diff options
Diffstat (limited to 'parsing')
64 files changed, 5321 insertions, 8693 deletions
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index e6d9f99d..650afe17 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -6,12 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: argextend.ml4,v 1.9.2.4 2005/01/15 14:56:53 herbelin Exp $ *) +(* $Id: argextend.ml4 7739 2005-12-26 17:08:16Z herbelin $ *) open Genarg open Q_util open Q_coqast -open Ast let join_loc (deb1,_) (_,fin2) = (deb1,fin2) let loc = Util.dummy_loc @@ -25,16 +24,15 @@ let rec make_rawwit loc = function | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >> | IdentArgType -> <:expr< Genarg.rawwit_ident >> - | HypArgType -> <:expr< Genarg.rawwit_var >> + | VarArgType -> <:expr< Genarg.rawwit_var >> | RefArgType -> <:expr< Genarg.rawwit_ref >> | SortArgType -> <:expr< Genarg.rawwit_sort >> | ConstrArgType -> <:expr< Genarg.rawwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >> | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >> - | TacticArgType -> <:expr< Genarg.rawwit_tactic >> + | TacticArgType n -> <:expr< Genarg.rawwit_tactic $mlexpr_of_int n$ >> | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >> - | OpenConstrArgType -> <:expr< Genarg.rawwit_open_constr >> - | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >> + | OpenConstrArgType b -> <:expr< Genarg.rawwit_open_constr_gen $mlexpr_of_bool b$ >> | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >> | BindingsArgType -> <:expr< Genarg.rawwit_bindings >> | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >> @@ -52,16 +50,15 @@ let rec make_globwit loc = function | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >> | IdentArgType -> <:expr< Genarg.globwit_ident >> - | HypArgType -> <:expr< Genarg.globwit_var >> + | VarArgType -> <:expr< Genarg.globwit_var >> | RefArgType -> <:expr< Genarg.globwit_ref >> | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >> | SortArgType -> <:expr< Genarg.globwit_sort >> | ConstrArgType -> <:expr< Genarg.globwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >> - | TacticArgType -> <:expr< Genarg.globwit_tactic >> + | TacticArgType n -> <:expr< Genarg.globwit_tactic $mlexpr_of_int n$ >> | RedExprArgType -> <:expr< Genarg.globwit_red_expr >> - | OpenConstrArgType -> <:expr< Genarg.globwit_open_constr >> - | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >> + | OpenConstrArgType b -> <:expr< Genarg.globwit_open_constr_gen $mlexpr_of_bool b$ >> | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >> | BindingsArgType -> <:expr< Genarg.globwit_bindings >> | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >> @@ -79,16 +76,15 @@ let rec make_wit loc = function | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >> | IdentArgType -> <:expr< Genarg.wit_ident >> - | HypArgType -> <:expr< Genarg.wit_var >> + | VarArgType -> <:expr< Genarg.wit_var >> | RefArgType -> <:expr< Genarg.wit_ref >> | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> | SortArgType -> <:expr< Genarg.wit_sort >> | ConstrArgType -> <:expr< Genarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >> - | TacticArgType -> <:expr< Genarg.wit_tactic >> + | TacticArgType n -> <:expr< Genarg.wit_tactic $mlexpr_of_int n$ >> | RedExprArgType -> <:expr< Genarg.wit_red_expr >> - | OpenConstrArgType -> <:expr< Genarg.wit_open_constr >> - | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >> + | OpenConstrArgType b -> <:expr< Genarg.wit_open_constr_gen $mlexpr_of_bool b$ >> | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >> | BindingsArgType -> <:expr< Genarg.wit_bindings >> | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >> @@ -105,7 +101,8 @@ let make_act loc act pil = | Some (p, t) :: tl -> <:expr< Gramext.action - (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) + (fun $lid:p$ -> + let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> in make (List.rev pil) @@ -113,22 +110,34 @@ let make_rule loc (prods,act) = let (symbs,pil) = List.split prods in <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >> -let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl = - let interp = match f with - | None -> <:expr< Tacinterp.interp_genarg >> - | Some f -> <:expr< $lid:f$>> in - let glob = match g with - | None -> <:expr< Tacinterp.intern_genarg >> - | Some f -> <:expr< $lid:f$>> in - let substitute = match h with - | None -> <:expr< Tacinterp.subst_genarg >> - | Some f -> <:expr< $lid:f$>> in +let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = let rawtyp, rawpr = match rawtyppr with | None -> typ,pr | Some (t,p) -> t,p in let globtyp, globpr = match globtyppr with | None -> typ,pr | Some (t,p) -> t,p in + let glob = match g with + | None -> + <:expr< fun e x -> + out_gen $make_globwit loc typ$ + (Tacinterp.intern_genarg e + (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >> + | Some f -> <:expr< $lid:f$>> in + let interp = match f with + | None -> + <:expr< fun ist gl x -> + out_gen $make_wit loc typ$ + (Tacinterp.interp_genarg ist gl + (Genarg.in_gen $make_globwit loc globtyp$ x)) >> + | Some f -> <:expr< $lid:f$>> in + let substitute = match h with + | None -> + <:expr< fun s x -> + out_gen $make_globwit loc globtyp$ + (Tacinterp.subst_genarg s + (Genarg.in_gen $make_globwit loc globtyp$ x)) >> + | Some f -> <:expr< $lid:f$>> in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in let rawwit = <:expr< $lid:"rawwit_"^s$ >> in @@ -141,36 +150,22 @@ let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl = value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; Tacinterp.add_interp_genarg $se$ ((fun e x -> - (in_gen $globwit$ - (out_gen $make_globwit loc typ$ - ($glob$ e - (in_gen $make_rawwit loc rawtyp$ - (out_gen $rawwit$ x)))))), + (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))), (fun ist gl x -> - (in_gen $wit$ - (out_gen $make_wit loc typ$ - ($interp$ ist gl - (in_gen $make_globwit loc rawtyp$ - (out_gen $globwit$ x)))))), + (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))), (fun subst x -> - (in_gen $globwit$ - (out_gen $make_globwit loc typ$ - ($substitute$ subst - (in_gen $make_globwit loc rawtyp$ - (out_gen $globwit$ x))))))); + (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x))))); Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None [(None, None, $rules$)]; Pptactic.declare_extra_genarg_pprule - $mlexpr_of_bool for_v8$ ($rawwit$, $lid:rawpr$) ($globwit$, $lid:globpr$) ($wit$, $lid:pr$); end >> -let declare_vernac_argument for_v8 loc s cl = +let declare_vernac_argument loc s cl = let se = mlexpr_of_string s in - let typ = ExtraArgType s in let rawwit = <:expr< $lid:"rawwit_"^s$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in <:str_item< @@ -238,40 +233,17 @@ EXTEND "END" -> if String.capitalize s = s then failwith "Argument entry names must be lowercase"; - declare_tactic_argument true loc s typ pr f g h rawtyppr globtyppr l + declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> if String.capitalize s = s then failwith "Argument entry names must be lowercase"; - declare_vernac_argument true loc s l - | "V7"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; - "TYPED"; "AS"; typ = argtype; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - rawtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; - "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; - globtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; - "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; - declare_tactic_argument false loc s typ pr f g h rawtyppr globtyppr l - | "V7"; "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; - declare_vernac_argument false loc s l ] ] + declare_vernac_argument loc s l ] ] ; argtype: - [ "2" RIGHTA - [ e1 = argtype; "*"; e2 = NEXT -> PairArgType (e1, e2) ] + [ "2" + [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] | "1" [ e = argtype; LIDENT "list" -> List0ArgType e | e = argtype; LIDENT "option" -> OptArgType e ] @@ -288,7 +260,8 @@ EXTEND | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Pcoq.lexer.Token.using ("", s); - (<:expr< (Gramext.Stoken (Extend.terminal $str:s$)) >>, None) + (<:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>, None) ] ] ; END + diff --git a/parsing/ast.ml b/parsing/ast.ml deleted file mode 100755 index b2a30f9c..00000000 --- a/parsing/ast.ml +++ /dev/null @@ -1,600 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ast.ml,v 1.29.2.1 2004/07/16 19:30:37 herbelin Exp $ *) - -open Pp -open Util -open Names -open Libnames -open Coqast -open Topconstr -open Genarg - -let isMeta s = String.length s <> 0 & s.[0]='$' - -let loc = function - | Node (loc,_,_) -> loc - | Nvar (loc,_) -> loc - | Nmeta (loc,_) -> loc - | Slam (loc,_,_) -> loc - | Smetalam (loc,_,_) -> loc - | Num (loc,_) -> loc - | Id (loc,_) -> loc - | Str (loc,_) -> loc - | Path (loc,_) -> loc - | Dynamic (loc,_) -> loc - -(* patterns of ast *) -type astpat = - | Pquote of t - | Pmeta of string * tok_kind - | Pnode of string * patlist - | Pslam of identifier option * astpat - | Pmeta_slam of string * astpat - -and patlist = - | Pcons of astpat * patlist - | Plmeta of string - | Pnil - -and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist - -type pat = - | AstListPat of patlist - | PureAstPat of astpat - -(* building a node with dummy location *) - -let ope(op,l) = Node(dummy_loc,op,l) -let slam(idl,b) = Slam(dummy_loc,idl,b) -let ide s = Id(dummy_loc,s) -let nvar s = Nvar(dummy_loc,s) -let num n = Num(dummy_loc,n) -let string s = Str(dummy_loc,s) -let path sl = Path(dummy_loc,sl) -let dynamic d = Dynamic(dummy_loc,d) - -let rec set_loc loc = function - | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al) - | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b) - | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b) - | Nvar(_,s) -> Nvar(loc,s) - | Nmeta(_,s) -> Nmeta(loc,s) - | Id(_,s) -> Id(loc,s) - | Str(_,s) -> Str(loc,s) - | Num(_,s) -> Num(loc,s) - | Path(_,sl) -> Path(loc,sl) - | Dynamic(_,d) -> Dynamic(loc,d) - -let path_section loc sp = Coqast.Path(loc, sp) - -let section_path sp = sp - -(* ast destructors *) -let num_of_ast = function - | Num(_,n) -> n - | ast -> invalid_arg_loc (loc ast, "Ast.num_of_ast") - -let nvar_of_ast = function - | Nvar(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -let meta_of_ast = function - | Nmeta(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -let id_of_ast = function - | Id(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -(* semantic actions of grammar rules *) -type act = - | Act of constr_expr - | ActCase of act * (pat * act) list - | ActCaseList of act * (pat * act) list - -(* values associated to variables *) -(* -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t -*) -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t - -type ast_action_type = ETast | ETastl - -type dynamic_grammar = - | ConstrNode of constr_expr - | CasesPatternNode of cases_pattern_expr - -type grammar_action = - | SimpleAction of loc * dynamic_grammar - | CaseAction of - loc * grammar_action * ast_action_type * (t list * grammar_action) list - -type env = (string * typed_ast) list - -let string_of_dirpath = function - | [] -> "<empty>" - | sl -> - String.concat "." (List.map string_of_id (List.rev sl)) - -let pr_id id = str (string_of_id id) - -let print_kn kn = - let (mp,dp,l) = repr_kn kn in - let dpl = repr_dirpath dp in - str (string_of_mp mp) ++ str "." ++ - prlist_with_sep (fun _ -> str".") pr_id dpl ++ - str (string_of_label l) - -(* Pretty-printing *) -let rec print_ast ast = - match ast with - | Num(_,n) -> int n - | Str(_,s) -> qs s - | Path(_,sl) -> print_kn sl - | Id (_,s) -> str "{" ++ str s ++ str "}" - | Nvar(_,s) -> pr_id s - | Nmeta(_,s) -> str s - | Node(_,op,l) -> - hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")") - | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast) - | Slam(_,Some x,ast) -> - hov 1 - (str "[" ++ pr_id x ++ str "]" ++ cut () ++ - print_ast ast) - | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast) - | Dynamic(_,d) -> - hov 0 (str "<dynamic: " ++ str (Dyn.tag d) ++ str ">") - -and print_astl astl = - prlist_with_sep pr_spc print_ast astl - -let print_ast_cast = function - | Tany -> (mt ()) - | Tvar -> (str":var") - | Tid -> (str":id") - | Tstr -> (str":str") - | Tpath -> (str":path") - | Tnum -> (str":num") - | Tlist -> (str":list") - -let rec print_astpat = function - | Pquote ast -> - str"'" ++ print_ast ast - | Pmeta(s,tk) -> - str s ++ print_ast_cast tk - | Pmeta_slam(s,b) -> - hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b) - | Pnode(op,al) -> - hov 2 (str"(" ++ str op ++ spc () ++ print_astlpat al ++ str")" ) - | Pslam(None,b) -> - hov 1 (str"[<" ++ cut () ++ print_astpat b) - | Pslam(Some id,b) -> - hov 1 - (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b) - -and print_astlpat = function - | Pnil -> mt () - | Pcons(h,Pnil) -> hov 1 (print_astpat h) - | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t) - | Plmeta(s) -> str"| " ++ str s - - -let print_val = function - | PureAstNode a -> print_ast a - | AstListNode al -> - hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]") - -(* Ast values environments *) - -let grammar_type_error (loc,s) = - anomaly_loc (loc,s,(str"grammar type error: " ++ str s)) - - -(* Coercions enforced by the user *) -let check_cast loc a k = - match (k,a) with - | (Tany, _) -> () - | (Tid, Id _) -> () - | (Tvar, Nvar _) -> () - | (Tpath, Path _) -> () - | (Tstr, Str _) -> () - | (Tnum, Num _) -> () - | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val") - | _ -> user_err_loc (loc,"Ast.cast_val", - (str"cast _" ++ print_ast_cast k ++ str"failed")) - -let rec coerce_to_var = function - | Nvar(_,id) as var -> var - | Nmeta(_,id) as var -> var - | Node(_,"QUALID",[Nvar(_,id) as var]) -> var - | ast -> user_err_loc - (loc ast,"Ast.coerce_to_var", - (str"This expression should be a simple identifier")) - -let coerce_to_id_ast a = match coerce_to_var a with - | Nvar (_,id) -> id - | ast -> user_err_loc - (loc ast,"Ast.coerce_to_id", - str"This expression should be a simple identifier") - -let coerce_to_id = function - | CRef (Ident (loc,id)) -> (loc,id) - | a -> user_err_loc - (constr_loc a,"Ast.coerce_to_id", - str"This expression should be a simple identifier") - -let coerce_reference_to_id = function - | Ident (_,id) -> id - | Qualid (loc,_) -> - user_err_loc (loc, "Ast.coerce_reference_to_id", - str"This expression should be a simple identifier") - -let coerce_global_to_id = coerce_reference_to_id - -(* Pattern-matching on ast *) - -let env_assoc_value loc v env = - try - List.assoc v env - with Not_found -> - anomaly_loc - (loc,"Ast.env_assoc_value", - (str"metavariable " ++ str v ++ str" is unbound")) - -let env_assoc_list sigma (loc,v) = - match env_assoc_value loc v sigma with - | AstListNode al -> al - | PureAstNode a -> [a] - -let env_assoc sigma k (loc,v) = - match env_assoc_value loc v sigma with - | PureAstNode a -> check_cast loc a k; a - | _ -> grammar_type_error (loc,"Ast.env_assoc: "^v^" is an ast list") - -let env_assoc_nvars sigma (dloc,v) = - match env_assoc_value dloc v sigma with - | AstListNode al -> List.map coerce_to_id_ast al - | PureAstNode ast -> [coerce_to_id_ast ast] - -let build_lams dloc idl ast = - List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast - -(* Alpha-conversion *) - -let rec alpha_var id1 id2 = function - | (i1,i2)::_ when i1=id1 -> i2 = id2 - | (i1,i2)::_ when i2=id2 -> i1 = id1 - | _::idl -> alpha_var id1 id2 idl - | [] -> id1 = id2 - -let rec alpha alp a1 a2 = - match (a1,a2) with - | (Node(_,op1,tl1),Node(_,op2,tl2)) -> - (op1 = op2) & (List.length tl1 = List.length tl2) - & (List.for_all2 (alpha alp) tl1 tl2) - | (Nvar(_,id1),Nvar(_,id2)) -> alpha_var id1 id2 alp - | (Slam(_,None,body1),Slam(_,None,body2)) -> alpha alp body1 body2 - | (Slam(_,Some s1,body1),Slam(_,Some s2,body2)) -> - alpha ((s1,s2)::alp) body1 body2 - | (Id(_,s1),Id(_,s2)) -> s1=s2 - | (Str(_,s1),Str(_,s2)) -> s1=s2 - | (Num(_,n1),Num(_,n2)) -> n1=n2 - | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2 - | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false - | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false - | _ -> false - -let alpha_eq (a1,a2)= alpha [] a1 a2 - -let alpha_eq_val (x,y) = x = y -(* -let alpha_eq_val = function - | (Vast a1, Vast a2) -> alpha_eq (a1,a2) - | (Vastlist al1, Vastlist al2) -> - (List.length al1 = List.length al2) - & List.for_all2 (fun x y -> alpha_eq (x,y)) al1 al2 - | _ -> false -*) - -exception No_match of string - -let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s) - -(* Binds value v to variable var. If var is already bound, checks if - its value is alpha convertible with v. This allows non-linear patterns. - - Important note: The Metavariable $_ is a special case; it cannot be - bound, which is like _ in the ML matching. *) - -let bind_env sigma var v = - if var = "$_" then - sigma - else - try - let vvar = List.assoc var sigma in - if alpha_eq_val (v,vvar) then sigma - else raise (No_match "Ast.bind_env: values do not match") - with Not_found -> - (var,v)::sigma - -let bind_env_ast sigma var ast = - try - bind_env sigma var (PureAstNode ast) - with e -> - Stdpp.raise_with_loc (loc ast) e - -let alpha_define sigma loc ps s = - try - let _ = List.assoc ps sigma in sigma - with Not_found -> - if ps = "$_" then sigma else (ps, PureAstNode(Nvar(loc,s)))::sigma - - -(* Match an ast with an ast pattern. Returns the new environnement. *) - -let rec amatch alp sigma spat ast = - match (spat,ast) with - | (Pquote a, _) -> - if alpha alp a ast then - sigma - else - no_match_loc (loc ast,"quote does not match") - | (Pmeta(pv,Tany), _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tvar), Nvar _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tid), Id _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tnum), Num _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tstr), Str _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tpath), Path _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch") - | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) -> - amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b - | (Pmeta_slam(pv,pb), Slam(loc, None, b)) -> - amatch alp (bind_env_ast sigma pv (Nvar(loc,id_of_string "_"))) pb b - | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) -> - anomaly "amatch: match a pattern with an open ast" - | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op -> - (try amatchl alp sigma argp args - with e -> Stdpp.raise_with_loc loc e) - | (Pslam(None,bp), Slam(_,None,b)) -> amatch alp sigma bp b - | (Pslam(Some ps,bp), Slam(_,Some s,b)) -> amatch ((ps,s)::alp) sigma bp b - | _ -> no_match_loc (loc ast, "Ast.amatch") - -and amatchl alp sigma spatl astl = - match (spatl,astl) with - | (Pnil, []) -> sigma - | (Pcons(pat,patl), ast::asttl) -> - amatchl alp (amatch alp sigma pat ast) patl asttl - | (Plmeta pv, _) -> bind_env sigma pv (AstListNode astl) - | _ -> raise (No_match "Ast.amatchl") - -let ast_match = amatch [] - -let typed_ast_match env p a = match (p,a) with - | PureAstPat p, PureAstNode a -> amatch [] env p a - | AstListPat pl, AstListNode al -> amatchl [] env pl al - | _ -> failwith "Ast.typed_ast_match: TODO" - -let astl_match = amatchl [] - -let first_match pat_of_fun env ast sl = - let rec aux = function - | [] -> None - | h::t -> - (try Some (h, ast_match env (pat_of_fun h) ast) - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) - in - aux sl - -let find_all_matches pat_of_fun env ast sl = - let rec aux = function - | [] -> [] - | (h::t) -> - let l = aux t in - (try (h, ast_match env (pat_of_fun h) ast)::l - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> l) - in - aux sl - -let first_matchl patl_of_fun env astl sl = - let rec aux = function - | [] -> None - | (h::t) -> - (try Some (h, astl_match env (patl_of_fun h) astl) - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) - in - aux sl - -let bind_patvar env loc v etyp = - try - if List.assoc v env = etyp then - env - else - user_err_loc - (loc,"Ast.bind_patvar", - (str"variable " ++ str v ++ - str" is bound several times with different types")) - with Not_found -> - if v="$_" then env else (v,etyp)::env - -let make_astvar env loc v cast = - let env' = bind_patvar env loc v ETast in - (Pmeta(v,cast), env') - -(* Note: no metavar in operator position. necessary ? *) -let rec pat_of_ast env ast = - match ast with - | Nmeta(loc,pv) -> make_astvar env loc pv Tany -(* Obsolète - | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid -*) - | Smetalam(loc,s,a) -> - let senv = bind_patvar env loc s ETast in - let (pa,env') = pat_of_ast senv a in - (Pmeta_slam(s, pa), env') - | Node(_,"$VAR",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tvar - | Node(_,"$ID",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tid - | Node(_,"$NUM",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tnum - | Node(_,"$STR",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tstr - | Node(_,"$PATH",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tpath - | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env) - - (* This may occur when the meta is not textual but bound by coerce_to_id*) - | Slam(loc,Some id,b) when isMeta (string_of_id id) -> - let s = string_of_id id in - let senv = bind_patvar env loc s ETast in - let (pb,env') = pat_of_ast senv b in - (Pmeta_slam(s, pb), env') - - | Slam(_,os,b) -> - let (pb,env') = pat_of_ast env b in - (Pslam(os,pb), env') - | Node(loc,op,_) when isMeta op -> - user_err_loc(loc,"Ast.pat_of_ast", - (str"no patvar in operator position.")) - | Node(_,op,args) -> - let (pargs, env') = patl_of_astl env args in - (Pnode(op,pargs), env') -(* Compatibility with new parsing mode *) - | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany - | (Path _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env) - | Dynamic(loc,_) -> - invalid_arg_loc(loc,"pat_of_ast: dynamic") - -and patl_of_astl env astl = - match astl with - | [Node(_,"$LIST",[Nmeta(loc,pv)])] -> - let penv = bind_patvar env loc pv ETastl in - (Plmeta pv, penv) - | [] -> (Pnil,env) - | ast::asttl -> - let (p1,env1) = pat_of_ast env ast in - let (ptl,env2) = patl_of_astl env1 asttl in - (Pcons (p1,ptl), env2) - -type entry_env = (string * ast_action_type) list - -let to_pat = pat_of_ast - -(* Substitution *) - -(* Locations in quoted ast are wrong (they refer to the right hand - side of a grammar rule). A default location dloc is used whenever - we create an ast constructor. Locations in the binding list are trusted. *) - -(* For old ast printer *) -let rec pat_sub dloc sigma pat = - match pat with - | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) - | Pmeta_slam(pv,p) -> - let idl = env_assoc_nvars sigma (dloc,pv) in - build_lams dloc idl (pat_sub dloc sigma p) - | Pquote a -> set_loc dloc a - | Pnode(op,pl) -> Node(dloc, op, patl_sub dloc sigma pl) - | Pslam(os,p) -> Slam(dloc, os, pat_sub dloc sigma p) - -and patl_sub dloc sigma pl = - match pl with - | Pnil -> - [] - | Plmeta pv -> - env_assoc_list sigma (dloc,pv) - | Pcons(Pmeta(pv,Tlist), ptl) -> - (env_assoc_list sigma (dloc,pv))@(patl_sub dloc sigma ptl) - | Pcons(p1,ptl) -> - (pat_sub dloc sigma p1)::(patl_sub dloc sigma ptl) - -(* Converting and checking free meta-variables *) - -(* For old ast printer *) -let type_of_meta env loc pv = - try - List.assoc pv env - with Not_found -> - user_err_loc (loc,"Ast.type_of_meta", - (str"variable " ++ str pv ++ str" is unbound")) - -(* For old ast printer *) -let check_ast_meta env loc pv = - match type_of_meta env loc pv with - | ETast -> () - | _ -> - user_err_loc (loc,"Ast.check_ast_meta", - (str"variable " ++ str pv ++ str" is not of ast type")) - -(* For old ast printer *) -let rec val_of_ast env = function - | Nmeta(loc,pv) -> - check_ast_meta env loc pv; - Pmeta(pv,Tany) - | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast) - | Smetalam(loc,s,a) -> - let _ = type_of_meta env loc s in (* ids are coerced to id lists *) - Pmeta_slam(s, val_of_ast env a) - | (Path _|Num _|Id _|Str _|Nvar _ as ast) -> Pquote (set_loc dummy_loc ast) - | Slam(_,os,b) -> Pslam(os, val_of_ast env b) - | Node(loc,op,_) when isMeta op -> - user_err_loc(loc,"Ast.val_of_ast", - (str"no patvar in operator position.")) - | Node(_,op,args) -> Pnode(op, vall_of_astl env args) - | Dynamic(loc,_) -> - invalid_arg_loc(loc,"val_of_ast: dynamic") - -and vall_of_astl env = function - | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl -> - if type_of_meta env locv pv = ETastl then - if asttl = [] then - Plmeta pv - else - Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl) - else - user_err_loc - (loc,"Ast.vall_of_astl", - str"variable " ++ str pv ++ str" is not a List") - | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl) - | [] -> Pnil - -(* For old ast printer *) -let rec occur_var_ast s = function - | Node(_,"QUALID",_::_::_) -> false - | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2 - | Nvar(_,s2) -> s = s2 - | Node(loc,op,args) -> List.exists (occur_var_ast s) args - | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here" - | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body - | Id _ | Str _ | Num _ | Path _ -> false - | Dynamic _ -> (* Hum... what to do here *) false - - -(**********************************************************************) -(* Object substitution in modules *) - -let rec subst_astpat subst = function - | Pquote a -> Pquote (subst_ast subst a) - | Pmeta _ as p -> p - | Pnode (s,pl) -> Pnode (s,subst_astpatlist subst pl) - | Pslam (ido,p) -> Pslam (ido,subst_astpat subst p) - | Pmeta_slam (s,p) -> Pmeta_slam (s,subst_astpat subst p) - -and subst_astpatlist subst = function - | Pcons (p,pl) -> Pcons (subst_astpat subst p, subst_astpatlist subst pl) - | (Plmeta _ | Pnil) as pl -> pl - -let subst_pat subst = function - | AstListPat pl -> AstListPat (subst_astpatlist subst pl) - | PureAstPat p -> PureAstPat (subst_astpat subst p) diff --git a/parsing/ast.mli b/parsing/ast.mli deleted file mode 100755 index 7bc0b607..00000000 --- a/parsing/ast.mli +++ /dev/null @@ -1,123 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: ast.mli,v 1.17.2.1 2004/07/16 19:30:37 herbelin Exp $ i*) - -(*i*) -open Pp -open Util -open Names -open Libnames -open Coqast -open Topconstr -open Genarg -(*i*) - -(* Abstract syntax trees. *) - -val loc : Coqast.t -> loc - -(* ast constructors with dummy location *) -val ope : string * Coqast.t list -> Coqast.t -val slam : identifier option * Coqast.t -> Coqast.t -val nvar : identifier -> Coqast.t -val ide : string -> Coqast.t -val num : int -> Coqast.t -val string : string -> Coqast.t -val path : kernel_name -> Coqast.t -val dynamic : Dyn.t -> Coqast.t - -val set_loc : loc -> Coqast.t -> Coqast.t - -val path_section : loc -> kernel_name -> Coqast.t -val section_path : kernel_name -> kernel_name - -(* ast destructors *) -val num_of_ast : Coqast.t -> int -val id_of_ast : Coqast.t -> string -val nvar_of_ast : Coqast.t -> identifier -val meta_of_ast : Coqast.t -> string - -(* patterns of ast *) -type astpat = - | Pquote of t - | Pmeta of string * tok_kind - | Pnode of string * patlist - | Pslam of identifier option * astpat - | Pmeta_slam of string * astpat - -and patlist = - | Pcons of astpat * patlist - | Plmeta of string - | Pnil - -and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist - -type pat = - | AstListPat of patlist - | PureAstPat of astpat - -(* semantic actions of grammar rules *) -type act = - | Act of constr_expr - | ActCase of act * (pat * act) list - | ActCaseList of act * (pat * act) list - -(* values associated to variables *) -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t - -type ast_action_type = ETast | ETastl - -type dynamic_grammar = - | ConstrNode of constr_expr - | CasesPatternNode of cases_pattern_expr - -type grammar_action = - | SimpleAction of loc * dynamic_grammar - | CaseAction of - loc * grammar_action * ast_action_type * (t list * grammar_action) list - -type env = (string * typed_ast) list - -val coerce_to_id : constr_expr -> identifier located - -val coerce_global_to_id : reference -> identifier -val coerce_reference_to_id : reference -> identifier - -exception No_match of string - -val isMeta : string -> bool - -val print_ast : Coqast.t -> std_ppcmds -val print_astl : Coqast.t list -> std_ppcmds -val print_astpat : astpat -> std_ppcmds -val print_astlpat : patlist -> std_ppcmds - -(* Meta-syntax operations: matching and substitution *) - -type entry_env = (string * ast_action_type) list - -val grammar_type_error : loc * string -> 'a - -(* Converting and checking free meta-variables *) - -(* For old ast printer *) -val pat_sub : loc -> env -> astpat -> Coqast.t -val val_of_ast : entry_env -> Coqast.t -> astpat -val alpha_eq : Coqast.t * Coqast.t -> bool -val alpha_eq_val : typed_ast * typed_ast -> bool -val occur_var_ast : identifier -> Coqast.t -> bool -val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list -val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list -> - ('a * env) option -val to_pat : entry_env -> Coqast.t -> (astpat * entry_env) - -(* Object substitution in modules *) -val subst_astpat : Names.substitution -> astpat -> astpat diff --git a/parsing/coqast.ml b/parsing/coqast.ml deleted file mode 100644 index 0f447766..00000000 --- a/parsing/coqast.ml +++ /dev/null @@ -1,123 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: coqast.ml,v 1.9.6.1 2004/07/16 19:30:37 herbelin Exp $ *) - -(*i*) -open Util -open Names -open Libnames -(*i*) - -type t = - | Node of loc * string * t list - | Nmeta of loc * string - | Nvar of loc * identifier - | Slam of loc * identifier option * t - | Smetalam of loc * string * t - | Num of loc * int - | Str of loc * string - | Id of loc * string - | Path of loc * kernel_name - | Dynamic of loc * Dyn.t - -type the_coq_ast = t - -let subst_meta bl ast = - let rec aux = function - | Node (_,"META", [Num(_, n)]) -> List.assoc n bl - | Node(loc, node_name, args) -> - Node(loc, node_name, List.map aux args) - | Slam(loc, var, arg) -> Slam(loc, var, aux arg) - | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg) - | other -> other - in - aux ast - -let rec collect_metas = function - | Node (_,"META", [Num(_, n)]) -> [n] - | Node(_, _, args) -> List.concat (List.map collect_metas args) - | Slam(loc, var, arg) -> collect_metas arg - | Smetalam(loc, var, arg) -> collect_metas arg - | _ -> [] - -(* Hash-consing *) -module Hloc = Hashcons.Make( - struct - type t = loc - type u = unit - let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2 - let hash_sub () x = x - let hash = Hashtbl.hash - end) - -module Hast = Hashcons.Make( - struct - type t = the_coq_ast - type u = - (the_coq_ast -> the_coq_ast) * - ((loc -> loc) * (string -> string) - * (identifier -> identifier) * (kernel_name -> kernel_name)) - let hash_sub (hast,(hloc,hstr,hid,hsp)) = function - | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al) - | Nmeta(l,s) -> Nmeta(hloc l, hstr s) - | Nvar(l,s) -> Nvar(hloc l, hid s) - | Slam(l,None,t) -> Slam(hloc l, None, hast t) - | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t) - | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t) - | Num(l,n) -> Num(hloc l, n) - | Id(l,s) -> Id(hloc l, hstr s) - | Str(l,s) -> Str(hloc l, hstr s) - | Path(l,d) -> Path(hloc l, hsp d) - | Dynamic(l,d) -> Dynamic(hloc l, d) - let equal a1 a2 = - match (a1,a2) with - | (Node(l1,s1,al1), Node(l2,s2,al2)) -> - (l1==l2 & s1==s2 & List.length al1 = List.length al2) - & List.for_all2 (==) al1 al2 - | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2 - | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2 - | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2 - | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2 - | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2 - | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2 - | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2 - | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2 - | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2) - | _ -> false - let hash = Hashtbl.hash - end) - -let hcons_ast (hstr,hid,hpath) = - let hloc = Hashcons.simple_hcons Hloc.f () in - let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath) in - (hast,hloc) - -let rec subst_ast subst ast = match ast with - | Node (l,s,astl) -> - let astl' = Util.list_smartmap (subst_ast subst) astl in - if astl' == astl then ast else - Node (l,s,astl') - | Slam (l,ido,ast1) -> - let ast1' = subst_ast subst ast1 in - if ast1' == ast1 then ast else - Slam (l,ido,ast1') - | Smetalam (l,s,ast1) -> - let ast1' = subst_ast subst ast1 in - if ast1' == ast1 then ast else - Smetalam (l,s,ast1') - | Path (loc,kn) -> - let kn' = Names.subst_kn subst kn in - if kn' == kn then ast else - Path(loc,kn') - | Nmeta _ - | Nvar _ -> ast - | Num _ - | Str _ - | Id _ - | Dynamic _ -> ast diff --git a/parsing/coqast.mli b/parsing/coqast.mli deleted file mode 100644 index 0b1138f2..00000000 --- a/parsing/coqast.mli +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: coqast.mli,v 1.10.6.2 2005/01/21 16:42:36 herbelin Exp $ i*) - -(*i*) -open Util -open Names -open Libnames -(*i*) - -(* Abstract syntax trees. *) - -type t = - | Node of loc * string * t list - | Nmeta of loc * string - | Nvar of loc * identifier - | Slam of loc * identifier option * t - | Smetalam of loc * string * t - | Num of loc * int - | Str of loc * string - | Id of loc * string - | Path of loc * kernel_name - | Dynamic of loc * Dyn.t - -(* returns the list of metas occuring in the ast *) -val collect_metas : t -> int list - -(* [subst_meta bl ast]: for each binding [(i,c_i)] in [bl], - replace the metavar [?i] by [c_i] in [ast] *) -val subst_meta : (int * t) list -> t -> t - -(* hash-consing function *) -val hcons_ast: - (string -> string) * (Names.identifier -> Names.identifier) - * (kernel_name -> kernel_name) - -> (t -> t) * (loc -> loc) - -val subst_ast: Names.substitution -> t -> t - -(*i -val map_tactic_expr : (t -> t) -> (tactic_expr -> tactic_expr) -> tactic_expr -> tactic_expr -val fold_tactic_expr : - ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a -val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit -i*) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 09889d40..c723175c 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -6,64 +6,31 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: egrammar.ml,v 1.48.2.4 2005/12/23 22:16:46 herbelin Exp $ *) +(* $Id: egrammar.ml 7762 2005-12-30 10:55:33Z herbelin $ *) open Pp open Util -open Ppextend -open Extend open Pcoq +open Extend open Topconstr -open Ast open Genarg open Libnames open Nameops - -(* State of the grammar extensions *) - -type notation_grammar = - int * Gramext.g_assoc option * notation * prod_item list * int list option - -type all_grammar_command = - | Notation of (precedence * tolerability list) * notation_grammar - | Grammar of grammar_command - | TacticGrammar of - (string * (string * grammar_production list) * - (Names.dir_path * Tacexpr.raw_tactic_expr)) - list * (string * Genarg.argument_type list * - (string * Pptactic.grammar_terminals)) list - -let subst_all_grammar_command subst = function - | Notation _ -> anomaly "Notation not in GRAMMAR summary" - | Grammar gc -> Grammar (subst_grammar_command subst gc) - | TacticGrammar (g,p) -> TacticGrammar (g,p) (* TODO ... *) - -let (grammar_state : all_grammar_command list ref) = ref [] - +open Tacexpr +open Names +open Vernacexpr (**************************************************************************) -(* Interpretation of the right hand side of grammar rules *) - -(* When reporting errors, we add the name of the grammar rule that failed *) -let specify_name name e = - match e with - | UserError(lab,strm) -> - UserError(lab, (str"during interpretation of grammar rule " ++ - str name ++ str"," ++ spc () ++ strm)) - | Anomaly(lab,strm) -> - Anomaly(lab, (str"during interpretation of grammar rule " ++ - str name ++ str"," ++ spc () ++ strm)) - | Failure s -> - Failure("during interpretation of grammar rule "^name^", "^s) - | e -> e - -(* Translation of environments: a production +(* + * --- Note on the mapping of grammar productions to camlp4 actions --- + * + * Translation of environments: a production * [ nt1(x1) ... nti(xi) ] -> act(x1..xi) * is written (with camlp4 conventions): * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) * where v1..vi are the values generated by non-terminals nt1..nti. * Since the actions are executed by substituting an environment, - * make_act builds the following closure: + * the make_*_action family build the following closure: * * ((fun env -> * (fun vi -> @@ -77,11 +44,18 @@ let specify_name name e = * []) *) -open Names +(**********************************************************************) +(** Declare Notations grammar rules *) + +type prod_item = + | Term of Token.pattern + | NonTerm of constr_production_entry * + (Names.identifier * constr_production_entry) option type 'a action_env = (identifier * 'a) list -let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = +let make_constr_action + (f : loc -> constr_expr action_env -> constr_expr) pil = let rec make (env : constr_expr action_env) = function | [] -> Gramext.action (fun loc -> f loc env) @@ -95,8 +69,8 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = Gramext.action (fun (v:identifier) -> make ((p,CRef (Ident (dummy_loc,v))) :: env) tl) | Some (p, ETBigint) :: tl -> (* non-terminal *) - Gramext.action (fun (v:Bignat.bigint) -> - make ((p,CNumeral (dummy_loc,v)) :: env) tl) + Gramext.action (fun (v:Bigint.bigint) -> + make ((p,CPrim (dummy_loc,Numeral v)) :: env) tl) | Some (p, ETConstrList _) :: tl -> Gramext.action (fun (v:constr_expr list) -> let dummyid = Ident (dummy_loc,id_of_string "") in @@ -105,7 +79,7 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = failwith "Unexpected entry of type cases pattern" in make [] (List.rev pil) -let make_act_in_cases_pattern (* For Notations *) +let make_cases_pattern_action (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = let rec make (env : cases_pattern_expr action_env) = function | [] -> @@ -121,8 +95,8 @@ let make_act_in_cases_pattern (* For Notations *) Gramext.action (fun (v:identifier) -> make ((p,CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))) :: env) tl) | Some (p, ETBigint) :: tl -> (* non-terminal *) - Gramext.action (fun (v:Bignat.bigint) -> - make ((p,CPatNumeral (dummy_loc,v)) :: env) tl) + Gramext.action (fun (v:Bigint.bigint) -> + make ((p,CPatPrim (dummy_loc,Numeral v)) :: env) tl) | Some (p, ETConstrList _) :: tl -> Gramext.action (fun (v:cases_pattern_expr list) -> let dummyid = Ident (dummy_loc,id_of_string "") in @@ -131,183 +105,37 @@ let make_act_in_cases_pattern (* For Notations *) failwith "Unexpected entry of type cases pattern or other" in make [] (List.rev pil) -(* For V7 Grammar only *) -let make_cases_pattern_act - (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = - let rec make (env : cases_pattern_expr action_env) = function - | [] -> - Gramext.action (fun loc -> f loc env) - | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) - | Some (p, ETPattern) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,v) :: env) tl) - | Some (p, ETReference) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,CPatAtom(dummy_loc,Some v)) :: env) - tl) - | Some (p, ETBigint) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,CPatNumeral(dummy_loc,v)) :: env) tl) - | Some (p, (ETConstrList _ | ETIdent | ETConstr _ | ETOther _)) :: tl -> - error "ident and constr entry not admitted in patterns cases syntax extensions" in - make [] (List.rev pil) - -(* Grammar extension command. Rules are assumed correct. - * Type-checking of grammar rules is done during the translation of - * ast to the type grammar_command. We only check that the existing - * entries have the type assumed in the grammar command (these types - * annotations are added when type-checking the command, function - * Extend.of_ast) *) - -let symbol_of_prod_item univ assoc from forpat = function +let make_constr_prod_item univ assoc from forpat = function | Term tok -> (Gramext.Stoken tok, None) | NonTerm (nt, ovar) -> let eobj = symbol_of_production assoc from forpat nt in (eobj, ovar) -let coerce_to_id = function - | CRef (Ident (_,id)) -> id - | c -> - user_err_loc (constr_loc c, "subst_rawconstr", - str"This expression should be a simple identifier") - -let coerce_to_ref = function - | CRef r -> r - | c -> - user_err_loc (constr_loc c, "subst_rawconstr", - str"This expression should be a simple reference") - -let subst_ref loc subst id = - try coerce_to_ref (List.assoc id subst) with Not_found -> Ident (loc,id) - -let subst_pat_id loc subst id = - try List.assoc id subst - with Not_found -> CPatAtom (loc,Some (Ident (loc,id))) - -let subst_id subst id = - try coerce_to_id (List.assoc id subst) with Not_found -> id - -(* -let subst_cases_pattern_expr a loc subs = - let rec subst = function - | CPatAlias (_,p,x) -> CPatAlias (loc,subst p,x) - (* No subst in compound pattern ? *) - | CPatCstr (_,ref,pl) -> CPatCstr (loc,ref,List.map subst pl) - | CPatAtom (_,Some (Ident (_,id))) -> subst_pat_id loc subs id - | CPatAtom (_,x) -> CPatAtom (loc,x) - | CPatNotation (_,ntn,l) -> CPatNotation - | CPatNumeral (_,n) -> CPatNumeral (loc,n) - | CPatDelimiters (_,key,p) -> CPatDelimiters (loc,key,subst p) - in subst a -*) - -let subst_constr_expr a loc subs = - let rec subst = function - | CRef (Ident (_,id)) -> - (try List.assoc id subs with Not_found -> CRef (Ident (loc,id))) - (* Temporary: no robust treatment of substituted binders *) - | CLambdaN (_,[],c) -> subst c - | CLambdaN (_,([],t)::bl,c) -> subst (CLambdaN (loc,bl,c)) - | CLambdaN (_,((_,na)::bl,t)::bll,c) -> - let na = name_app (subst_id subs) na in - CLambdaN (loc,[[loc,na],subst t], subst (CLambdaN (loc,(bl,t)::bll,c))) - | CProdN (_,[],c) -> subst c - | CProdN (_,([],t)::bl,c) -> subst (CProdN (loc,bl,c)) - | CProdN (_,((_,na)::bl,t)::bll,c) -> - let na = name_app (subst_id subs) na in - CProdN (loc,[[loc,na],subst t], subst (CProdN (loc,(bl,t)::bll,c))) - | CLetIn (_,(_,na),b,c) -> - let na = name_app (subst_id subs) na in - CLetIn (loc,(loc,na),subst b,subst c) - | CArrow (_,a,b) -> CArrow (loc,subst a,subst b) - | CAppExpl (_,(p,Ident (_,id)),l) -> - CAppExpl (loc,(p,subst_ref loc subs id),List.map subst l) - | CAppExpl (_,r,l) -> CAppExpl (loc,r,List.map subst l) - | CApp (_,(p,a),l) -> - CApp (loc,(p,subst a),List.map (fun (a,i) -> (subst a,i)) l) - | CCast (_,a,b) -> CCast (loc,subst a,subst b) - | CNotation (_,n,l) -> CNotation (loc,n,List.map subst l) - | CDelimiters (_,s,a) -> CDelimiters (loc,s,subst a) - | CHole _ | CEvar _ | CPatVar _ | CSort _ - | CNumeral _ | CDynamic _ | CRef _ as x -> x - | CCases (_,(po,rtntypo),a,bl) -> - (* TODO: apply g on the binding variables in pat... *) - let bl = List.map (fun (_,pat,rhs) -> (loc,pat,subst rhs)) bl in - CCases (loc,(option_app subst po,option_app subst rtntypo), - List.map (fun (tm,x) -> subst tm,x) a,bl) - | COrderedCase (_,s,po,a,bl) -> - COrderedCase (loc,s,option_app subst po,subst a,List.map subst bl) - | CLetTuple (_,nal,(na,po),a,b) -> - let na = option_app (name_app (subst_id subs)) na in - let nal = List.map (name_app (subst_id subs)) nal in - CLetTuple (loc,nal,(na,option_app subst po),subst a,subst b) - | CIf (_,c,(na,po),b1,b2) -> - let na = option_app (name_app (subst_id subs)) na in - CIf (loc,subst c,(na,option_app subst po),subst b1,subst b2) - | CFix (_,id,dl) -> - CFix (loc,id,List.map (fun (id,n,bl, t,d) -> - (id,n, - List.map(function - LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) - | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, - subst t,subst d)) dl) - | CCoFix (_,id,dl) -> - CCoFix (loc,id,List.map (fun (id,bl,t,d) -> - (id, - List.map(function - LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) - | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, - subst t,subst d)) dl) - in subst a - -(* For V7 Grammar only *) -let make_rule univ assoc etyp rule = - if not !Options.v7 then anomaly "No Grammar in new syntax"; - let pil = List.map (symbol_of_prod_item univ assoc etyp false) rule.gr_production in +let extend_constr entry (n,assoc,pos,p4assoc,name) mkact (forpat,pt) = + let univ = get_univ "constr" in + let pil = List.map (make_constr_prod_item univ assoc n forpat) pt in let (symbs,ntl) = List.split pil in - let act = match etyp with - | ETPattern -> - (* Ugly *) - let f loc env = match rule.gr_action, env with - | CRef (Ident(_,p)), [p',a] when p=p' -> a - | CDelimiters (_,s,CRef (Ident(_,p))), [p',a] when p=p' -> - CPatDelimiters (loc,s,a) - | _ -> error "Unable to handle this grammar extension of pattern" in - make_cases_pattern_act f ntl - | ETConstrList _ | ETIdent | ETBigint | ETReference -> error "Cannot extend" - | ETConstr _ | ETOther _ -> - make_act (subst_constr_expr rule.gr_action) ntl in - (symbs, act) + grammar_extend entry pos [(name, p4assoc, [symbs, mkact ntl])] -(* Rules of a level are entered in reverse order, so that the first rules - are applied before the last ones *) -(* For V7 Grammar only *) -let extend_entry univ (te, etyp, pos, name, ass, p4ass, rls) = - let rules = List.rev (List.map (make_rule univ ass etyp) rls) in - grammar_extend te pos [(name, p4ass, rules)] - -(* Defines new entries. If the entry already exists, check its type *) -let define_entry univ {ge_name=typ; gl_assoc=ass; gl_rules=rls} = - let e,lev,keepassoc = get_constr_entry false typ in - let pos,p4ass,name = find_position false keepassoc ass lev in - (e,typ,pos,name,ass,p4ass,rls) - -(* Add a bunch of grammar rules. Does not check if it is well formed *) -(* For V7 Grammar only *) -let extend_grammar_rules gram = - let univ = get_univ gram.gc_univ in - let tl = List.map (define_entry univ) gram.gc_entries in - List.iter (extend_entry univ) tl - -(* Add a grammar rules for tactics *) -type grammar_tactic_production = - | TacTerm of string - | TacNonTerm of loc * (Gram.te Gramext.g_symbol * argument_type) * string option +let extend_constr_notation (n,assoc,ntn,rule) = + (* Add the notation in constr *) + let mkact loc env = CNotation (loc,ntn,List.map snd env) in + let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in + let pos,p4assoc,name = find_position false keepassoc assoc level in + extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name) + (make_constr_action mkact) (false,rule); + (* Add the notation in cases_pattern *) + let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in + let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in + let pos,p4assoc,name = find_position true keepassoc assoc level in + extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name) + (make_cases_pattern_action mkact) (true,rule) -let make_prod_item = function - | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None) - | TacNonTerm (_,(nont,t), po) -> - (nont, option_app (fun p -> (p,t)) po) +(**********************************************************************) +(** Making generic actions in type generic_argument *) -let make_gen_act f pil = +let make_generic_action + (f:loc -> ('b * raw_generic_argument) list -> 'a) pil = let rec make env = function | [] -> Gramext.action (fun loc -> f loc env) @@ -317,73 +145,77 @@ let make_gen_act f pil = Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in make [] (List.rev pil) -let extend_constr entry (n,assoc,pos,p4assoc,name) make_act (forpat,pt) = - let univ = get_univ "constr" in - let pil = List.map (symbol_of_prod_item univ assoc n forpat) pt in - let (symbs,ntl) = List.split pil in - let act = make_act ntl in - grammar_extend entry pos [(name, p4assoc, [symbs, act])] - -let extend_constr_notation (n,assoc,ntn,rule,permut) = - let mkact = - match permut with - None -> (fun loc env -> CNotation (loc,ntn,List.map snd env)) - | Some p -> (fun loc env -> - CNotation (loc,ntn,List.map (fun i -> snd (List.nth env i)) p)) in - let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in - let pos,p4assoc,name = find_position false keepassoc assoc level in - extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name) - (make_act mkact) (false,rule); - if not !Options.v7 then - let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in - let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in - let pos,p4assoc,name = find_position true keepassoc assoc level in - extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name) - (make_act_in_cases_pattern mkact) (true,rule) - -(* These grammars are not a removable *) -let make_rule univ f g (s,pt) = - let hd = Gramext.Stoken ("IDENT", s) in - let pil = (hd,None) :: List.map g pt in - let (symbs,ntl) = List.split pil in - let act = make_gen_act f ntl in +let make_rule univ f g pt = + let (symbs,ntl) = List.split (List.map g pt) in + let act = make_generic_action f ntl in (symbs, act) +(**********************************************************************) +(** Grammar extensions declared at ML level *) + +type grammar_tactic_production = + | TacTerm of string + | TacNonTerm of + loc * (Gram.te Gramext.g_symbol * argument_type) * string option + +let make_prod_item = function + | TacTerm s -> (Gramext.Stoken (Lexer.terminal s), None) + | TacNonTerm (_,(nont,t), po) -> (nont, option_app (fun p -> (p,t)) po) + +(* Tactic grammar extensions *) + let tac_exts = ref [] let get_extend_tactic_grammars () = !tac_exts let extend_tactic_grammar s gl = tac_exts := (s,gl) :: !tac_exts; let univ = get_univ "tactic" in - let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in - let rules = List.map (make_rule univ make_act make_prod_item) gl in + let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in + let rules = List.map (make_rule univ mkact make_prod_item) gl in Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)] +(* Vernac grammar extensions *) + let vernac_exts = ref [] let get_extend_vernac_grammars () = !vernac_exts let extend_vernac_command_grammar s gl = vernac_exts := (s,gl) :: !vernac_exts; let univ = get_univ "vernac" in - let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in - let rules = List.map (make_rule univ make_act make_prod_item) gl in + let mkact loc l = VernacExtend (s,List.map snd l) in + let rules = List.map (make_rule univ mkact make_prod_item) gl in Gram.extend Vernac_.command None [(None, None, List.rev rules)] -let rec interp_entry_name u s = +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +(* Interpretation of the grammar entry names *) + +let find_index s t = + let t,n = repr_ident (id_of_string t) in + if s <> t or n = None then raise Not_found; + out_some n + +let rec interp_entry_name up_level u s = let l = String.length s in if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name u (String.sub s 3 (l-8)) in + let t, g = interp_entry_name up_level u (String.sub s 3 (l-8)) in List1ArgType t, Gramext.Slist1 g else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name u (String.sub s 0 (l-5)) in + let t, g = interp_entry_name up_level u (String.sub s 0 (l-5)) in List0ArgType t, Gramext.Slist0 g else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name u (String.sub s 0 (l-4)) in + let t, g = interp_entry_name up_level u (String.sub s 0 (l-4)) in OptArgType t, Gramext.Sopt g else + try + let i = find_index "tactic" s in + TacticArgType i, + if i=up_level then Gramext.Sself else + if i=up_level-1 then Gramext.Snext else + Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i) + with Not_found -> let e = - if !Options.v7 then get_entry (get_univ u) s - else (* Qualified entries are no longer in use *) try get_entry (get_univ "tactic") s with _ -> @@ -396,31 +228,61 @@ let rec interp_entry_name u s = let t = type_of_typed_entry e in t,Gramext.Snterm (Pcoq.Gram.Entry.obj o) -let qualified_nterm current_univ = function - | NtQual (univ, en) -> if !Options.v7 then (univ, en) else assert false - | NtShort en -> (current_univ, en) - -let make_vprod_item univ = function - | VTerm s -> (Gramext.Stoken (Extend.terminal s), None) +let make_vprod_item n univ = function + | VTerm s -> (Gramext.Stoken (Lexer.terminal s), None) | VNonTerm (loc, nt, po) -> - let (u,nt) = qualified_nterm univ nt in - let (etyp, e) = interp_entry_name u nt in + let (etyp, e) = interp_entry_name n univ nt in e, option_app (fun p -> (p,etyp)) po -let add_tactic_entries gl = +let get_tactic_entry n = + if n = 0 then + weaken_entry Tactic.simple_tactic, None + else if 1<=n && n<=5 then + weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)) + +(* Declaration of the tactic grammar rule *) + +let head_is_ident = function VTerm _::_ -> true | _ -> false + +let add_tactic_entry (key,lev,prods,tac) = let univ = get_univ "tactic" in - let make_act s tac loc l = Tacexpr.TacAlias (loc,s,l,tac) in - let f (s,l,tac) = - make_rule univ (make_act s tac) (make_vprod_item "tactic") l in - let rules = List.map f gl in + let entry, pos = get_tactic_entry lev in + let mkprod = make_vprod_item lev "tactic" in + let rules = + if lev = 0 then begin + if not (head_is_ident prods) then + error "Notation for simple tactic must start with an identifier"; + let mkact s tac loc l = + (TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in + make_rule univ (mkact key tac) mkprod prods + end + else + let mkact s tac loc l = + (TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in + make_rule univ (mkact key tac) mkprod prods in let _ = find_position true true None None (* to synchronise with remove *) in - grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)] + grammar_extend entry pos [(None, None, List.rev [rules])] + +(**********************************************************************) +(** State of the grammar extensions *) + +type notation_grammar = + int * Gramext.g_assoc option * notation * prod_item list + +type all_grammar_command = + | Notation of Notation.level * notation_grammar + | TacticGrammar of + (string * int * grammar_production list * + (Names.dir_path * Tacexpr.glob_tactic_expr)) + +let (grammar_state : all_grammar_command list ref) = ref [] let extend_grammar gram = (match gram with | Notation (_,a) -> extend_constr_notation a - | Grammar g -> extend_grammar_rules g - | TacticGrammar (l,_) -> add_tactic_entries l); + | TacticGrammar g -> add_tactic_entry g); grammar_state := gram :: !grammar_state let reset_extend_grammars_v8 () = @@ -428,12 +290,12 @@ let reset_extend_grammars_v8 () = let tv = List.rev !vernac_exts in tac_exts := []; vernac_exts := []; - List.iter (fun (s,gl) -> extend_tactic_grammar s gl) te; + List.iter (fun (s,gl) -> print_string ("Resinstalling "^s); flush stdout; extend_tactic_grammar s gl) te; List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv let recover_notation_grammar ntn prec = let l = map_succeed (function - | Notation (prec',(_,_,ntn',_,_ as x)) when prec = prec' & ntn = ntn' -> x + | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x | _ -> failwith "") !grammar_state in assert (List.length l = 1); List.hd l @@ -453,11 +315,7 @@ let factorize_grams l1 l2 = let number_of_entries gcl = List.fold_left (fun n -> function - | Notation _ -> - if !Options.v7 then n + 1 - else n + 2 (* 1 for operconstr, 1 for pattern *) - | Grammar gc -> - n + (List.length gc.gc_entries) + | Notation _ -> n + 2 (* 1 for operconstr, 1 for pattern *) | TacticGrammar _ -> n + 1) 0 gcl diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index ade91453..31247044 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -6,54 +6,62 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: egrammar.mli,v 1.14.2.6 2005/12/23 22:16:46 herbelin Exp $ i*) +(*i $Id: egrammar.mli 7732 2005-12-26 13:51:24Z herbelin $ i*) (*i*) open Util open Topconstr -open Ast -open Coqast +open Pcoq +open Extend open Vernacexpr open Ppextend -open Extend open Rawterm +open Mod_subst (*i*) +(** Mapping of grammar productions to camlp4 actions + Used for Coq-level Notation and Tactic Notation, + and for ML-level tactic and vernac extensions + *) + +type prod_item = + | Term of Token.pattern + | NonTerm of constr_production_entry * + (Names.identifier * constr_production_entry) option + type notation_grammar = - int * Gramext.g_assoc option * notation * prod_item list * int list option + int * Gramext.g_assoc option * notation * prod_item list type all_grammar_command = | Notation of (precedence * tolerability list) * notation_grammar - | Grammar of grammar_command | TacticGrammar of - (string * (string * grammar_production list) * - (Names.dir_path * Tacexpr.raw_tactic_expr)) - list * (string * Genarg.argument_type list * - (string * Pptactic.grammar_terminals)) list + (string * int * grammar_production list * + (Names.dir_path * Tacexpr.glob_tactic_expr)) val extend_grammar : all_grammar_command -> unit (* Add grammar rules for tactics *) + type grammar_tactic_production = | TacTerm of string - | TacNonTerm of loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option + | TacNonTerm of + loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option val extend_tactic_grammar : - string -> (string * grammar_tactic_production list) list -> unit + string -> grammar_tactic_production list list -> unit val extend_vernac_command_grammar : - string -> (string * grammar_tactic_production list) list -> unit - + string -> grammar_tactic_production list list -> unit +(* val get_extend_tactic_grammars : - unit -> (string * (string * grammar_tactic_production list) list) list + unit -> (string * grammar_tactic_production list list) list +*) val get_extend_vernac_grammars : - unit -> (string * (string * grammar_tactic_production list) list) list + unit -> (string * grammar_tactic_production list list) list +(* val reset_extend_grammars_v8 : unit -> unit - -val subst_all_grammar_command : - Names.substitution -> all_grammar_command -> all_grammar_command - -val interp_entry_name : string -> string -> +*) +val interp_entry_name : int -> string -> string -> entry_type * Token.t Gramext.g_symbol val recover_notation_grammar : diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml deleted file mode 100644 index 6a4758ab..00000000 --- a/parsing/esyntax.ml +++ /dev/null @@ -1,276 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: esyntax.ml,v 1.21.2.1 2004/07/16 19:30:37 herbelin Exp $ *) - -open Pp -open Util -open Names -open Libnames -open Coqast -open Ast -open Extend -open Ppextend -open Names -open Nametab -open Topconstr -open Symbols - -(*** Syntax keys ***) - -(* We define keys for ast and astpats. This is a kind of hash - * function. An ast may have several keys, but astpat only one. The - * idea is that if an ast A matches a pattern P, then the key of P - * is in the set of keys of A. Thus, we can split the syntax entries - * according to the key of the pattern. *) - -type key = - | Cst of Names.constant (* keys for global constants rules *) - | SecVar of Names.variable - | Ind of Names.inductive - | Cstr of Names.constructor - | Nod of string (* keys for other constructed asts rules *) - | Oth (* key for other syntax rules *) - | All (* key for catch-all rules (i.e. with a pattern such as $x .. *) - -let warning_verbose = ref true - -let ast_keys = function - | Node(_,"APPLIST", Node(_,"CONST", [Path (_,sl)]) ::_) -> - [Cst sl; Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"SECVAR", [Nvar (_,s)]) ::_) -> - [SecVar s; Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) -> - [Ind (sl,tyi); Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT", - [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) -> - [Cstr ((sl,tyi),i); Nod "APPLIST"; All] - | Node(_,s,_) -> [Nod s; All] - | _ -> [Oth; All] - -let spat_key astp = - match astp with - | Pnode("APPLIST", - Pcons(Pnode("CONST", - Pcons(Pquote(Path (_,sl)),_)), _)) - -> Cst sl - | Pnode("APPLIST", - Pcons(Pnode("SECVAR", - Pcons(Pquote(Nvar (_,s)),_)), _)) - -> SecVar s - | Pnode("APPLIST", - Pcons(Pnode("MUTIND", - Pcons(Pquote(Path (_,sl)), - Pcons(Pquote(Num (_,tyi)),_))), _)) - -> Ind (sl,tyi) - | Pnode("APPLIST", - Pcons(Pnode("MUTCONSTRUCT", - Pcons(Pquote(Path (_,sl)), - Pcons(Pquote(Num (_,tyi)), - Pcons(Pquote(Num (_,i)),_)))), _)) - -> Cstr ((sl,tyi),i) - | Pnode(na,_) -> Nod na - | Pquote ast -> List.hd (ast_keys ast) - | Pmeta _ -> All - | _ -> Oth - -let se_key se = spat_key se.syn_astpat - -(** Syntax entry tables (state of the pretty_printer) **) -let from_name_table = ref Gmap.empty -let from_key_table = ref Gmapl.empty - -(* Summary operations *) -type frozen_t = (string * string, astpat syntax_entry) Gmap.t * - (string * key, astpat syntax_entry) Gmapl.t - -let freeze () = - (!from_name_table, !from_key_table) - -let unfreeze (fnm,fkm) = - from_name_table := fnm; - from_key_table := fkm - -let init () = - from_name_table := Gmap.empty; - from_key_table := Gmapl.empty - -let find_syntax_entry whatfor gt = - let gt_keys = ast_keys gt in - let entries = - List.flatten - (List.map (fun k -> Gmapl.find (whatfor,k) !from_key_table) gt_keys) - in - find_all_matches (fun se -> se.syn_astpat) [] gt entries - -let remove_with_warning name = - if Gmap.mem name !from_name_table then begin - let se = Gmap.find name !from_name_table in - let key = (fst name, se_key se) in - if !warning_verbose then - (Options.if_verbose - warning ("overriding syntax rule "^(fst name)^":"^(snd name)^".")); - from_name_table := Gmap.remove name !from_name_table; - from_key_table := Gmapl.remove key se !from_key_table - end - -let add_rule whatfor se = - let name = (whatfor,se.syn_id) in - let key = (whatfor, se_key se) in - remove_with_warning name; - from_name_table := Gmap.add name se !from_name_table; - from_key_table := Gmapl.add key se !from_key_table - -let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel - - -(* Pretty-printing machinery *) - -type std_printer = Coqast.t -> std_ppcmds -type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Coqast.t -> std_ppcmds option - -(* Module of primitive printers *) -module Ppprim = - struct - type t = std_printer -> std_printer - let tab = ref ([] : (string * t) list) - let map a = List.assoc a !tab - let add (a,ppr) = tab := (a,ppr)::!tab - end - -(**********************************************************************) -(* Primitive printers (e.g. for numerals) *) - -(* This is the map associating to a printer the scope it belongs to *) -(* and its ML code *) - -let primitive_printer_tab = - ref (Stringmap.empty : (scope_name * primitive_printer) Stringmap.t) -let declare_primitive_printer s sc pp = - primitive_printer_tab := Stringmap.add s (sc,pp) !primitive_printer_tab -let lookup_primitive_printer s = - Stringmap.find s !primitive_printer_tab - -(* Register the primitive printer for "token". It is not used in syntax/PP*.v, - * but any ast matching no PP rule is printed with it. *) -(* -let _ = declare_primitive_printer "token" token_printer -*) - -(* A printer for the tokens. *) -let token_printer stdpr = function - | (Id _ | Num _ | Str _ | Path _ as ast) -> print_ast ast - | a -> stdpr a - -(* Unused ?? -(* A primitive printer to do "print as" (to specify a length for a string) *) -let print_as_printer = function - | Node (_, "AS", [Num(_,n); Str(_,s)]) -> Some (stras (n,s)) - | ast -> None - -let _ = declare_primitive_printer "print_as" default_scope print_as_printer -*) - -(* Handle infix symbols *) - -let pr_parenthesis inherited se strm = - if tolerable_prec inherited se.syn_prec then - strm - else - (str"(" ++ strm ++ str")") - -let print_delimiters inh se strm = function - | None -> pr_parenthesis inh se strm - | Some key -> - let left = "'"^key^":" and right = "'" in - let lspace = - if is_letter (left.[String.length left -1]) then str " " else mt () in - let rspace = - let c = right.[0] in - if is_ident_tail c then str " " else mt () in - hov 0 (str left ++ lspace ++ strm ++ rspace ++ str right) - -(* Print the syntax entry. In the unparsing hunks, the tokens are - * printed using the token_printer, unless another primitive printer - * is specified. *) - -let print_syntax_entry sub_pr scopes env se = - let rec print_hunk rule_prec scopes = function - | PH(e,externpr,reln) -> - let node = Ast.pat_sub dummy_loc env e in - let printer = - match externpr with (* May branch to an other printer *) - | Some c -> - (try (* Test for a primitive printer *) Ppprim.map c - with Not_found -> token_printer) - | _ -> token_printer in - printer (sub_pr scopes (Some(rule_prec,reln))) node - | RO s -> str s - | UNP_TAB -> tab () - | UNP_FNL -> fnl () - | UNP_BRK(n1,n2) -> brk(n1,n2) - | UNP_TBRK(n1,n2) -> tbrk(n1,n2) - | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub) - | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser" - in - prlist (print_hunk se.syn_prec scopes) se.syn_hunks - -let call_primitive_parser rec_pr otherwise inherited scopes (se,env) = - try ( - match se.syn_hunks with - | [PH(e,Some c,reln)] -> - (* Test for a primitive printer; may raise Not_found *) - let sc,pr = lookup_primitive_printer c in - (* Look if scope [sc] associated to this printer is OK *) - (match Symbols.availability_of_numeral sc scopes with - | None -> otherwise () - | Some key -> - (* We can use this printer *) - let node = Ast.pat_sub dummy_loc env e in - match pr node with - | Some strm -> print_delimiters inherited se strm key - | None -> otherwise ()) - | [UNP_SYMBOLIC (sc,pat,sub)] -> - (match Symbols.availability_of_notation (sc,pat) scopes with - | None -> otherwise () - | Some (scopt,key) -> - print_delimiters inherited se - (print_syntax_entry rec_pr - (option_fold_right Symbols.push_scope scopt scopes) env - {se with syn_hunks = [sub]}) key) - | _ -> - pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) - ) - with Not_found -> (* To handle old style printer *) - pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) - -(* [genprint whatfor dflt inhprec ast] prints out the ast of - * 'universe' whatfor. If the term is not matched by any - * pretty-printing rule, then it will call dflt on it, which is - * responsible for printing out the term (usually #GENTERM...). - * In the case of tactics and commands, dflt also prints - * global constants basenames. *) - -let genprint dflt whatfor inhprec ast = - let rec rec_pr scopes inherited gt = - let entries = find_syntax_entry whatfor gt in - let rec test_rule = function - | se_env::rules -> - call_primitive_parser - rec_pr - (fun () -> test_rule rules) - inherited scopes se_env - | [] -> dflt gt (* No rule found *) - in test_rule entries - in - try - rec_pr (Symbols.current_scopes ()) inhprec ast - with - | Failure _ -> (str"<PP failure: " ++ dflt ast ++ str">") - | Not_found -> (str"<PP search failure: " ++ dflt ast ++ str">") diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli deleted file mode 100644 index 88d1a0e2..00000000 --- a/parsing/esyntax.mli +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: esyntax.mli,v 1.10.2.2 2005/01/21 16:42:36 herbelin Exp $ i*) - -(*i*) -open Pp -open Extend -open Symbols -open Ppextend -open Topconstr -(*i*) - -(* Syntax entry tables. *) - -type frozen_t - -(* pretty-printer summary operations *) -val init : unit -> unit -val freeze : unit -> frozen_t -val unfreeze : frozen_t -> unit - -(* Search and add a PP rule for an ast in the summary *) -val find_syntax_entry : - string -> Coqast.t -> (Ast.astpat syntax_entry * Ast.env) list -val add_rule : string -> Ast.astpat syntax_entry -> unit -val add_ppobject : Ast.astpat syntax_command -> unit -val warning_verbose : bool ref - -(* Pretty-printing *) - -type std_printer = Coqast.t -> std_ppcmds -type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Coqast.t -> std_ppcmds option - -(* Module of constr primitive printers [old style - no scope] *) -module Ppprim : - sig - type t = std_printer -> std_printer - val add : string * t -> unit - end - -val declare_primitive_printer : - string -> scope_name -> primitive_printer -> unit - -(*i -val declare_infix_symbol : Libnames.section_path -> string -> unit -i*) - -(* Generic printing functions *) -(*i -val token_printer: std_printer -> std_printer -val print_syntax_entry : - string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds -i*) -val genprint : std_printer -> unparsing_subfunction diff --git a/parsing/extend.ml b/parsing/extend.ml index 2778de44..f4c98291 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -7,21 +7,23 @@ (************************************************************************) -(*i $Id: extend.ml,v 1.20.2.1 2004/07/16 19:30:37 herbelin Exp $ i*) +(*i $Id: extend.ml 7761 2005-12-30 10:52:19Z herbelin $ i*) open Util open Pp open Gramext open Names -open Ast open Ppextend open Topconstr open Genarg -type entry_type = argument_type +(**********************************************************************) +(* constr entry keys *) + +type side = Left | Right type production_position = - | BorderProd of bool * Gramext.g_assoc option (* true=left; false=right *) + | BorderProd of side * Gramext.g_assoc option (* true=left; false=right *) | InternalProd type production_level = @@ -37,54 +39,13 @@ type ('lev,'pos) constr_entry_key = type constr_production_entry = (production_level,production_position) constr_entry_key -type constr_entry = (int,unit) constr_entry_key -type simple_constr_production_entry = (production_level,unit) constr_entry_key - -type nonterm_prod = - | ProdList0 of nonterm_prod - | ProdList1 of nonterm_prod * Token.pattern list - | ProdOpt of nonterm_prod - | ProdPrimitive of constr_production_entry - -type prod_item = - | Term of Token.pattern - | NonTerm of constr_production_entry * - (Names.identifier * constr_production_entry) option - -type grammar_rule = { - gr_name : string; - gr_production : prod_item list; - gr_action : constr_expr } - -type grammar_entry = { - ge_name : constr_entry; - gl_assoc : Gramext.g_assoc option; - gl_rules : grammar_rule list } - -type grammar_command = { - gc_univ : string; - gc_entries : grammar_entry list } - -type grammar_associativity = Gramext.g_assoc option +type constr_entry = + (int,unit) constr_entry_key +type simple_constr_production_entry = + (production_level,unit) constr_entry_key (**********************************************************************) -(* Globalisation and type-checking of Grammar actions *) - -type entry_context = identifier list - -open Rawterm -open Libnames - -let globalizer = ref (fun _ _ -> CHole dummy_loc) -let set_constr_globalizer f = globalizer := f - -let act_of_ast vars = function - | SimpleAction (loc,ConstrNode a) -> !globalizer vars a - | SimpleAction (loc,CasesPatternNode a) -> - failwith "TODO:act_of_ast: cases_pattern" - | CaseAction _ -> failwith "case/let not supported" - -let to_act_check_vars = act_of_ast +(* syntax modifiers *) type syntax_modifier = | SetItemLevel of string list * production_level @@ -94,285 +55,3 @@ type syntax_modifier = | SetOnlyParsing | SetFormat of string located -type nonterm = - | NtShort of string - | NtQual of string * string -type grammar_production = - | VTerm of string - | VNonTerm of loc * nonterm * Names.identifier option -type raw_grammar_rule = string * grammar_production list * grammar_action -type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list - -(* No kernel names in Grammar's *) -let subst_constr_expr _ a = a - -let subst_grammar_rule subst gr = - { gr with gr_action = subst_constr_expr subst gr.gr_action } - -let subst_grammar_entry subst ge = - { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules } - -let subst_grammar_command subst gc = - { gc with gc_entries = List.map (subst_grammar_entry subst) gc.gc_entries } - - -(*s Terminal symbols interpretation *) - -let is_ident_not_keyword s = - match s.[0] with - | 'a'..'z' | 'A'..'Z' | '_' -> not (Lexer.is_keyword s) - | _ -> false - -let is_number s = - match s.[0] with - | '0'..'9' -> true - | _ -> false - -let strip s = - let len = - let rec loop i len = - if i = String.length s then len - else if s.[i] == ' ' then loop (i + 1) len - else loop (i + 1) (len + 1) - in - loop 0 0 - in - if len == String.length s then s - else - let s' = String.create len in - let rec loop i i' = - if i == String.length s then s' - else if s.[i] == ' ' then loop (i + 1) i' - else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end - in - loop 0 0 - -let terminal s = - let s = strip s in - if s = "" then failwith "empty token"; - if is_ident_not_keyword s then ("IDENT", s) - else if is_number s then ("INT", s) - else ("", s) - -(*s Non-terminal symbols interpretation *) - -(* For compatibility *) -let warn nt nt' = - warning ("'"^nt^"' grammar entry is obsolete; use name '"^nt'^"' instead"); - nt' - -let rename_command_entry nt = - if String.length nt >= 7 & String.sub nt 0 7 = "command" - then warn nt ("constr"^(String.sub nt 7 (String.length nt - 7))) - else if nt = "lcommand" then warn nt "lconstr" - else if nt = "lassoc_command4" then warn nt "lassoc_constr4" - else nt - -(* This translates constr0, constr1, ... level into camlp4 levels of constr *) - -let explicitize_prod_entry inj pos univ nt = - if univ = "prim" & nt = "var" then ETIdent else - if univ = "prim" & nt = "bigint" then ETBigint else - if univ <> "constr" then ETOther (univ,nt) else - match nt with - | "constr0" -> ETConstr (inj 0,pos) - | "constr1" -> ETConstr (inj 1,pos) - | "constr2" -> ETConstr (inj 2,pos) - | "constr3" -> ETConstr (inj 3,pos) - | "lassoc_constr4" -> ETConstr (inj 4,pos) - | "constr5" -> ETConstr (inj 5,pos) - | "constr6" -> ETConstr (inj 6,pos) - | "constr7" -> ETConstr (inj 7,pos) - | "constr8" -> ETConstr (inj 8,pos) - | "constr" when !Options.v7 -> ETConstr (inj 8,pos) - | "constr9" -> ETConstr (inj 9,pos) - | "constr10" | "lconstr" -> ETConstr (inj 10,pos) - | "pattern" -> ETPattern - | "ident" -> ETIdent - | "global" -> ETReference - | _ -> ETOther (univ,nt) - -let explicitize_entry = explicitize_prod_entry (fun x -> x) () - -(* Express border sub entries in function of the from level and an assoc *) -(* We're cheating: not necessarily the same assoc on right and left *) -let clever_explicitize_prod_entry pos univ from en = - let t = explicitize_prod_entry (fun x -> NumLevel x) pos univ en in - match from with - | ETConstr (from,()) -> - (match t with - | ETConstr (n,BorderProd (left,None)) - when (n=NumLevel from & left) -> - ETConstr (n,BorderProd (left,Some Gramext.LeftA)) - | ETConstr (NumLevel n,BorderProd (left,None)) - when (n=from-1 & not left) -> - ETConstr - (NumLevel (n+1),BorderProd (left,Some Gramext.LeftA)) - | ETConstr (NumLevel n,BorderProd (left,None)) - when (n=from-1 & left) -> - ETConstr - (NumLevel (n+1),BorderProd (left,Some Gramext.RightA)) - | ETConstr (n,BorderProd (left,None)) - when (n=NumLevel from & not left) -> - ETConstr (n,BorderProd (left,Some Gramext.RightA)) - | t -> t) - | _ -> t - -let qualified_nterm current_univ pos from = function - | NtQual (univ, en) -> - clever_explicitize_prod_entry pos univ from en - | NtShort en -> - clever_explicitize_prod_entry pos current_univ from en - -let check_entry check_entry_type = function - | ETOther (u,n) -> check_entry_type (u,n) - | _ -> () - -let nterm loc (((check_entry_type,univ),from),pos) nont = - let typ = qualified_nterm univ pos from nont in - check_entry check_entry_type typ; - typ - -let prod_item univ env = function - | VTerm s -> env, Term (terminal s) - | VNonTerm (loc, nt, Some p) -> - let typ = nterm loc univ nt in - (p :: env, NonTerm (typ, Some (p,typ))) - | VNonTerm (loc, nt, None) -> - let typ = nterm loc univ nt in - env, NonTerm (typ, None) - -let rec prod_item_list univ penv pil current_pos = - match pil with - | [] -> [], penv - | pi :: pitl -> - let pos = if pitl=[] then (BorderProd (false,None)) else current_pos in - let (env, pic) = prod_item (univ,pos) penv pi in - let (pictl, act_env) = prod_item_list univ env pitl InternalProd in - (pic :: pictl, act_env) - -let gram_rule univ (name,pil,act) = - let (pilc, act_env) = prod_item_list univ [] pil (BorderProd (true,None)) in - let a = to_act_check_vars act_env act in - { gr_name = name; gr_production = pilc; gr_action = a } - -let border = function - | NonTerm (ETConstr(_,BorderProd (_,a)),_) :: _ -> a - | _ -> None - -let clever_assoc ass g = - if g.gr_production <> [] then - (match border g.gr_production, border (List.rev g.gr_production) with - | Some LeftA, Some RightA -> ass (* Untractable; we cheat *) - | Some LeftA, _ -> Some LeftA - | _, Some RightA -> Some RightA - | _ -> Some NonA) - else ass - -let gram_entry univ (nt, ass, rl) = - let from = explicitize_entry (snd univ) nt in - let l = List.map (gram_rule (univ,from)) rl in - let ass = List.fold_left clever_assoc ass l in - { ge_name = from; - gl_assoc = ass; - gl_rules = l } - -let interp_grammar_command univ ge entryl = - { gc_univ = univ; - gc_entries = List.map (gram_entry (ge,univ)) entryl } - -(* unparsing objects *) - -type 'pat unparsing_hunk = - | PH of 'pat * string option * parenRelation - | RO of string - | UNP_BOX of ppbox * 'pat unparsing_hunk list - | UNP_BRK of int * int - | UNP_TBRK of int * int - | UNP_TAB - | UNP_FNL - | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk - -let rec subst_hunk subst_pat subst hunk = match hunk with - | PH (pat,so,pr) -> - let pat' = subst_pat subst pat in - if pat'==pat then hunk else - PH (pat',so,pr) - | RO _ -> hunk - | UNP_BOX (ppbox, hunkl) -> - let hunkl' = list_smartmap (subst_hunk subst_pat subst) hunkl in - if hunkl' == hunkl then hunk else - UNP_BOX (ppbox, hunkl') - | UNP_BRK _ - | UNP_TBRK _ - | UNP_TAB - | UNP_FNL -> hunk - | UNP_SYMBOLIC (s1, s2, pat) -> - let pat' = subst_hunk subst_pat subst pat in - if pat' == pat then hunk else - UNP_SYMBOLIC (s1, s2, pat') - -(* Checks if the precedence of the parent printer (None means the - highest precedence), and the child's one, follow the given - relation. *) - -let tolerable_prec oparent_prec_reln child_prec = - match oparent_prec_reln with - | Some (pprec, L) -> child_prec < pprec - | Some (pprec, E) -> child_prec <= pprec - | Some (_, Prec level) -> child_prec <= level - | _ -> true - -type 'pat syntax_entry = { - syn_id : string; - syn_prec: precedence; - syn_astpat : 'pat; - syn_hunks : 'pat unparsing_hunk list } - -let subst_syntax_entry subst_pat subst sentry = - let syn_astpat' = subst_pat subst sentry.syn_astpat in - let syn_hunks' = list_smartmap (subst_hunk subst_pat subst) sentry.syn_hunks - in - if syn_astpat' == sentry.syn_astpat - && syn_hunks' == sentry.syn_hunks then sentry - else - { sentry with - syn_astpat = syn_astpat' ; - syn_hunks = syn_hunks' ; - } - -type 'pat syntax_command = { - sc_univ : string; - sc_entries : 'pat syntax_entry list } - -let subst_syntax_command subst_pat subst scomm = - let sc_entries' = - list_smartmap (subst_syntax_entry subst_pat subst) scomm.sc_entries - in - if sc_entries' == scomm.sc_entries then scomm else - { scomm with sc_entries = sc_entries' } - -type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type raw_syntax_entry = precedence * syntax_rule list - -let rec interp_unparsing env = function - | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr) - | UNP_BOX (b,ul) -> UNP_BOX (b,List.map (interp_unparsing env) ul) - | UNP_BRK _ | RO _ | UNP_TBRK _ | UNP_TAB | UNP_FNL as x -> x - | UNP_SYMBOLIC (x,y,u) -> UNP_SYMBOLIC (x,y,interp_unparsing env u) - -let rule_of_ast univ prec (s,spat,unp) = - let (astpat,meta_env) = Ast.to_pat [] spat in - let hunks = List.map (interp_unparsing meta_env) unp in - { syn_id = s; - syn_prec = prec; - syn_astpat = astpat; - syn_hunks = hunks } - -let level_of_ast univ (prec,rl) = List.map (rule_of_ast univ prec) rl - -let interp_syntax_entry univ sel = - { sc_univ = univ; - sc_entries = List.flatten (List.map (level_of_ast univ) sel)} - - diff --git a/parsing/extend.mli b/parsing/extend.mli index c5417649..80de7108 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -6,23 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extend.mli,v 1.19.2.2 2005/01/21 16:42:37 herbelin Exp $ i*) +(*i $Id: extend.mli 7761 2005-12-30 10:52:19Z herbelin $ i*) -(*i*) -open Pp open Util -open Names -open Ast -open Coqast -open Ppextend -open Topconstr -open Genarg -(*i*) -type entry_type = argument_type +(**********************************************************************) +(* constr entry keys *) + +type side = Left | Right type production_position = - | BorderProd of bool * Gramext.g_assoc option (* true=left; false=right *) + | BorderProd of side * Gramext.g_assoc option (* true=left; false=right *) | InternalProd type production_level = @@ -38,41 +32,13 @@ type ('lev,'pos) constr_entry_key = type constr_production_entry = (production_level,production_position) constr_entry_key -type constr_entry = (int,unit) constr_entry_key -type simple_constr_production_entry = (production_level,unit) constr_entry_key - -type nonterm_prod = - | ProdList0 of nonterm_prod - | ProdList1 of nonterm_prod * Token.pattern list - | ProdOpt of nonterm_prod - | ProdPrimitive of constr_production_entry - -type prod_item = - | Term of Token.pattern - | NonTerm of constr_production_entry * - (Names.identifier * constr_production_entry) option - -type grammar_rule = { - gr_name : string; - gr_production : prod_item list; - gr_action : constr_expr } - -type grammar_entry = { - ge_name : constr_entry; - gl_assoc : Gramext.g_assoc option; - gl_rules : grammar_rule list } - -type grammar_command = { - gc_univ : string; - gc_entries : grammar_entry list } - -type grammar_associativity = Gramext.g_assoc option +type constr_entry = + (int,unit) constr_entry_key +type simple_constr_production_entry = + (production_level,unit) constr_entry_key -(* Globalisation and type-checking of Grammar actions *) -type entry_context = identifier list - -val set_constr_globalizer : - (entry_context -> constr_expr -> constr_expr) -> unit +(**********************************************************************) +(* syntax modifiers *) type syntax_modifier = | SetItemLevel of string list * production_level @@ -82,73 +48,3 @@ type syntax_modifier = | SetOnlyParsing | SetFormat of string located -type nonterm = - | NtShort of string - | NtQual of string * string -type grammar_production = - | VTerm of string - | VNonTerm of loc * nonterm * Names.identifier option -type raw_grammar_rule = string * grammar_production list * grammar_action -type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list - -val terminal : string -> string * string - -val rename_command_entry : string -> string - -val explicitize_entry : string -> string -> constr_entry - -val subst_grammar_command : - Names.substitution -> grammar_command -> grammar_command - -(* unparsing objects *) - -type 'pat unparsing_hunk = - | PH of 'pat * string option * parenRelation - | RO of string - | UNP_BOX of ppbox * 'pat unparsing_hunk list - | UNP_BRK of int * int - | UNP_TBRK of int * int - | UNP_TAB - | UNP_FNL - | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk - -(*i -val subst_unparsing_hunk : - Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> - 'pat unparsing_hunk -> 'pat unparsing_hunk -i*) - -(* Checks if the precedence of the parent printer (None means the - highest precedence), and the child's one, follow the given - relation. *) - -val tolerable_prec : tolerability option -> precedence -> bool - -type 'pat syntax_entry = { - syn_id : string; - syn_prec: precedence; - syn_astpat : 'pat; - syn_hunks : 'pat unparsing_hunk list } - -val subst_syntax_entry : - (Names.substitution -> 'pat -> 'pat) -> - Names.substitution -> 'pat syntax_entry -> 'pat syntax_entry - - -type 'pat syntax_command = { - sc_univ : string; - sc_entries : 'pat syntax_entry list } - -val subst_syntax_command : - (Names.substitution -> 'pat -> 'pat) -> - Names.substitution -> 'pat syntax_command -> 'pat syntax_command - -type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type raw_syntax_entry = precedence * syntax_rule list - -val interp_grammar_command : - string -> (string * string -> unit) -> - raw_grammar_entry list -> grammar_command - -val interp_syntax_entry : - string -> raw_syntax_entry list -> Ast.astpat syntax_command diff --git a/parsing/g_ascii_syntax.ml b/parsing/g_ascii_syntax.ml new file mode 100644 index 00000000..e6324e00 --- /dev/null +++ b/parsing/g_ascii_syntax.ml @@ -0,0 +1,81 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +open Pp +open Util +open Names +open Pcoq +open Rawterm +open Topconstr +open Libnames +open Coqlib +open Bigint + +exception Non_closed_ascii + +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let make_kn dir id = Libnames.encode_kn (make_dir dir) (id_of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) + +let ascii_module = ["Coq";"Strings";"Ascii"] + +let ascii_path = make_path ascii_module "ascii" + +let ascii_kn = make_kn ascii_module "ascii" +let path_of_Ascii = ((ascii_kn,0),1) +let static_glob_Ascii = ConstructRef path_of_Ascii + +let make_reference id = find_reference "Ascii interpretation" ascii_module id +let glob_Ascii = lazy (make_reference "Ascii") + +open Lazy + +let interp_ascii dloc p = + let rec aux n p = + if n = 0 then [] else + let mp = p mod 2 in + RRef (dloc,if mp = 0 then glob_false else glob_true) + :: (aux (n-1) (p/2)) in + RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p) + +let interp_ascii_string dloc s = + let p = + if String.length s = 1 then int_of_char s.[0] + else + if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2] + then int_of_string s + else + user_err_loc (dloc,"interp_ascii_string", + str "Expects a single character or a three-digits ascii code") in + interp_ascii dloc p + +let uninterp_ascii r = + let rec uninterp_bool_list n = function + | [] when n = 0 -> 0 + | RRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) + | _ -> raise Non_closed_ascii in + try + let rec aux = function + | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l + | _ -> raise Non_closed_ascii in + Some (aux r) + with + Non_closed_ascii -> None + +let make_ascii_string n = + if n>=32 && n<=126 then String.make 1 (char_of_int n) + else Printf.sprintf "%03d" n + +let uninterp_ascii_string r = option_app make_ascii_string (uninterp_ascii r) + +let _ = + Notation.declare_string_interpreter "char_scope" + (ascii_path,ascii_module) + interp_ascii_string + ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4 deleted file mode 100644 index c4badbc3..00000000 --- a/parsing/g_basevernac.ml4 +++ /dev/null @@ -1,524 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_basevernac.ml4,v 1.83.2.2 2004/07/16 19:30:37 herbelin Exp $ *) - -open Coqast -open Extend -open Ppextend -open Vernacexpr -open Pcoq -open Vernac_ -open Goptions -open Constr -open Prim - -let vernac_kw = - [ "Quit"; "Load"; "Compile"; "Fixpoint"; "CoFixpoint"; - "Definition"; "Inductive"; "CoInductive"; - "Theorem"; "Variable"; "Axiom"; "Parameter"; "Hypothesis"; - "."; ">->" ] -let _ = - if !Options.v7 then - List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw - -let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" -let lstring = Gram.Entry.create "lstring" - - -if !Options.v7 then -GEXTEND Gram - GLOBAL: class_rawexpr; - - class_rawexpr: - [ [ IDENT "FUNCLASS" -> FunClass - | IDENT "SORTCLASS" -> SortClass - | qid = global -> RefClass qid ] ] - ; -END; - -if !Options.v7 then -GEXTEND Gram - GLOBAL: command lstring; - - lstring: - [ [ s = STRING -> s ] ] - ; - comment: - [ [ c = constr -> CommentConstr c - | s = STRING -> CommentString s - | n = natural -> CommentInt n ] ] - ; - command: - [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l - - (* System directory *) - | IDENT "Pwd" -> VernacChdir None - | IDENT "Cd" -> VernacChdir None - | IDENT "Cd"; dir = lstring -> VernacChdir (Some dir) - - (* Toplevel control *) - | IDENT "Drop" -> VernacToplevelControl Drop - | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop - | "Quit" -> VernacToplevelControl Quit - - (* Dump of the universe graph - to file or to stdout *) - | IDENT "Dump"; IDENT "Universes"; fopt = OPT lstring -> - VernacPrint (PrintUniverses fopt) - - | IDENT "Locate"; l = locatable -> VernacLocate l - - (* Managing load paths *) - | IDENT "Add"; IDENT "LoadPath"; dir = lstring; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = lstring; - alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) - | IDENT "Remove"; IDENT "LoadPath"; dir = lstring -> - VernacRemoveLoadPath dir - - (* For compatibility *) - | IDENT "AddPath"; dir = lstring; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "AddRecPath"; dir = lstring; alias = as_dirpath -> - VernacAddLoadPath (true, dir, alias) - | IDENT "DelPath"; dir = lstring -> - VernacRemoveLoadPath dir - - (* Printing (careful factorization of entries) *) - | IDENT "Print"; p = printable -> VernacPrint p - | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) - | IDENT "Print" -> VernacPrint PrintLocalContext - | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> - VernacPrint (PrintModuleType qid) - | IDENT "Print"; IDENT "Module"; qid = global -> - VernacPrint (PrintModule qid) - | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) - | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid) - - (* Searching the environment *) - | IDENT "Search"; qid = global; l = in_or_out_modules -> - VernacSearch (SearchHead qid, l) - | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchPattern c, l) - | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchRewrite c, l) - | IDENT "SearchAbout"; - sl = [ "["; l = LIST1 [ r = global -> SearchRef r - | s = lstring -> SearchString s ]; "]" -> l - | qid = global -> [SearchRef qid] ]; - l = in_or_out_modules -> - VernacSearch (SearchAbout sl, l) - - (* TODO: rapprocher Eval et Check *) - | IDENT "Eval"; r = Tactic.red_expr; "in"; - c = constr -> VernacCheckMayEval (Some r, None, c) - | IDENT "Check"; c = constr -> - VernacCheckMayEval (None, None, c) - | "Type"; c = constr -> VernacGlobalCheck c (* pas dans le RefMan *) - - | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = lstring -> - VernacAddMLPath (false, dir) - | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = lstring -> - VernacAddMLPath (true, dir) -(* - | IDENT "SearchIsos"; c = constr -> VernacSearch (SearchIsos c) -*) - - (* Pour intervenir sur les tables de paramètres *) - - | "Set"; table = IDENT; field = IDENT; v = option_value -> - VernacSetOption (SecondaryTable (table,field),v) - | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> - VernacAddOption (SecondaryTable (table,field),lv) - | "Set"; table = IDENT; field = IDENT -> - VernacSetOption (SecondaryTable (table,field),BoolValue true) - | IDENT "Unset"; table = IDENT; field = IDENT -> - VernacUnsetOption (SecondaryTable (table,field)) - | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> - VernacRemoveOption (SecondaryTable (table,field),lv) - | "Set"; table = IDENT; value = option_value -> - VernacSetOption (PrimaryTable table, value) - | "Set"; table = IDENT -> - VernacSetOption (PrimaryTable table, BoolValue true) - | IDENT "Unset"; table = IDENT -> - VernacUnsetOption (PrimaryTable table) - - | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT -> - VernacPrintOption (SecondaryTable (table,field)) - | IDENT "Print"; IDENT "Table"; table = IDENT -> - VernacPrintOption (PrimaryTable table) - - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value - -> VernacAddOption (SecondaryTable (table,field), v) - - (* Un value global ci-dessous va être caché par un field au dessus! *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> - VernacAddOption (PrimaryTable table, v) - - | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value - -> VernacMemOption (SecondaryTable (table,field), v) - | IDENT "Test"; table = IDENT; field = IDENT -> - VernacPrintOption (SecondaryTable (table,field)) - | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value -> - VernacMemOption (PrimaryTable table, v) - | IDENT "Test"; table = IDENT -> - VernacPrintOption (PrimaryTable table) - - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value - -> VernacRemoveOption (SecondaryTable (table,field), v) - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - VernacRemoveOption (PrimaryTable table, v) ] ] - ; - printable: - [ [ IDENT "Term"; qid = global -> PrintOpaqueName qid - | IDENT "All" -> PrintFullContext - | IDENT "Section"; s = global -> PrintSectionContext s - | IDENT "Grammar"; uni = IDENT; ent = IDENT -> - (* This should be in "syntax" section but is here for factorization*) - PrintGrammar (uni, ent) - | IDENT "LoadPath" -> PrintLoadPath - | IDENT "Modules" -> PrintModules - - | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath - | IDENT "ML"; IDENT "Modules" -> PrintMLModules - | IDENT "Graph" -> PrintGraph - | IDENT "Classes" -> PrintClasses - | IDENT "Coercions" -> PrintCoercions - | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr - -> PrintCoercionPaths (s,t) - | IDENT "Tables" -> PrintTables - | "Proof"; qid = global -> PrintOpaqueName qid - | IDENT "Hint" -> PrintHintGoal - | IDENT "Hint"; qid = global -> PrintHint qid - | IDENT "Hint"; "*" -> PrintHintDb - | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | IDENT "Scopes" -> PrintScopes - | IDENT "Scope"; s = IDENT -> PrintScope s - | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s - | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ] - ; - locatable: - [ [ qid = global -> LocateTerm qid - | IDENT "File"; f = lstring -> LocateFile f - | IDENT "Library"; qid = global -> LocateLibrary qid - | s = lstring -> LocateNotation s ] ] - ; - option_value: - [ [ n = integer -> IntValue n - | s = lstring -> StringValue s ] ] - ; - option_ref_value: - [ [ id = global -> QualidRefValue id - | s = lstring -> StringRefValue s ] ] - ; - as_dirpath: - [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] - ; - in_or_out_modules: - [ [ IDENT "inside"; l = LIST1 global -> SearchInside l - | IDENT "outside"; l = LIST1 global -> SearchOutside l - | -> SearchOutside [] ] ] - ; -END - -(* Grammar extensions *) - -(* automatic translation of levels *) -let adapt_level n = - if n >= 10 then n*10 else - [| 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100|].(n) - -let map_modl = function - | SetItemLevel(ids,NumLevel n) -> SetItemLevel(ids,NumLevel (adapt_level n)) - | SetLevel n -> SetLevel(adapt_level n) - | m -> m - -if !Options.v7 then -GEXTEND Gram - GLOBAL: syntax; - - univ: - [ [ univ = IDENT -> - set_default_action_parser (parser_type_from_name univ); univ ] ] - ; - syntax: - [ [ IDENT "Token"; s = lstring -> - Pp.warning "Token declarations are now useless"; VernacNop - - | IDENT "Grammar"; IDENT "tactic"; IDENT "simple_tactic"; - OPT [ ":"; IDENT "tactic" ]; ":="; - OPT "|"; tl = LIST0 grammar_tactic_rule SEP "|" -> - VernacTacticGrammar tl - - | IDENT "Grammar"; u = univ; - tl = LIST1 grammar_entry SEP "with" -> - VernacGrammar (rename_command_entry u,tl) - - | IDENT "Syntax"; u = univ; el = LIST1 syntax_entry SEP ";" -> - VernacSyntax (u,el) - - | IDENT "Uninterpreted"; IDENT "Notation"; local = locality; s = lstring; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - (s8,mv8) = - [IDENT "V8only"; - s8=OPT lstring; - mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] -> - (s8,mv8) - | -> (None,None)] -> - let s8 = match s8 with Some s -> s | _ -> s in - let mv8 = match mv8 with - Some mv8 -> mv8 - | _ -> List.map map_modl modl in - VernacSyntaxExtension (local,Some (s,modl),Some(s8,mv8)) - - | IDENT "Uninterpreted"; IDENT "V8Notation"; local = locality; s = lstring; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> - VernacSyntaxExtension (local,None,Some(s,modl)) - - | IDENT "Open"; local = locality; IDENT "Scope"; - sc = IDENT -> VernacOpenCloseScope (local,true, sc) - - | IDENT "Close"; local = locality; IDENT "Scope"; - sc = IDENT -> VernacOpenCloseScope (local,false,sc) - - | IDENT "Delimits"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> - VernacDelimiters (sc,key) - - | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - - | IDENT "Arguments"; IDENT "Scope"; qid = global; - "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) - - | IDENT "Infix"; local = locality; a = entry_prec; n = OPT natural; - op = lstring; - p = global; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc]; - mv8 = - [IDENT "V8only"; - a8=entry_prec; - n8=OPT natural; - op8=OPT lstring; - mv8=["("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> []] - -> - (match (a8,n8,mv8,op8) with - | None,None,[],None -> None - | _,_,mv8,_ -> - Some(op8,Metasyntax.merge_modifiers a8 n8 mv8)) - | -> (* Means: rules are based on V7 rules *) - Some (None,[]) ] -> - let mv = Metasyntax.merge_modifiers a n modl in - let v8 = Util.option_app (function (op8,mv8) -> - let op8 = match op8 with None -> op | Some op -> op in - let mv8 = - if mv8=[] then - let mv8 = List.map map_modl mv in - let mv8 = if List.for_all - (function SetLevel _ -> false | _ -> true) mv8 - then SetLevel 10 :: mv8 else mv8 in - let mv8 = if List.for_all - (function SetAssoc _ -> false | _ -> true) mv8 - then SetAssoc Gramext.LeftA :: mv8 else mv8 in - mv8 - else mv8 in - (op8,mv8)) mv8 in - VernacInfix (local,(op,mv),p,v8,sc) - | IDENT "Distfix"; local = locality; a = entry_prec; n = natural; - s = lstring; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] -> - let (a,s,c) = Metasyntax.translate_distfix a s p in - let mv = Some(s,[SetLevel n;SetAssoc a]) in - VernacNotation (local,c,mv,mv,sc) -(* - VernacDistfix (local,a,n,s,p,sc) -*) - | IDENT "Notation"; local = locality; id = ident; ":="; c = constr; - b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> - VernacSyntacticDefinition (id,c,local,b) - | IDENT "Notation"; local = locality; s = lstring; ":="; c = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ]; - (s8,mv8) = - [IDENT "V8only"; - s8=OPT lstring; - mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] -> - (s8,mv8) - | -> (* Means: rules are based on V7 rules *) - None, Some [] ] -> - let smv8 = match s8,mv8 with - | None, None -> None (* = only interpretation *) - | Some s8, None -> Some (s8,[]) (* = only interp, new s *) - | None, Some [] -> Some (s,List.map map_modl modl) (*like v7*) - | None, Some mv8 -> Some (s,mv8) (* s like v7 *) - | Some s8, Some mv8 -> Some (s8,mv8) in - VernacNotation (local,c,Some(s,modl),smv8,sc) - | IDENT "V8Notation"; local = locality; s = lstring; ":="; c = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,None,Some(s,modl),sc) - - | IDENT "V8Infix"; local = locality; op8 = lstring; p = global; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc] -> - let mv8 = Metasyntax.merge_modifiers None None modl in - VernacInfix (local,("",[]),p,Some (op8,mv8),sc) - - (* "Print" "Grammar" should be here but is in "command" entry in order - to factorize with other "Print"-based vernac entries *) - ] ] - ; - locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; - level: - [ [ IDENT "level"; n = natural -> NumLevel n - | IDENT "next"; IDENT "level" -> NextLevel ] ] - ; - syntax_modifier: - [ [ x = IDENT; IDENT "at"; lev = level -> SetItemLevel ([x],lev) - | x = IDENT; ","; l = LIST1 IDENT SEP ","; IDENT "at"; lev = level -> - SetItemLevel (x::l,lev) - | IDENT "at"; IDENT "level"; n = natural -> SetLevel n - | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA - | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA - | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA - | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) - | IDENT "only"; IDENT "parsing" -> SetOnlyParsing - | IDENT "format"; s = [s = lstring -> (loc,s)] -> SetFormat s ] ] - ; - syntax_extension_type: - [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference - | IDENT "bigint" -> ETBigint - | i=IDENT -> ETOther ("constr",i) - ] ] - ; - opt_scope: - [ [ IDENT "_" -> None | sc = IDENT -> Some sc ] ] - ; - (* Syntax entries for Grammar. Only grammar_entry is exported *) - grammar_entry: - [[ nont = IDENT; set_entry_type; ":="; - ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" -> - (rename_command_entry nont,ep,rl) ]] - ; - entry_prec: - [[ IDENT "LEFTA" -> Some Gramext.LeftA - | IDENT "RIGHTA" -> Some Gramext.RightA - | IDENT "NONA" -> Some Gramext.NonA - | -> None ]] - ; - grammar_tactic_rule: - [[ name = rule_name; "["; s = lstring; pil = LIST0 production_item; "]"; - "->"; "["; t = Tactic.tactic; "]" -> (name, (s,pil), t) ]] - ; - grammar_rule: - [[ name = rule_name; "["; pil = LIST0 production_item; "]"; "->"; - a = action -> (name, pil, a) ]] - ; - rule_name: - [[ name = IDENT -> name ]] - ; - production_item: - [[ s = lstring -> VTerm s - | nt = non_terminal; po = OPT [ "("; p = METAIDENT; ")" -> p ] -> - match po with - | Some p -> VNonTerm (loc,nt,Some (Names.id_of_string p)) - | _ -> VNonTerm (loc,nt,None) ]] - ; - non_terminal: - [[ u = IDENT; ":"; nt = IDENT -> - NtQual(rename_command_entry u, rename_command_entry nt) - | nt = IDENT -> NtShort (rename_command_entry nt) ]] - ; - - - (* Syntax entries for Syntax. Only syntax_entry is exported *) - syntax_entry: - [ [ IDENT "level"; p = precedence; ":"; - OPT "|"; rl = LIST1 syntax_rule SEP "|" -> (p,rl) ] ] - ; - syntax_rule: - [ [ nm = IDENT; "["; s = astpat; "]"; "->"; u = unparsing -> (nm,s,u) ] ] - ; - precedence: - [ [ a = natural -> a -(* | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3)*) - ] ] - ; - unparsing: - [ [ "["; ll = LIST0 next_hunks; "]" -> ll ] ] - ; - next_hunks: - [ [ IDENT "FNL" -> UNP_FNL - | IDENT "TAB" -> UNP_TAB - | c = lstring -> RO c - | "["; - x = - [ b = box; ll = LIST0 next_hunks -> UNP_BOX (b,ll) - | n = natural; m = natural -> UNP_BRK (n, m) - | IDENT "TBRK"; n = natural; m = natural -> UNP_TBRK (n, m) ]; - "]" -> x - | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] -> - match oprec with - | Some (ext,pr) -> PH (e,ext,pr) - | None -> PH (e,None,Any) - ]] - ; - box: - [ [ "<"; bk = box_kind; ">" -> bk ] ] - ; - box_kind: - [ [ IDENT "h"; n = natural -> PpHB n - | IDENT "v"; n = natural -> PpVB n - | IDENT "hv"; n = natural -> PpHVB n - | IDENT "hov"; n = natural -> PpHOVB n - | IDENT "t" -> PpTB ] ] - ; - paren_reln_or_extern: - [ [ IDENT "L" -> None, L - | IDENT "E" -> None, E - | pprim = lstring; precrec = OPT [ ":"; p = precedence -> p ] -> - match precrec with - | Some p -> Some pprim, Prec p - | None -> Some pprim, Any ] ] - ; - (* meta-syntax entries *) - astpat: - [ [ "<<" ; a = Prim.ast; ">>" -> a - | a = Constr.constr -> - Termast.ast_of_rawconstr - (Constrintern.interp_rawconstr Evd.empty (Global.env()) a) - ] ] - ; - action: - [ [ IDENT "let"; p = Prim.astlist; et = set_internal_entry_type; - "="; e1 = action; "in"; e = action -> Ast.CaseAction (loc,e1,et,[p,e]) - | IDENT "case"; a = action; et = set_internal_entry_type; "of"; - cl = LIST1 case SEP "|"; IDENT "esac" -> Ast.CaseAction (loc,a,et,cl) - | "["; a = default_action_parser; "]" -> Ast.SimpleAction (loc,a) ] ] - ; - case: - [[ p = Prim.astlist; "->"; a = action -> (p,a) ]] - ; - set_internal_entry_type: - [[ ":"; IDENT "ast"; IDENT "list" -> Ast.ETastl - | [ ":"; IDENT "ast" -> () | -> () ] -> Ast.ETast ]] - ; - set_entry_type: - [[ ":"; et = entry_type -> set_default_action_parser et - | -> () ]] - ; - entry_type: - [[ IDENT "ast"; IDENT "list" -> Util.error "type ast list no longer supported" - | IDENT "ast" -> Util.error "type ast no longer supported" - | IDENT "constr" -> ConstrParser - | IDENT "pattern" -> CasesPatternParser - | IDENT "tactic" -> assert false - | IDENT "vernac" -> Util.error "vernac extensions no longer supported" ] ] - ; -END diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4 deleted file mode 100644 index b952305d..00000000 --- a/parsing/g_cases.ml4 +++ /dev/null @@ -1,73 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_cases.ml4,v 1.27.2.1 2004/07/16 19:30:38 herbelin Exp $ *) - -open Pcoq -open Constr -open Topconstr -open Term -open Libnames - -open Prim - -let pair loc = - Qualid (loc, Libnames.qualid_of_string "Coq.Init.Datatypes.pair") - -if !Options.v7 then -GEXTEND Gram - GLOBAL: operconstr pattern; - - pattern: - [ [ r = Prim.reference -> CPatAtom (loc,Some r) - | IDENT "_" -> CPatAtom (loc,None) - (* Hack to parse syntax "(n)" as a natural number *) - | "("; G_constr.test_int_rparen; n = bigint; ")" -> - (* Delimiter "N" moved to "nat" in V7 *) - CPatDelimiters (loc,"nat",CPatNumeral (loc,n)) - | "("; p = compound_pattern; ")" -> p - | n = bigint -> CPatNumeral (loc,n) - | "'"; G_constr.test_ident_colon; key = IDENT; ":"; c = pattern; "'" -> - CPatDelimiters (loc,key,c) - ] ] - ; - compound_pattern: - [ [ p = pattern ; lp = LIST1 pattern -> - (match p with - | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) - | _ -> Util.user_err_loc - (loc, "compound_pattern", Pp.str "Constructor expected")) - | p = pattern; "as"; id = base_ident -> - CPatAlias (loc, p, id) - | p1 = pattern; ","; p2 = pattern -> - CPatCstr (loc, pair loc, [p1; p2]) - | p = pattern -> p ] ] - ; - equation: - [ [ lhs = LIST1 pattern; "=>"; rhs = operconstr LEVEL "9" -> (loc,lhs,rhs) ] ] - ; - ne_eqn_list: - [ [ leqn = LIST1 equation SEP "|" -> leqn ] ] - ; - operconstr: LEVEL "1" - [ [ "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; - OPT "|"; eqs = ne_eqn_list; "end" -> - let lc = List.map (fun c -> c,(None,None)) lc in - CCases (loc, (Some p,None), lc, eqs) - | "Cases"; lc = LIST1 constr; "of"; - OPT "|"; eqs = ne_eqn_list; "end" -> - let lc = List.map (fun c -> c,(None,None)) lc in - CCases (loc, (None,None), lc, eqs) - | "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; "end" -> - let lc = List.map (fun c -> c,(None,None)) lc in - CCases (loc, (Some p,None), lc, []) - | "Cases"; lc = LIST1 constr; "of"; "end" -> - let lc = List.map (fun c -> c,(None,None)) lc in - CCases (loc, (None,None), lc, []) ] ] - ; -END; diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 80dc69f1..9f7f7304 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -6,129 +6,129 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_constr.ml4,v 1.52.2.2 2004/11/17 12:48:35 herbelin Exp $ *) +(* $Id: g_constr.ml4 8624 2006-03-13 17:38:17Z msozeau $ *) open Pcoq open Constr +open Prim open Rawterm open Term open Names open Libnames -open Prim open Topconstr -(* Initialize the lexer *) +open Util + let constr_kw = - [ "Cases"; "of"; "with"; "end"; "as"; "in"; "Prop"; "Set"; "Type"; - ":"; "("; ")"; "["; "]"; "{"; "}"; ","; ";"; "->"; "="; ":="; "!"; - "::"; "<:"; ":<"; "=>"; "<"; ">"; "|"; "?"; "/"; - "<->"; "\\/"; "/\\"; "`"; "``"; "&"; "*"; "+"; "@"; "^"; "#"; "-"; - "~"; "'"; "<<"; ">>"; "<>"; ".." - ] -let _ = - if !Options.v7 then - List.iter (fun s -> Lexer.add_token ("",s)) constr_kw -(* "let" is not a keyword because #Core#let.cci would not parse. - Is it still accurate ? *) + [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; + "end"; "as"; "let"; "if"; "then"; "else"; "return"; + "Prop"; "Set"; "Type"; ".("; "_"; ".." ] +let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw -let coerce_to_var = function - | CRef (Ident (_,id)) -> id - | ast -> Util.user_err_loc - (constr_loc ast,"Ast.coerce_to_var", - (Pp.str"This expression should be a simple identifier")) +let mk_cast = function + (c,(_,None)) -> c + | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, DEFAULTcast,ty) -let coerce_to_name = function - | CRef (Ident (loc,id)) -> (loc, Name id) - | ast -> Util.user_err_loc - (constr_loc ast,"Ast.coerce_to_var", - (Pp.str"This expression should be a simple identifier")) +let mk_lam = function + ([],c) -> c + | (bl,c) -> CLambdaN(constr_loc c, bl,c) -let set_loc loc = function - | CRef(Ident(_,i)) -> CRef(Ident(loc,i)) - | CRef(Qualid(_,q)) -> CRef(Qualid(loc,q)) - | CFix(_,x,a) -> CFix(loc,x,a) - | CCoFix(_,x,a) -> CCoFix(loc,x,a) - | CArrow(_,a,b) -> CArrow(loc,a,b) - | CProdN(_,bl,a) -> CProdN(loc,bl,a) - | CLambdaN(_,bl,a) -> CLambdaN(loc,bl,a) - | CLetIn(_,x,a,b) -> CLetIn(loc,x,a,b) - | CAppExpl(_,f,a) -> CAppExpl(loc,f,a) - | CApp(_,f,a) -> CApp(loc,f,a) - | CCases(_,p,a,br) -> CCases(loc,p,a,br) - | COrderedCase(_,s,p,a,br) -> COrderedCase(loc,s,p,a,br) - | CLetTuple(_,ids,p,a,b) -> CLetTuple(loc,ids,p,a,b) - | CIf(_,e,p,a,b) -> CIf(loc,e,p,a,b) - | CHole _ -> CHole loc - | CPatVar(_,v) -> CPatVar(loc,v) - | CEvar(_,ev) -> CEvar(loc,ev) - | CSort(_,s) -> CSort(loc,s) - | CCast(_,a,b) -> CCast(loc,a,b) - | CNotation(_,n,l) -> CNotation(loc,n,l) - | CNumeral(_,i) -> CNumeral(loc,i) - | CDelimiters(_,s,e) -> CDelimiters(loc,s,e) - | CDynamic(_,d) -> CDynamic(loc,d) +let loc_of_binder_let = function + | LocalRawAssum ((loc,_)::_,_)::_ -> loc + | LocalRawDef ((loc,_),_)::_ -> loc + | _ -> dummy_loc -open Util +let rec mkCProdN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> + CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) + | [] -> c + | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c -let rec abstract_constr loc c = function +let rec mkCLambdaN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> + CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) | [] -> c - | LocalRawDef ((loc',x),b)::bl -> - CLetIn (join_loc loc' loc, (loc', x), b, abstract_constr loc c bl) - | LocalRawAssum (nal,t)::bl -> - let loc' = join_loc (fst (List.hd nal)) loc in - CLambdaN(loc', [nal, t], abstract_constr loc c bl) + | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c -(* Hack to parse "(n)" as nat without conflicts with the (useless) *) -(* admissible notation "(n)" *) -let test_int_rparen = - Gram.Entry.of_parser "test_int_rparen" - (fun strm -> - match Stream.npeek 1 strm with - | [("INT", _)] -> - begin match Stream.npeek 2 strm with - | [_; ("", ")")] -> () - | _ -> raise Stream.Failure - end - | _ -> raise Stream.Failure) +let rec index_and_rec_order_of_annot loc bl ann = + match names_of_local_assums bl,ann with + | [_], (None, r) -> 0, r + | lids, (Some x, ro) -> + let ids = List.map snd lids in + (try list_index (snd x) ids - 1, ro + with Not_found -> + user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable")) + | _ -> user_err_loc(loc,"index_of_annot", + Pp.str "cannot guess decreasing argument of fix") -(* Hack to parse "n" at level 0 without conflicting with "n!" at level 91 *) -(* admissible notation "(n)" *) -let test_int_bang = - Gram.Entry.of_parser "test_int_bang" - (fun strm -> - match Stream.npeek 1 strm with - | [("INT", n)] -> - begin match Stream.npeek 2 strm with - | [_; ("", "!")] -> () - | _ -> raise Stream.Failure - end - | _ -> raise Stream.Failure) +let mk_fixb (id,bl,ann,body,(loc,tyc)) = + let n,ro = index_and_rec_order_of_annot (fst id) bl ann in + let ty = match tyc with + Some ty -> ty + | None -> CHole loc in + (snd id,(n,ro),bl,ty,body) + +let mk_cofixb (id,bl,ann,body,(loc,tyc)) = + let _ = option_app (fun (aloc,_) -> + Util.user_err_loc + (aloc,"Constr:mk_cofixb", + Pp.str"Annotation forbidden in cofix expression")) (fst ann) in + let ty = match tyc with + Some ty -> ty + | None -> CHole loc in + (snd id,bl,ty,body) + +let mk_fix(loc,kw,id,dcls) = + if kw then + let fb = List.map mk_fixb dcls in + CFix(loc,id,fb) + else + let fb = List.map mk_cofixb dcls in + CCoFix(loc,id,fb) + +let mk_single_fix (loc,kw,dcl) = + let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) -(* Hack to parse "`id:...`" at level 0 without conflicting with - "`...`" from ZArith *) -let test_ident_colon = - Gram.Entry.of_parser "test_ident_colon" +let binder_constr = + create_constr_entry (get_univ "constr") "binder_constr" + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let lpar_id_coloneq = + Gram.Entry.of_parser "test_lpar_id_coloneq" (fun strm -> match Stream.npeek 1 strm with - | [("IDENT", _)] -> - begin match Stream.npeek 2 strm with - | [_; ("", ":")] -> () - | _ -> raise Stream.Failure - end + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",s)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string s + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) -if !Options.v7 then GEXTEND Gram - GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot - (*ne_name_comma_list*); + GLOBAL: binder_constr lconstr constr operconstr sort global + constr_pattern lconstr_pattern Constr.ident binder binder_let pattern; Constr.ident: [ [ id = Prim.ident -> id (* This is used in quotations and Syntax *) | id = METAIDENT -> id_of_string id ] ] ; + Prim.name: + [ [ "_" -> (loc, Anonymous) ] ] + ; global: [ [ r = Prim.reference -> r @@ -138,231 +138,197 @@ GEXTEND Gram constr_pattern: [ [ c = constr -> c ] ] ; - ne_constr_list: - [ [ cl = LIST1 constr -> cl ] ] + lconstr_pattern: + [ [ c = lconstr -> c ] ] ; sort: [ [ "Set" -> RProp Pos | "Prop" -> RProp Null | "Type" -> RType None ] ] ; - constr: - [ [ c = operconstr LEVEL "8" -> c ] ] - ; lconstr: - [ [ c = operconstr LEVEL "10" -> c ] ] + [ [ c = operconstr LEVEL "200" -> c ] ] + ; + constr: + [ [ c = operconstr LEVEL "9" -> c ] ] ; operconstr: - [ "10" RIGHTA - [ "!"; f = global; args = LIST0 (operconstr LEVEL "9") -> - CAppExpl (loc, (None,f), args) -(* - | "!"; f = global; "with"; b = binding_list -> - <:ast< (APPLISTWITH $f $b) >> -*) - | f = operconstr; args = LIST1 constr91 -> CApp (loc, (None,f), args) ] - | "9" RIGHTA - [ c1 = operconstr; "::"; c2 = operconstr LEVEL "9" -> CCast (loc, c1, c2) ] - | "8" RIGHTA - [ c1 = operconstr; "->"; c2 = operconstr LEVEL "8"-> CArrow (loc, c1, c2) ] - | "1" RIGHTA - [ "<"; p = annot; ">"; IDENT "Match"; c = constr; "with"; - cl = LIST0 constr; "end" -> - COrderedCase (loc, MatchStyle, Some p, c, cl) - | "<"; p = annot; ">"; IDENT "Case"; c = constr; "of"; - cl = LIST0 constr; "end" -> - COrderedCase (loc, RegularStyle, Some p, c, cl) - | IDENT "Case"; c = constr; "of"; cl = LIST0 constr; "end" -> - COrderedCase (loc, RegularStyle, None, c, cl) - | IDENT "Match"; c = constr; "with"; cl = LIST1 constr; "end" -> - COrderedCase (loc, MatchStyle, None, c, cl) - | IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; - c = constr; "in"; c1 = constr -> - (* TODO: right loc *) - COrderedCase - (loc, LetStyle, None, c, [CLambdaN (loc, [b, CHole loc], c1)]) - | IDENT "let"; na = name; "="; c = opt_casted_constr; - "in"; c1 = constr -> - CLetIn (loc, na, c, c1) - | IDENT "if"; c1 = constr; - IDENT "then"; c2 = constr; - IDENT "else"; c3 = constr -> - COrderedCase (loc, IfStyle, None, c1, [c2; c3]) - | "<"; p = annot; ">"; - IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; - "in"; c1 = constr -> - (* TODO: right loc *) - COrderedCase (loc, LetStyle, Some p, c, - [CLambdaN (loc, [b, CHole loc], c1)]) - | "<"; p = annot; ">"; - IDENT "if"; c1 = constr; - IDENT "then"; c2 = constr; - IDENT "else"; c3 = constr -> - COrderedCase (loc, IfStyle, Some p, c1, [c2; c3]) - | ".."; c = operconstr LEVEL "0"; ".." -> + [ "200" RIGHTA + [ c = binder_constr -> c ] + | "100" RIGHTA + [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,DEFAULTcast,c2) + | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,DEFAULTcast,c2) ] + | "99" RIGHTA [ ] + | "90" RIGHTA + [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) + | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)] + | "10" LEFTA + [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args) + | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ] + | "9" + [ ".."; c = operconstr LEVEL "0"; ".." -> CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] - | "0" RIGHTA - [ "?" -> CHole loc - | "?"; n = Prim.natural -> CPatVar (loc, (false,Pattern.patvar_of_int n)) - | bll = binders; c = constr -> abstract_constr loc c bll - (* Hack to parse syntax "(n)" as a natural number *) - | "("; test_int_rparen; n = bigint; ")" -> - (* Delimiter "N" moved to "nat" in V7 *) - CDelimiters (loc,"nat",CNumeral (loc,n)) - | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_tail -> - let id = coerce_to_name lc1 in - CProdN (loc, ([id], c)::bl, body) -(* TODO: Syntaxe (_:t...)t et (_,x...)t *) - | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; - (bl,body) = product_tail -> - let id1 = coerce_to_name lc1 in - let id2 = coerce_to_name lc2 in - CProdN (loc, ([id1; id2], c)::bl, body) - | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; - idl = ne_name_comma_list; ":"; c = constr; (bl,body) = product_tail -> - let id1 = coerce_to_name lc1 in - let id2 = coerce_to_name lc2 in - CProdN (loc, (id1::id2::idl, c)::bl, body) - | "("; lc1 = lconstr; ")" -> - if Options.do_translate() then set_loc loc lc1 else lc1 - | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" -> - (match lc1 with - | CPatVar (loc2,(false,n)) -> - CApp (loc,(None,CPatVar (loc2, (true,n))), List.map (fun c -> c, None) cl) - | _ -> - Util.error "Second-order pattern-matching expects a head metavariable") - | IDENT "Fix"; id = identref; "{"; fbinders = fixbinders; "}" -> - CFix (loc, id, fbinders) - | IDENT "CoFix"; id = identref; "{"; fbinders = cofixbinders; "}" -> - CCoFix (loc, id, fbinders) - | IDENT "Prefix" ; "(" ; s = STRING ; cl = LIST0 constr ; ")" -> - CNotation(loc, s, cl) - | s = sort -> CSort (loc, s) - | v = global -> CRef v - | n = bigint -> CNumeral (loc,n) - | "!"; f = global -> CAppExpl (loc,(None,f),[]) - | "'"; test_ident_colon; key = IDENT; ":"; c = constr; "'" -> - (* Delimiter "N" implicitly moved to "nat" in V7 *) - let key = if key = "N" then "nat" else key in - let key = if key = "P" then "positive" else key in - let key = if key = "T" then "type" else key in - CDelimiters (loc,key,c) ] ] + | "1" LEFTA + [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> + CApp(loc,(Some (List.length args+1),CRef f),args@[c,None]) + | c=operconstr; ".("; "@"; f=global; + args=LIST0 (operconstr LEVEL "9"); ")" -> + CAppExpl(loc,(Some (List.length args+1),f),args@[c]) + | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ] + | "0" + [ c=atomic_constr -> c + | c=match_constr -> c + | "("; c = operconstr LEVEL "200"; ")" -> + (match c with + CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> + CNotation(loc,"( _ )",[c]) + | _ -> c) ] ] ; - constr91: - [ [ test_int_bang; n = INT; "!"; c = operconstr LEVEL "9" -> - (c, Some (loc,ExplByPos (int_of_string n))) - | c = operconstr LEVEL "9" -> (c, None) ] ] + binder_constr: + [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" -> + mkCProdN loc bl c + | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" -> + mkCLambdaN loc bl c + | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":="; + c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> + let loc1 = loc_of_binder_let bl in + CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) + | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> + let fixp = mk_single_fix fx in + let (li,id) = match fixp with + CFix(_,id,_) -> id + | CCoFix(_,id,_) -> id + | _ -> assert false in + CLetIn(loc,(li,Name id),fixp,c) + | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; + po = return_type; + ":="; c1 = operconstr LEVEL "200"; "in"; + c2 = operconstr LEVEL "200" -> + CLetTuple (loc,List.map snd lb,po,c1,c2) + | "if"; c=operconstr LEVEL "200"; po = return_type; + "then"; b1=operconstr LEVEL "200"; + "else"; b2=operconstr LEVEL "200" -> + CIf (loc, c, po, b1, b2) + | c=fix_constr -> c ] ] ; - (* annot and product_annot_tail are hacks to forbid concrete syntax *) - (* ">" (e.g. for gt, Zgt, ...) in annotations *) - annot: - [ RIGHTA - [ bll = binders; c = annot -> abstract_constr loc c bll - | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_annot_tail -> - let id = coerce_to_name lc1 in - CProdN (loc, ([id], c)::bl, body) - | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; - (bl,body) = product_annot_tail -> - let id1 = coerce_to_name lc1 in - let id2 = coerce_to_name lc2 in - CProdN (loc, ([id1; id2], c)::bl, body) - | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; - idl = ne_name_comma_list; ":"; c = constr; - (bl,body) = product_annot_tail -> - let id1 = coerce_to_name lc1 in - let id2 = coerce_to_name lc2 in - CProdN (loc, (id1::id2::idl, c)::bl, body) - | "("; lc1 = lconstr; ")" -> lc1 - | c1 = annot; "->"; c2 = annot -> CArrow (loc, c1, c2) ] - | RIGHTA - [ c1 = annot; "\\/"; c2 = annot -> CNotation (loc, "_ \\/ _", [c1;c2]) ] - | RIGHTA - [ c1 = annot; "/\\"; c2 = annot -> CNotation (loc, "_ /\\ _", [c1;c2]) ] - | RIGHTA - [ "~"; c = SELF -> CNotation (loc, "~ _", [c]) ] - | RIGHTA - [ c1 = SELF; "=="; c2 = NEXT -> CNotation (loc, "_ == _", [c1;c2]) ] - | RIGHTA - [ c1 = SELF; "="; c2 = NEXT -> CNotation (loc, "_ = _", [c1;c2]) ] - | [ c = operconstr LEVEL "4L" -> c ] ] + appl_arg: + [ [ id = lpar_id_coloneq; c=lconstr; ")" -> + (c,Some (loc,ExplByName id)) + | c=constr -> (c,None) ] ] ; - product_annot_tail: - [ [ ";"; idl = ne_name_comma_list; ":"; c = constr; - (bl,c2) = product_annot_tail -> ((idl, c)::bl, c2) - | ";"; idl = ne_name_comma_list; (bl,c2) = product_annot_tail -> - ((idl, CHole (fst (List.hd idl)))::bl, c2) - | ")"; c = annot -> ([], c) ] ] + atomic_constr: + [ [ g=global -> CRef g + | s=sort -> CSort (loc,s) + | n=INT -> CPrim (loc, Numeral (Bigint.of_string n)) + | s=string -> CPrim (loc, String s) + | "_" -> CHole loc + | "?"; id=ident -> CPatVar(loc,(false,id)) ] ] ; - ne_name_comma_list: - [ [ nal = LIST1 name SEP "," -> nal ] ] + fix_constr: + [ [ fx1=single_fix -> mk_single_fix fx1 + | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with"; + "for"; id=identref -> + mk_fix(loc,kw,id,dcl1::dcls) + ] ] ; - name_comma_list_tail: - [ [ ","; idl = ne_name_comma_list -> idl - | -> [] ] ] + single_fix: + [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ] ; - opt_casted_constr: - [ [ c = constr; ":"; t = constr -> CCast (loc, c, t) - | c = constr -> c ] ] + fix_kw: + [ [ "fix" -> true + | "cofix" -> false ] ] ; - vardecls: - [ [ na = name; nal = name_comma_list_tail; c = type_option -> - LocalRawAssum (na::nal,c) - | na = name; "="; c = opt_casted_constr -> - LocalRawDef (na, c) - | na = name; ":="; c = opt_casted_constr -> - LocalRawDef (na, c) - - (* This is used in quotations *) - | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c) - ] ] + fix_decl: + [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":="; + c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ] ; - ne_vardecls_list: - [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl - | id = vardecls -> [id] ] ] + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> (Some id, CStructRec) + | "{"; IDENT "wf"; id=name; rel=lconstr; "}" -> (Some id, CWfRec rel) + | -> (None, CStructRec) + ] ] ; - binders: - [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ] + match_constr: + [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; + br=branches; "end" -> CCases(loc,ty,ci,br) ] ] ; - simple_params: - [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) - | idl = LIST1 name SEP "," -> (idl, CHole loc) - ] ] + case_item: + [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] ; - simple_binders: - [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ] + pred_pattern: + [ [ ona = OPT ["as"; id=name -> snd id]; + ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] ; - ne_simple_binders_list: - [ [ bll = LIST1 simple_binders -> List.flatten bll ] ] + case_type: + [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] ; - type_option: - [ [ ":"; c = constr -> c - | -> CHole loc ] ] + return_type: + [ [ a = OPT [ na = OPT["as"; id=name -> snd id]; + ty = case_type -> (na,ty) ] -> + match a with + | None -> None, None + | Some (na,t) -> (na, Some t) + ] ] ; - fixbinder: - [ [ id = base_ident; "/"; recarg = natural; ":"; type_ = constr; - ":="; def = constr -> - (id, recarg-1, [], type_, def) - | id = base_ident; bl = ne_simple_binders_list; ":"; type_ = constr; - ":="; def = constr -> - let ni = List.length (List.flatten (List.map fst bl)) -1 in - let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in - (id, ni, bl, type_, def) ] ] + branches: + [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; - fixbinders: - [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ] + eqn: + [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ] ; - cofixbinder: - [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr -> - (id, [],type_, def) ] ] + pattern: + [ "200" RIGHTA [ ] + | "100" LEFTA + [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ] + | "99" RIGHTA [ ] + | "10" LEFTA + [ p = pattern; lp = LIST1 (pattern LEVEL "0") -> + (match p with + | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) + | _ -> Util.user_err_loc + (cases_pattern_loc p, "compound_pattern", + Pp.str "Constructor expected")) + | p = pattern; "as"; id = ident -> + CPatAlias (loc, p, id) + | c = pattern; "%"; key=IDENT -> + CPatDelimiters (loc,key,c) ] + | "0" + [ r = Prim.reference -> CPatAtom (loc,Some r) + | "_" -> CPatAtom (loc,None) + | "("; p = pattern LEVEL "200"; ")" -> + (match p with + CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> + CPatNotation(loc,"( _ )",[p]) + | _ -> p) + | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n)) + | s = string -> CPatPrim (loc, String s) ] ] + ; + binder_list: + [ [ idl=LIST1 name; bl=LIST0 binder_let -> + LocalRawAssum (idl,CHole loc)::bl + | idl=LIST1 name; ":"; c=lconstr -> + [LocalRawAssum (idl,c)] + | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let -> + LocalRawAssum (idl,c)::bl ] ] + ; + binder_let: + [ [ id=name -> + LocalRawAssum ([id],CHole loc) + | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> + LocalRawAssum (id::idl,c) + | "("; id=name; ":"; c=lconstr; ")" -> + LocalRawAssum ([id],c) + | "("; id=name; ":="; c=lconstr; ")" -> + LocalRawDef (id,c) + | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> + LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c,DEFAULTcast,t)) + ] ] ; - cofixbinders: - [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ] + binder: + [ [ id=name -> ([id],CHole loc) + | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ] ; - product_tail: - [ [ ";"; idl = ne_name_comma_list; ":"; c = constr; - (bl,c2) = product_tail -> ((idl, c)::bl, c2) - | ";"; idl = ne_name_comma_list; (bl,c2) = product_tail -> - ((idl, CHole (fst (List.hd idl)))::bl, c2) - | ")"; c = constr -> ([], c) ] ] + type_cstr: + [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] ; -END;; + END;; diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4 deleted file mode 100644 index fe579e98..00000000 --- a/parsing/g_constrnew.ml4 +++ /dev/null @@ -1,338 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_constrnew.ml4,v 1.41.2.4 2005/09/21 14:47:33 herbelin Exp $ *) - -open Pcoq -open Constr -open Prim -open Rawterm -open Term -open Names -open Libnames -open Topconstr - -open Util - -let constr_kw = - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; - "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type"; ".("; "_"; ".." ] - -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) constr_kw - -(* For Correctness syntax; doesn't work if in psyntax (freeze pb?) *) -let _ = Lexer.add_token ("","!") - -let mk_cast = function - (c,(_,None)) -> c - | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, ty) - -let mk_lam = function - ([],c) -> c - | (bl,c) -> CLambdaN(constr_loc c, bl,c) - -let mk_match (loc,cil,rty,br) = - CCases(loc,(None,rty),cil,br) - -let loc_of_binder_let = function - | LocalRawAssum ((loc,_)::_,_)::_ -> loc - | LocalRawDef ((loc,_),_)::_ -> loc - | _ -> dummy_loc - -let rec mkCProdN loc bll c = - match bll with - | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> - CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> - CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) - | [] -> c - | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c - -let rec mkCLambdaN loc bll c = - match bll with - | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> - CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> - CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) - | [] -> c - | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c - -let rec index_of_annot loc bl ann = - match names_of_local_assums bl,ann with - | [_], None -> 0 - | lids, Some x -> - let ids = List.map snd lids in - (try list_index (snd x) ids - 1 - with Not_found -> - user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable")) - | _ -> user_err_loc(loc,"index_of_annot", - Pp.str "cannot guess decreasing argument of fix") - -let mk_fixb (id,bl,ann,body,(loc,tyc)) = - let n = index_of_annot (fst id) bl ann in - let ty = match tyc with - Some ty -> ty - | None -> CHole loc in - (snd id,n,bl,ty,body) - -let mk_cofixb (id,bl,ann,body,(loc,tyc)) = - let _ = option_app (fun (aloc,_) -> - Util.user_err_loc - (aloc,"Constr:mk_cofixb", - Pp.str"Annotation forbidden in cofix expression")) ann in - let ty = match tyc with - Some ty -> ty - | None -> CHole loc in - (snd id,bl,ty,body) - -let mk_fix(loc,kw,id,dcls) = - if kw then - let fb = List.map mk_fixb dcls in - CFix(loc,id,fb) - else - let fb = List.map mk_cofixb dcls in - CCoFix(loc,id,fb) - -let mk_single_fix (loc,kw,dcl) = - let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) - -let binder_constr = - create_constr_entry (get_univ "constr") "binder_constr" - -(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) -(* admissible notation "(x t)" *) -let lpar_id_coloneq = - Gram.Entry.of_parser "test_lpar_id_coloneq" - (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",s)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; - Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr sort global - constr_pattern lconstr_pattern Constr.ident binder binder_let pattern; - Constr.ident: - [ [ id = Prim.ident -> id - - (* This is used in quotations and Syntax *) - | id = METAIDENT -> id_of_string id ] ] - ; - Prim.name: - [ [ "_" -> (loc, Anonymous) ] ] - ; - Prim.ast: - [ [ "_" -> Coqast.Nvar(loc,id_of_string"_") ] ] - ; - global: - [ [ r = Prim.reference -> r - - (* This is used in quotations *) - | id = METAIDENT -> Ident (loc,id_of_string id) ] ] - ; - constr_pattern: - [ [ c = constr -> c ] ] - ; - lconstr_pattern: - [ [ c = lconstr -> c ] ] - ; - sort: - [ [ "Set" -> RProp Pos - | "Prop" -> RProp Null - | "Type" -> RType None ] ] - ; - lconstr: - [ [ c = operconstr LEVEL "200" -> c ] ] - ; - constr: - [ [ c = operconstr LEVEL "9" -> c ] ] - ; - operconstr: - [ "200" RIGHTA - [ c = binder_constr -> c ] - | "100" RIGHTA - [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,c2) - | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,c2) ] - | "99" RIGHTA [ ] - | "90" RIGHTA - [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) - | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)] - | "10" LEFTA - [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args) - | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ] - | "9" - [ ".."; c = operconstr LEVEL "0"; ".." -> - CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] - | "1" LEFTA - [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> - CApp(loc,(Some (List.length args+1),CRef f),args@[c,None]) - | c=operconstr; ".("; "@"; f=global; - args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(loc,(Some (List.length args+1),f),args@[c]) - | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ] - | "0" - [ c=atomic_constr -> c - | c=match_constr -> c - | "("; c = operconstr LEVEL "200"; ")" -> - (match c with - CNumeral(_,Bignat.POS _) -> CNotation(loc,"( _ )",[c]) - | _ -> c) ] ] - ; - binder_constr: - [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" -> - mkCProdN loc bl c - | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" -> - mkCLambdaN loc bl c - | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":="; - c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - let loc1 = loc_of_binder_let bl in - CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) - | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> - let fixp = mk_single_fix fx in - let (li,id) = match fixp with - CFix(_,id,_) -> id - | CCoFix(_,id,_) -> id - | _ -> assert false in - CLetIn(loc,(li,Name id),fixp,c) - | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; - po = return_type; - ":="; c1 = operconstr LEVEL "200"; "in"; - c2 = operconstr LEVEL "200" -> - CLetTuple (loc,List.map snd lb,po,c1,c2) - | "if"; c=operconstr LEVEL "200"; po = return_type; - "then"; b1=operconstr LEVEL "200"; - "else"; b2=operconstr LEVEL "200" -> - CIf (loc, c, po, b1, b2) - | c=fix_constr -> c ] ] - ; - appl_arg: - [ [ id = lpar_id_coloneq; c=lconstr; ")" -> - (c,Some (loc,ExplByName id)) - | c=constr -> (c,None) ] ] - ; - atomic_constr: - [ [ g=global -> CRef g - | s=sort -> CSort(loc,s) - | n=INT -> CNumeral (loc,Bignat.POS (Bignat.of_string n)) - | "_" -> CHole loc - | "?"; id=ident -> CPatVar(loc,(false,id)) ] ] - ; - fix_constr: - [ [ fx1=single_fix -> mk_single_fix fx1 - | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with"; - "for"; id=identref -> - mk_fix(loc,kw,id,dcl1::dcls) - ] ] - ; - single_fix: - [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ] - ; - fix_kw: - [ [ "fix" -> true - | "cofix" -> false ] ] - ; - fix_decl: - [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":="; - c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ] - ; - fixannot: - [ [ "{"; IDENT "struct"; id=name; "}" -> Some id - | -> None ] ] - ; - match_constr: - [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; - br=branches; "end" -> mk_match (loc,ci,ty,br) ] ] - ; - case_item: - [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] - ; - pred_pattern: - [ [ ona = OPT ["as"; id=name -> snd id]; - ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] - ; - case_type: - [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] - ; - return_type: - [ [ a = OPT [ na = OPT["as"; id=name -> snd id]; - ty = case_type -> (na,ty) ] -> - match a with - | None -> None, None - | Some (na,t) -> (na, Some t) - ] ] - ; - branches: - [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] - ; - eqn: - [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ] - ; - pattern: - [ "200" RIGHTA [ ] - | "99" RIGHTA [ ] - | "10" LEFTA - [ p = pattern ; lp = LIST1 (pattern LEVEL "0") -> - (match p with - | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) - | _ -> Util.user_err_loc - (cases_pattern_loc p, "compound_pattern", - Pp.str "Constructor expected")) - | p = pattern; "as"; id = base_ident -> - CPatAlias (loc, p, id) - | c = pattern; "%"; key=IDENT -> - CPatDelimiters (loc,key,c) ] - | "0" - [ r = Prim.reference -> CPatAtom (loc,Some r) - | "_" -> CPatAtom (loc,None) - | "("; p = pattern LEVEL "200"; ")" -> - (match p with - CPatNumeral(_,Bignat.POS _) -> CPatNotation(loc,"( _ )",[p]) - | _ -> p) - | n = INT -> CPatNumeral (loc,Bignat.POS(Bignat.of_string n)) ] ] - ; - binder_list: - [ [ idl=LIST1 name; bl=LIST0 binder_let -> - LocalRawAssum (idl,CHole loc)::bl - | idl=LIST1 name; ":"; c=lconstr -> - [LocalRawAssum (idl,c)] - | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let -> - LocalRawAssum (idl,c)::bl ] ] - ; - binder_let: - [ [ id=name -> - LocalRawAssum ([id],CHole loc) - | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> - LocalRawAssum (id::idl,c) - | "("; id=name; ":"; c=lconstr; ")" -> - LocalRawAssum ([id],c) - | "("; id=name; ":="; c=lconstr; ")" -> - LocalRawDef (id,c) - | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> - LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c,t)) - ] ] - ; - binder: - [ [ id=name -> ([id],CHole loc) - | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ] - ; - type_cstr: - [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] - ; - END;; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 7349a6f8..6ed22c7e 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,16 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_ltac.ml4,v 1.28.2.2 2004/07/16 19:30:38 herbelin Exp $ *) +(* $Id: g_ltac.ml4 8129 2006-03-05 09:05:12Z herbelin $ *) open Pp open Util -open Ast open Topconstr open Rawterm open Tacexpr open Vernacexpr -open Ast open Pcoq open Prim open Tactic @@ -37,163 +35,156 @@ let arg_of_expr = function TacArg a -> a | e -> Tacexp (e:raw_tactic_expr) +let tacarg_of_expr = function + | TacArg (Reference r) -> TacCall (dummy_loc,r,[]) + | TacArg a -> a + | e -> Tacexp (e:raw_tactic_expr) + (* Tactics grammar rules *) -if !Options.v7 then GEXTEND Gram - GLOBAL: tactic Vernac_.command tactic_arg; + GLOBAL: tactic Vernac_.command tactic_expr tactic_arg constr_may_eval; -(* - GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun; -*) + tactic_expr: + [ "5" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1) + | ta = tactic_expr; ";"; + "["; lta = LIST0 OPT tactic_expr SEP "|"; "]" -> + let lta = List.map (function None -> TacId [] | Some t -> t) lta in + TacThens (ta, lta) ] + | "4" + [ ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "info"; tc = tactic_expr -> TacInfo tc +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + TacAbstract (tc,Some s) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr -> + TacFun (it,body) + | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in"; + body = tactic_expr -> TacLetRecIn (rcl,body) + | "let"; llc = LIST1 let_clause SEP "with"; "in"; + u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u) + | b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchContext (b,false,mrl) + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchContext (b,true,mrl) + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (b,c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "complete" ; ta = tactic_expr -> TacComplete ta + | IDENT "idtac"; l = LIST0 message_token -> TacId l + | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (n,l) + | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg -> + TacArg (TacExternal (loc,com,req,la)) + | st = simple_tactic -> TacAtom (loc,st) + | a = may_eval_arg -> TacArg(a) + | IDENT "constr"; ":"; c = Constr.constr -> + TacArg(ConstrMayEval(ConstrTerm c)) + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + TacArg(IntroPattern ipat) + | r = reference; la = LIST1 tactic_arg -> + TacArg(TacCall (loc,r,la)) + | r = reference -> TacArg (Reference r) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | a = tactic_atom -> TacArg a ] ] + ; + (* Tactic arguments *) + tactic_arg: + [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> tacarg_of_expr a + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat + | a = may_eval_arg -> a + | r = reference -> Reference r + | a = tactic_atom -> a + | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] + ; + may_eval_arg: + [ [ c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; s = OPT STRING -> TacFreshId s ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrEval (rtc,c) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrContext (id,c) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrTypeOf c ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> c + | c = Constr.constr -> ConstrTerm c ] ] + ; + tactic_atom: + [ [ id = METAIDENT -> MetaIdArg (loc,id) + | "()" -> TacVoid ] ] + ; + match_key: + [ [ "match" -> false ] ] + ; input_fun: - [ [ l = base_ident -> Some l - | "()" -> None ] ] + [ [ "_" -> None + | l = ident -> Some l ] ] ; let_clause: - [ [ id = identref; "="; te = tactic_letarg -> LETCLAUSE (id, None, te) - | id = base_ident; ":"; c = Constr.constr; ":="; "Proof" -> - LETTOPCLAUSE (id, c) - | id = identref; ":"; c = constrarg; ":="; te = tactic_letarg -> - LETCLAUSE (id, Some (TacArg(ConstrMayEval c)), te) - | id = base_ident; ":"; c = Constr.constr -> - LETTOPCLAUSE (id, c) ] ] + [ [ id = identref; ":="; te = tactic_expr -> + LETCLAUSE (id, None, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ] ; rec_clause: - [ [ name = identref; it = LIST1 input_fun; "->"; body = tactic_expr -> + [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr -> (name,(it,body)) ] ] ; match_pattern: - [ [ id = Constr.constr_pattern; "["; pc = Constr.constr_pattern; "]" -> - let (_,s) = coerce_to_id id in Subterm (Some s, pc) - | "["; pc = Constr.constr_pattern; "]" -> Subterm (None,pc) - | pc = Constr.constr_pattern -> Term pc ] ] + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + Subterm (oid, pc) + | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) ] ] ; match_context_rule: - [ [ "["; largs = LIST0 match_hyps SEP ";"; "|-"; mp = match_pattern; "]"; - "->"; te = tactic_expr -> Pat (largs, mp, te) - | IDENT "_"; "->"; te = tactic_expr -> All te ] ] + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] ; match_context_list: [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] ; match_rule: - [ [ "["; mp = match_pattern; "]"; "->"; te = tactic_expr -> Pat ([],mp,te) - | IDENT "_"; "->"; te = tactic_expr -> All te ] ] + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> mrl | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] ; - tactic_expr: - [ [ ta = tactic_expr5 -> ta ] ] - ; - tactic_expr5: - [ [ ta0 = tactic_expr5; ";"; ta1 = tactic_expr4 -> TacThen (ta0, ta1) - | ta = tactic_expr5; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" -> - TacThens (ta, lta) - | y = tactic_expr4 -> y ] ] - ; - tactic_expr4: - [ [ ta = tactic_expr3 -> ta ] ] - ; - tactic_expr3: - [ [ IDENT "Try"; ta = tactic_expr3 -> TacTry ta - | IDENT "Do"; n = int_or_var; ta = tactic_expr3 -> TacDo (n,ta) - | IDENT "Repeat"; ta = tactic_expr3 -> TacRepeat ta - | IDENT "Progress"; ta = tactic_expr3 -> TacProgress ta - | IDENT "Info"; tc = tactic_expr3 -> TacInfo tc - | ta = tactic_expr2 -> ta ] ] - ; - tactic_expr2: - [ [ ta0 = tactic_atom; "Orelse"; ta1 = tactic_expr3 -> TacOrelse (ta0,ta1) - | ta = tactic_atom -> ta ] ] - ; - tactic_atom: - [ [ IDENT "Fun"; it = LIST1 input_fun ; "->"; body = tactic_expr -> - TacFun (it,body) - | IDENT "Rec"; rc = rec_clause -> - warning "'Rec f ...' is obsolete; use 'Rec f ... In f' instead"; - TacLetRecIn ([rc],TacArg (Reference (Libnames.Ident (fst rc)))) - | IDENT "Rec"; rc = rec_clause; rcl = LIST0 rec_clause SEP "And"; - [IDENT "In" | "in"]; body = tactic_expr -> TacLetRecIn (rc::rcl,body) - | IDENT "Let"; llc = LIST1 let_clause SEP "And"; IDENT "In"; - u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u) - - | IDENT "Match"; IDENT "Context"; IDENT "With"; mrl = match_context_list - -> TacMatchContext (false,mrl) - | IDENT "Match"; IDENT "Reverse"; IDENT "Context"; IDENT "With"; mrl = match_context_list - -> TacMatchContext (true,mrl) - | IDENT "Match"; c = constrarg; IDENT "With"; mrl = match_list -> - TacMatch (TacArg(ConstrMayEval c),mrl) -(*To do: put Abstract in Refiner*) - | IDENT "Abstract"; tc = tactic_expr -> TacAbstract (tc,None) - | IDENT "Abstract"; tc = tactic_expr; "using"; s = base_ident -> - TacAbstract (tc,Some s) -(*End of To do*) - | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "Solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "Idtac" ; s = [ s = STRING -> s | -> ""] -> TacId s - | IDENT "Fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; - s = [ s = STRING -> s | -> ""] -> TacFail (n,s) - | st = simple_tactic -> TacAtom (loc,st) - | "("; a = tactic_expr; ")" -> a - | a = tactic_arg -> TacArg a - ] ] - ; - (* Tactic arguments *) - tactic_arg: - [ [ ta = tactic_arg1 -> ta ] ] - ; - tactic_letarg: - (* Cannot be merged with tactic_arg1, since then "In"/"And" are - parsed as lqualid! *) - [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrMayEval (ConstrEval (rtc,c)) - | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> - ConstrMayEval (ConstrContext (id,c)) - | IDENT "Check"; c = Constr.constr -> - ConstrMayEval (ConstrTypeOf c) - | IDENT "FreshId"; s = OPT STRING -> TacFreshId s - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat - | r = reference -> Reference r - | ta = tactic_arg0 -> ta ] ] - ; - tactic_arg1: - [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrMayEval (ConstrEval (rtc,c)) - | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> - ConstrMayEval (ConstrContext (id,c)) - | IDENT "Check"; c = Constr.constr -> - ConstrMayEval (ConstrTypeOf c) - | IDENT "FreshId"; s = OPT STRING -> TacFreshId s - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat - | r = reference; la = LIST1 tactic_arg0 -> TacCall (loc,r,la) - | r = reference -> Reference r - | ta = tactic_arg0 -> ta ] ] - ; - tactic_arg0: - [ [ "("; a = tactic_expr; ")" -> arg_of_expr a - | "()" -> TacVoid - | r = reference -> Reference r - | n = integer -> Integer n - | id = METAIDENT -> MetaIdArg (loc,id) - | "?" -> ConstrMayEval (ConstrTerm (CHole loc)) - | "?"; n = natural -> ConstrMayEval (ConstrTerm (CPatVar (loc,(false,Pattern.patvar_of_int n)))) - | "'"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] + message_token: + [ [ id = identref -> MsgIdent (AI id) + | s = STRING -> MsgString s + | n = integer -> MsgInt n ] ] ; (* Definitions for tactics *) - deftok: - [ [ IDENT "Meta" - | IDENT "Tactic" ] ] - ; tacdef_body: [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr -> (name, TacFun (it, body)) @@ -204,10 +195,8 @@ GEXTEND Gram [ [ tac = tactic_expr -> tac ] ] ; Vernac_.command: - [ [ deftok; "Definition"; b = tacdef_body -> - VernacDeclareTacticDefinition (false, [b]) - | IDENT "Recursive"; deftok; "Definition"; - l = LIST1 tacdef_body SEP "And" -> + [ [ IDENT "Ltac"; + l = LIST1 tacdef_body SEP "with" -> VernacDeclareTacticDefinition (true, l) ] ] ; END diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4 deleted file mode 100644 index 7492ac8c..00000000 --- a/parsing/g_ltacnew.ml4 +++ /dev/null @@ -1,195 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_ltacnew.ml4,v 1.22.2.3 2005/06/21 15:31:12 herbelin Exp $ *) - -open Pp -open Util -open Ast -open Topconstr -open Rawterm -open Tacexpr -open Vernacexpr -open Ast -open Pcoq -open Prim -open Tactic - -type let_clause_kind = - | LETTOPCLAUSE of Names.identifier * constr_expr - | LETCLAUSE of - (Names.identifier Util.located * raw_tactic_expr option * raw_tactic_arg) - -let fail_default_value = Genarg.ArgArg 0 - -let out_letin_clause loc = function - | LETTOPCLAUSE _ -> user_err_loc (loc, "", (str "Syntax Error")) - | LETCLAUSE (id,c,d) -> (id,c,d) - -let make_letin_clause loc = List.map (out_letin_clause loc) - -let arg_of_expr = function - TacArg a -> a - | e -> Tacexp (e:raw_tactic_expr) - -(* Tactics grammar rules *) - -let tactic_expr = Gram.Entry.create "tactic:tactic_expr" - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: tactic Vernac_.command tactic_expr tactic_arg constr_may_eval; - - tactic_expr: - [ "5" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1) - | ta = tactic_expr; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" -> - TacThens (ta, lta) ] - | "4" - [ ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "info"; tc = tactic_expr -> TacInfo tc -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = base_ident -> - TacAbstract (tc,Some s) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr -> - TacFun (it,body) - | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in"; - body = tactic_expr -> TacLetRecIn (rcl,body) - | "let"; llc = LIST1 let_clause SEP "with"; "in"; - u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u) - | "match"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchContext (false,mrl) - | "match"; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchContext (true,mrl) - | "match"; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; s = [ s = STRING -> s | -> ""] -> TacId s - | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; - s = [ s = STRING -> s | -> ""] -> TacFail (n,s) - | st = simple_tactic -> TacAtom (loc,st) - | a = may_eval_arg -> TacArg(a) - | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(ConstrMayEval(ConstrTerm c)) - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> - TacArg(IntroPattern ipat) - | r = reference; la = LIST1 tactic_arg -> - TacArg(TacCall (loc,r,la)) - | r = reference -> TacArg (Reference r) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | a = tactic_atom -> TacArg a ] ] - ; - (* Tactic arguments *) - tactic_arg: - [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat - | a = may_eval_arg -> a - | a = tactic_atom -> a - | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] - ; - may_eval_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; s = OPT STRING -> TacFreshId s ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ id = METAIDENT -> MetaIdArg (loc,id) - | r = reference -> Reference r - | "()" -> TacVoid ] ] - ; - input_fun: - [ [ "_" -> None - | l = base_ident -> Some l ] ] - ; - let_clause: - [ [ id = identref; ":="; te = tactic_expr -> - LETCLAUSE (id, None, arg_of_expr te) - | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ] - ; - rec_clause: - [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr -> - (name,(it,body)) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - - (* Definitions for tactics *) -(* - deftok: - [ [ IDENT "Meta" - | IDENT "Tactic" ] ] - ; -*) - tacdef_body: - [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr -> - (name, TacFun (it, body)) - | name = identref; ":="; body = tactic_expr -> - (name, body) ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - Vernac_.command: - [ [ IDENT "Ltac"; - l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition (true, l) ] ] - ; - END diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 index dd4ef517..ed8dda5c 100644 --- a/parsing/g_minicoq.ml4 +++ b/parsing/g_minicoq.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_minicoq.ml4,v 1.17.6.1 2004/07/16 19:30:38 herbelin Exp $ *) +(* $Id: g_minicoq.ml4 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Util diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli index e19b1163..345d9575 100644 --- a/parsing/g_minicoq.mli +++ b/parsing/g_minicoq.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_minicoq.mli,v 1.8.16.1 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_minicoq.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Pp diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4 deleted file mode 100644 index 0b542608..00000000 --- a/parsing/g_module.ml4 +++ /dev/null @@ -1,47 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_module.ml4,v 1.6.2.1 2004/07/16 19:30:39 herbelin Exp $ *) - -open Pp -open Ast -open Pcoq -open Prim -open Module -open Util -open Topconstr - -(* Grammar rules for module expressions and types *) - -if !Options.v7 then -GEXTEND Gram - GLOBAL: module_expr module_type; - - module_expr: - [ [ qid = qualid -> CMEident qid - | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) - | "("; me = module_expr; ")" -> me -(* ... *) - ] ] - ; - - with_declaration: - [ [ "Definition"; id = identref; ":="; c = Constr.constr -> - CWith_Definition (id,c) - | IDENT "Module"; id = identref; ":="; qid = qualid -> - CWith_Module (id,qid) - ] ] - ; - - module_type: - [ [ qid = qualid -> CMTEident qid -(* ... *) - | mty = module_type; "with"; decl = with_declaration -> - CMTEwith (mty,decl) ] ] - ; -END diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml index 46ef81f3..f764bc28 100644 --- a/parsing/g_natsyntax.ml +++ b/parsing/g_natsyntax.ml @@ -6,112 +6,21 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_natsyntax.ml,v 1.19.2.2 2004/09/08 13:47:51 herbelin Exp $ *) +(* $Id: g_natsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *) -(* This file to allow writing (3) for (S (S (S O))) - and still write (S y) for (S y) *) +(* This file defines the printer for natural numbers in [nat] *) +(*i*) open Pcoq open Pp open Util open Names -open Coqast -open Ast open Coqlib -open Termast -open Extend - -let ast_O = ast_of_ref glob_O -let ast_S = ast_of_ref glob_S - -(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) -let nat_of_int n dloc = - let ast_O = set_loc dloc ast_O in - let ast_S = set_loc dloc ast_S in - let rec mk_nat n = - if n <= 0 then - ast_O - else - Node(dloc,"APPLIST", [ast_S; mk_nat (n-1)]) - in - mk_nat n - -let pat_nat_of_int n dloc = - let ast_O = set_loc dloc ast_O in - let ast_S = set_loc dloc ast_S in - let rec mk_nat n = - if n <= 0 then - ast_O - else - Node(dloc,"PATTCONSTRUCT", [ast_S; mk_nat (n-1)]) - in - mk_nat n - -let nat_of_string s dloc = - nat_of_int (int_of_string s) dloc - -let pat_nat_of_string s dloc = - pat_nat_of_int (int_of_string s) dloc - -exception Non_closed_number - -let rec int_of_nat_rec astS astO p = - match p with - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,astS) -> - (int_of_nat_rec astS astO a)+1 - | a when alpha_eq(a,astO) -> 1 - (***** YES, 1, non 0 ... to print the successor of p *) - | _ -> raise Non_closed_number - -let int_of_nat p = - try - Some (int_of_nat_rec ast_S ast_O p) - with - Non_closed_number -> None - -let pr_S a = hov 0 (str "S" ++ brk (1,1) ++ a) - -let rec pr_external_S std_pr = function - | Node (l,"APPLIST", [b; a]) when alpha_eq (b,ast_S) -> - str"(" ++ pr_S (pr_external_S std_pr a) ++ str")" - | p -> std_pr p - -(* Declare the primitive printer *) - -(* Prints not p, but the SUCCESSOR of p !!!!! *) -let nat_printer std_pr p = - match (int_of_nat p) with - | Some i -> str "(" ++ str (string_of_int i) ++ str ")" - | None -> str "(" ++ pr_S (pr_external_S std_pr p) ++ str ")" - -let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer) -(* -(* Declare the primitive parser *) - -let unat = create_univ_if_new "nat" - -let number = create_constr_entry unat "number" -let pat_number = create_constr_entry unat "pat_number" - -let _ = - Gram.extend number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action nat_of_string]] - -let _ = - Gram.extend pat_number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action pat_nat_of_string]] -*) - -(*i*) open Rawterm open Libnames -open Bignat +open Bigint open Coqlib -open Symbols +open Notation open Pp open Util open Names @@ -122,8 +31,7 @@ open Names (* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) let nat_of_int dloc n = - match n with - | POS n -> + if is_pos_or_zero n then begin if less_than (of_string "5000") n & Options.is_verbose () then begin warning ("You may experience stack overflow and segmentation fault\ \nwhile parsing numbers in nat greater than 5000"); @@ -132,30 +40,17 @@ let nat_of_int dloc n = let ref_O = RRef (dloc, glob_O) in let ref_S = RRef (dloc, glob_S) in let rec mk_nat acc n = - if is_nonzero n then + if n <> zero then mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) else acc in mk_nat ref_O n - | NEG n -> + end + else user_err_loc (dloc, "nat_of_int", str "Cannot interpret a negative number as a number of type nat") -let pat_nat_of_int dloc n name = - match n with - | POS n -> - let rec mk_nat n name = - if is_nonzero n then - PatCstr (dloc,path_of_S,[mk_nat (sub_1 n) Anonymous],name) - else - PatCstr (dloc,path_of_O,[],name) - in - mk_nat n name - | NEG n -> - user_err_loc (dloc, "pat_nat_of_int", - str "Unable to interpret a negative number in type nat") - (************************************************************************) (* Printing via scopes *) @@ -168,19 +63,7 @@ let rec int_of_nat = function let uninterp_nat p = try - Some (POS (int_of_nat p)) - with - Non_closed_number -> None - -let rec int_of_nat_pattern = function - | PatCstr (_,s,[a],_) when ConstructRef s = glob_S -> - add_1 (int_of_nat_pattern a) - | PatCstr (_,z,[],_) when ConstructRef z = glob_O -> zero - | _ -> raise Non_closed_number - -let uninterp_nat_pattern p = - try - Some (POS (int_of_nat_pattern p)) + Some (int_of_nat p) with Non_closed_number -> None @@ -188,42 +71,7 @@ let uninterp_nat_pattern p = (* Declare the primitive parsers and printers *) let _ = - Symbols.declare_numeral_interpreter "nat_scope" - (glob_nat,["Coq";"Init";"Datatypes"]) - (nat_of_int,Some pat_nat_of_int) - ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, None) - -(************************************************************************) -(* Old ast printing *) - -open Coqast -open Ast -open Termast - -let _ = if !Options.v7 then -let ast_O = ast_of_ref glob_O in -let ast_S = ast_of_ref glob_S in - -let rec int_of_nat = function - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,ast_S) -> (int_of_nat a) + 1 - | a when alpha_eq(a,ast_O) -> 0 - | _ -> raise Non_closed_number -in -(* Prints not p, but the SUCCESSOR of p !!!!! *) -let nat_printer_S p = - try - Some (int (int_of_nat p + 1)) - with - Non_closed_number -> None -in -let nat_printer_O _ = - Some (int 0) -in -(* Declare the primitive printers *) -let _ = - Esyntax.declare_primitive_printer "nat_printer_S" "nat_scope" nat_printer_S -in -let _ = - Esyntax.declare_primitive_printer "nat_printer_O" "nat_scope" nat_printer_O -in -() + Notation.declare_numeral_interpreter "nat_scope" + (nat_path,["Coq";"Init";"Datatypes"]) + nat_of_int + ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true) diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli index 1471aed2..174be771 100644 --- a/parsing/g_natsyntax.mli +++ b/parsing/g_natsyntax.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_natsyntax.mli,v 1.3.16.1 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_natsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Nice syntax for naturals. *) diff --git a/parsing/g_natsyntaxnew.mli b/parsing/g_natsyntaxnew.mli index 50d38133..97fb8791 100644 --- a/parsing/g_natsyntaxnew.mli +++ b/parsing/g_natsyntaxnew.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_natsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_natsyntaxnew.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Nice syntax for naturals. *) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index ce6d4e2f..d5ca5e0c 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -6,133 +6,89 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_prim.ml4,v 1.22.2.2 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_prim.ml4 7922 2006-01-23 19:11:11Z herbelin $ i*) -open Coqast open Pcoq open Names open Libnames open Topconstr -open Prim -let _ = reset_all_grammars() +let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] +let _ = List.iter (fun s -> Lexer.add_token("",s)) prim_kw +open Prim open Nametab -let local_id_of_string = id_of_string -let local_make_dirpath = make_dirpath -let local_make_qualid l id' = make_qualid (local_make_dirpath l) id' -let local_make_short_qualid id = make_short_qualid id -let local_make_posint = int_of_string -let local_make_negint n = - int_of_string n -let local_make_path l a = encode_kn (local_make_dirpath l) a -let local_make_binding loc a b = - match a with - | Nvar (_,id) -> Slam(loc,Some id,b) - | Nmeta (_,s) -> Smetalam(loc,s,b) - | _ -> failwith "Slam expects a var or a metavar" -let local_append l id = l@[id] -GEXTEND Gram - GLOBAL: ident natural integer bigint string preident ast - astlist qualid reference dirpath identref name base_ident var hyp; +let local_make_qualid l id = make_qualid (make_dirpath l) id - (* Compatibility: Prim.var is a synonym of Prim.ident *) - var: - [ [ id = ident -> id ] ] - ; - hyp: - [ [ id = ident -> id ] ] - ; - metaident: - [ [ s = METAIDENT -> Nmeta (loc,s) ] ] - ; +GEXTEND Gram + GLOBAL: + bigint natural integer identref name ident var preident + fullyqualid qualid reference dirpath + ne_string string; preident: [ [ s = IDENT -> s ] ] ; - base_ident: - [ [ s = IDENT -> local_id_of_string s ] ] - ; - name: - [ [ IDENT "_" -> (loc, Anonymous) - | id = base_ident -> (loc, Name id) ] ] - ; - identref: - [ [ id = base_ident -> (loc,id) ] ] - ; ident: - [ [ id = base_ident -> id ] ] + [ [ s = IDENT -> id_of_string s ] ] ; - natural: - [ [ i = INT -> local_make_posint i ] ] + var: (* as identref, but interpret as a term identifier in ltac *) + [ [ id = ident -> (loc,id) ] ] ; - bigint: - [ [ i = INT -> Bignat.POS (Bignat.of_string i) - | "-"; i = INT -> Bignat.NEG (Bignat.of_string i) ] ] - ; - integer: - [ [ i = INT -> local_make_posint i - | "-"; i = INT -> local_make_negint i ] ] + identref: + [ [ id = ident -> (loc,id) ] ] ; field: - [ [ s = FIELD -> local_id_of_string s ] ] - ; - dirpath: - [ [ id = base_ident; l = LIST0 field -> - local_make_dirpath (local_append l id) ] ] + [ [ s = FIELD -> id_of_string s ] ] ; fields: - [ [ id = field; (l,id') = fields -> (local_append l id,id') + [ [ id = field; (l,id') = fields -> (l@[id],id') | id = field -> ([],id) ] ] ; + fullyqualid: + [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l) + | id = ident -> loc,[id] + ] ] + ; basequalid: - [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id' - | id = base_ident -> local_make_short_qualid id + [ [ id = ident; (l,id')=fields -> local_make_qualid (l@[id]) id' + | id = ident -> make_short_qualid id ] ] ; - qualid: - [ [ qid = basequalid -> loc, qid ] ] + name: + [ [ IDENT "_" -> (loc, Anonymous) + | id = ident -> (loc, Name id) ] ] ; reference: - [ [ id = base_ident; (l,id') = fields -> - Qualid (loc, local_make_qualid (local_append l id) id') - | id = base_ident -> Ident (loc,id) + [ [ id = ident; (l,id') = fields -> + Qualid (loc, local_make_qualid (l@[id]) id') + | id = ident -> Ident (loc,id) ] ] ; + qualid: + [ [ qid = basequalid -> loc, qid ] ] + ; + ne_string: + [ [ s = STRING -> + if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s + ] ] + ; + dirpath: + [ [ id = ident; l = LIST0 field -> + make_dirpath (l@[id]) ] ] + ; string: [ [ s = STRING -> s ] ] ; - astpath: - [ [ id = base_ident; (l,a) = fields -> - Path(loc, local_make_path (local_append l id) a) - | id = base_ident -> Nvar(loc, id) - ] ] + integer: + [ [ i = INT -> int_of_string i + | "-"; i = INT -> - int_of_string i ] ] ; - (* ast *) - ast: - [ [ id = metaident -> id - | p = astpath -> p - | s = INT -> Num(loc, local_make_posint s) - | s = STRING -> Str(loc, s) - | "{"; s = METAIDENT; "}" -> Id(loc,s) - | "("; nname = IDENT; l = LIST0 ast; ")" -> Node(loc,nname,l) - | "("; METAIDENT "$LIST"; id = metaident; ")" -> Node(loc,"$LIST",[id]) - | "("; METAIDENT "$STR"; id = metaident; ")" -> Node(loc,"$STR",[id]) - | "("; METAIDENT "$VAR"; id = metaident; ")" -> Node(loc,"$VAR",[id]) - | "("; METAIDENT "$ID"; id = metaident; ")" -> Node(loc,"$ID",[id]) - | "("; METAIDENT "$ABSTRACT"; l = LIST0 ast;")"->Node(loc,"$ABSTRACT",l) - | "("; METAIDENT "$PATH"; id = metaident; ")" -> Node(loc,"$PATH",[id]) - | "("; METAIDENT "$NUM"; id = metaident; ")" -> Node(loc,"$NUM",[id]) - | "["; "<>"; "]"; b = ast -> Slam(loc,None,b) - | "["; a = ast; "]"; b = ast -> local_make_binding loc a b - -(* - | "["; ido = astidoption; "]"; b = ast -> Slam(loc,ido,b) - | "["; id = METAIDENT; "]"; b = ast -> Smetalam(loc,id,b) -*) - | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ] - ; - astlist: - [ [ l = LIST0 ast -> l ] ] + natural: + [ [ i = INT -> int_of_string i ] ] + ; + bigint: (* Negative numbers are dealt with specially *) + [ [ i = INT -> (Bigint.of_string i) ] ] ; END diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4 deleted file mode 100644 index c1875634..00000000 --- a/parsing/g_primnew.ml4 +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: g_primnew.ml4,v 1.4.2.2 2004/07/16 19:30:39 herbelin Exp $ i*) - -open Coqast -open Pcoq -open Names -open Libnames -open Topconstr - -let _ = - if not !Options.v7 then - Pcoq.reset_all_grammars() -let _ = - if not !Options.v7 then - let f = Gram.Unsafe.clear_entry in - f Prim.bigint; - f Prim.qualid; - f Prim.ast; - f Prim.reference - -let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "<>"; "<<"; ">>"; "'"] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) prim_kw - -open Prim - -open Nametab -let local_id_of_string = id_of_string -let local_make_dirpath = make_dirpath -let local_make_qualid l id' = make_qualid (local_make_dirpath l) id' -let local_make_short_qualid id = make_short_qualid id -let local_make_posint = int_of_string -let local_make_negint n = - int_of_string n -let local_make_path l a = encode_kn (local_make_dirpath l) a -let local_make_binding loc a b = - match a with - | Nvar (_,id) -> Slam(loc,Some id,b) - | Nmeta (_,s) -> Smetalam(loc,s,b) - | _ -> failwith "Slam expects a var or a metavar" -let local_append l id = l@[id] - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: bigint qualid reference ne_string; - field: - [ [ s = FIELD -> local_id_of_string s ] ] - ; - fields: - [ [ id = field; (l,id') = fields -> (local_append l id,id') - | id = field -> ([],id) - ] ] - ; - basequalid: - [ [ id = base_ident; (l,id')=fields -> - local_make_qualid (local_append l id) id' - | id = base_ident -> local_make_short_qualid id - ] ] - ; - reference: - [ [ id = base_ident; (l,id') = fields -> - Qualid (loc, local_make_qualid (local_append l id) id') - | id = base_ident -> Ident (loc,id) - ] ] - ; - qualid: - [ [ qid = basequalid -> loc, qid ] ] - ; - ne_string: - [ [ s = STRING -> - if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s - ] ] - ; - bigint: (* Negative numbers are dealt with specially *) - [ [ i = INT -> Bignat.POS (Bignat.of_string i) ] ] - ; -END diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 5262b785..886b33e2 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_proofs.ml4,v 1.33.2.1 2004/07/16 19:30:39 herbelin Exp $ *) +(* $Id: g_proofs.ml4 7936 2006-01-28 18:36:54Z herbelin $ *) open Pcoq open Pp @@ -18,10 +18,9 @@ open Vernacexpr open Prim open Constr -let thm_token = Gram.Entry.create "vernac:thm_token" +let thm_token = G_vernac.thm_token (* Proof commands *) -if !Options.v7 then GEXTEND Gram GLOBAL: command; @@ -35,27 +34,29 @@ GEXTEND Gram | ":"; l = LIST1 IDENT -> l ] ] ; command: - [ [ IDENT "Goal"; c = Constr.constr -> VernacGoal c - | "Proof" -> VernacProof (Tacexpr.TacId "") - | "Proof"; "with"; ta = tactic -> VernacProof ta + [ [ IDENT "Goal"; c = lconstr -> VernacGoal c + | IDENT "Proof" -> VernacProof (Tacexpr.TacId []) + | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll | IDENT "Abort"; id = identref -> VernacAbort (Some id) + | IDENT "Existential"; n = natural; c = constr_body -> + VernacSolveExistential (n,c) | IDENT "Admitted" -> VernacEndProof Admitted - | "Qed" -> VernacEndProof (Proved (true,None)) + | IDENT "Qed" -> VernacEndProof (Proved (true,None)) | IDENT "Save" -> VernacEndProof (Proved (true,None)) - | IDENT "Defined" -> VernacEndProof (Proved (false,None)) - | IDENT "Defined"; id=identref -> - VernacEndProof (Proved (false,Some (id,None))) | IDENT "Save"; tok = thm_token; id = identref -> VernacEndProof (Proved (true,Some (id,Some tok))) | IDENT "Save"; id = identref -> VernacEndProof (Proved (true,Some (id,None))) + | IDENT "Defined" -> VernacEndProof (Proved (false,None)) + | IDENT "Defined"; id=identref -> + VernacEndProof (Proved (false,Some (id,None))) | IDENT "Suspend" -> VernacSuspend | IDENT "Resume" -> VernacResume None | IDENT "Resume"; id = identref -> VernacResume (Some id) | IDENT "Restart" -> VernacRestart - | "Proof"; c = Constr.constr -> VernacExactProof c + | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n | IDENT "Focus" -> VernacFocus None @@ -63,20 +64,20 @@ GEXTEND Gram | IDENT "Unfocus" -> VernacUnfocus | IDENT "Show" -> VernacShow (ShowGoal None) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) - | IDENT "Show"; IDENT "Implicits"; n = natural -> - VernacShow (ShowGoalImplicitly (Some n)) - | IDENT "Show"; IDENT "Implicits" -> VernacShow (ShowGoalImplicitly None) + | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> + VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames - | IDENT "Show"; "Proof" -> VernacShow ShowProof + | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) - | IDENT "Explain"; "Proof"; l = LIST0 integer -> + | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id) + | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer -> VernacShow (ExplainProof l) - | IDENT "Explain"; "Proof"; IDENT "Tree"; l = LIST0 integer -> + | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> VernacShow (ExplainTree l) | IDENT "Go"; n = natural -> VernacGo (GoTo n) | IDENT "Go"; IDENT "top" -> VernacGo GoTop @@ -84,26 +85,13 @@ GEXTEND Gram | IDENT "Go"; IDENT "next" -> VernacGo GoNext | IDENT "Guarded" -> VernacCheckGuard (* Hints for Auto and EAuto *) - - | IDENT "HintDestruct"; - local = locality; - dloc = destruct_location; - id = base_ident; - hyptyp = Constr.constr_pattern; - pri = natural; - "["; tac = tactic; "]" -> - VernacHints(local,[],HintsDestruct (id,pri,dloc,hyptyp,tac)) - - | IDENT "Hint"; local = locality; hintname = base_ident; - dbnames = opt_hintbases; ":="; h = hint - -> VernacHints (local,dbnames, h hintname) - - | IDENT "Hints"; local = locality; - (dbnames,h) = hints -> VernacHints (local,dbnames, h) + | IDENT "Hint"; local = locality; h = hint; + dbnames = opt_hintbases -> + VernacHints (local,dbnames, h) (*This entry is not commented, only for debug*) - | IDENT "PrintConstr"; c = Constr.constr -> + | IDENT "PrintConstr"; c = constr -> VernacExtend ("PrintConstr", [Genarg.in_gen Genarg.rawwit_constr c]) ] ]; @@ -112,24 +100,23 @@ GEXTEND Gram [ [ IDENT "Local" -> true | -> false ] ] ; hint: - [ [ IDENT "Resolve"; c = Constr.constr -> fun name -> HintsResolve [Some name, c] - | IDENT "Immediate"; c = Constr.constr -> fun name -> HintsImmediate [Some name, c] - | IDENT "Unfold"; qid = global -> fun name -> HintsUnfold [Some name,qid] - | IDENT "Constructors"; c = global -> fun n -> - HintsConstructors (Some n,[c]) - | IDENT "Extern"; n = natural; c = Constr.constr ; tac = tactic -> - fun name -> HintsExtern (Some name,n,c,tac) ] ] - ; - hints: - [ [ IDENT "Resolve"; l = LIST1 global; dbnames = opt_hintbases -> - (dbnames, - HintsResolve - (List.map (fun qid -> (None, CAppExpl(loc,(None,qid),[]))) l)) - | IDENT "Immediate"; l = LIST1 global; dbnames = opt_hintbases -> - (dbnames, - HintsImmediate - (List.map (fun qid-> (None, CAppExpl (loc,(None,qid),[]))) l)) - | IDENT "Unfold"; l = LIST1 global; dbnames = opt_hintbases -> - (dbnames, HintsUnfold (List.map (fun qid -> (None,qid)) l)) ] ] + [ [ IDENT "Resolve"; lc = LIST1 constr -> HintsResolve lc + | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc + | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid + | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc + | IDENT "Extern"; n = natural; c = constr_pattern ; "=>"; + tac = tactic -> + HintsExtern (n,c,tac) + | IDENT "Destruct"; + id = ident; ":="; + pri = natural; + dloc = destruct_location; + hyptyp = constr_pattern; + "=>"; tac = tactic -> + HintsDestruct(id,pri,dloc,hyptyp,tac) ] ] ; - END + constr_body: + [ [ ":="; c = lconstr -> c + | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,Term.DEFAULTcast,t) ] ] + ; +END diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4 deleted file mode 100644 index 04bf7a8b..00000000 --- a/parsing/g_proofsnew.ml4 +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_proofsnew.ml4,v 1.9.2.1 2004/07/16 19:30:39 herbelin Exp $ *) - -open Pcoq -open Pp -open Tactic -open Util -open Vernac_ -open Topconstr -open Vernacexpr -open Prim -open Constr - -let thm_token = G_vernacnew.thm_token - -(* Proof commands *) -if not !Options.v7 then -GEXTEND Gram - GLOBAL: command; - - destruct_location : - [ [ IDENT "Conclusion" -> Tacexpr.ConclLocation () - | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis" - -> Tacexpr.HypLocation discard ] ] - ; - opt_hintbases: - [ [ -> [] - | ":"; l = LIST1 IDENT -> l ] ] - ; - command: - [ [ IDENT "Goal"; c = Constr.lconstr -> VernacGoal c - | IDENT "Proof" -> VernacNop - | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta - | IDENT "Abort" -> VernacAbort None - | IDENT "Abort"; IDENT "All" -> VernacAbortAll - | IDENT "Abort"; id = identref -> VernacAbort (Some id) - | IDENT "Existential"; n = natural; c = constr_body -> - VernacSolveExistential (n,c) - | IDENT "Admitted" -> VernacEndProof Admitted - | IDENT "Qed" -> VernacEndProof (Proved (true,None)) - | IDENT "Save" -> VernacEndProof (Proved (true,None)) - | IDENT "Save"; tok = thm_token; id = identref -> - VernacEndProof (Proved (true,Some (id,Some tok))) - | IDENT "Save"; id = identref -> - VernacEndProof (Proved (true,Some (id,None))) - | IDENT "Defined" -> VernacEndProof (Proved (false,None)) - | IDENT "Defined"; id=identref -> - VernacEndProof (Proved (false,Some (id,None))) - | IDENT "Suspend" -> VernacSuspend - | IDENT "Resume" -> VernacResume None - | IDENT "Resume"; id = identref -> VernacResume (Some id) - | IDENT "Restart" -> VernacRestart - | IDENT "Proof"; c = Constr.lconstr -> VernacExactProof c - | IDENT "Undo" -> VernacUndo 1 - | IDENT "Undo"; n = natural -> VernacUndo n - | IDENT "Focus" -> VernacFocus None - | IDENT "Focus"; n = natural -> VernacFocus (Some n) - | IDENT "Unfocus" -> VernacUnfocus - | IDENT "Show" -> VernacShow (ShowGoal None) - | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) - | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> - VernacShow (ShowGoalImplicitly n) - | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode - | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript - | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials - | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree - | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames - | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof - | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) - | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) - | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer -> - VernacShow (ExplainProof l) - | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> - VernacShow (ExplainTree l) - | IDENT "Go"; n = natural -> VernacGo (GoTo n) - | IDENT "Go"; IDENT "top" -> VernacGo GoTop - | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev - | IDENT "Go"; IDENT "next" -> VernacGo GoNext - | IDENT "Guarded" -> VernacCheckGuard -(* Hints for Auto and EAuto *) - | IDENT "Hint"; local = locality; h = hint; - dbnames = opt_hintbases -> - VernacHints (local,dbnames, h) - - -(*This entry is not commented, only for debug*) - | IDENT "PrintConstr"; c = Constr.constr -> - VernacExtend ("PrintConstr", - [Genarg.in_gen Genarg.rawwit_constr c]) - ] ]; - - locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; - hint: - [ [ IDENT "Resolve"; lc = LIST1 Constr.constr -> - HintsResolve (List.map (fun c -> (None, c)) lc) - | IDENT "Immediate"; lc = LIST1 Constr.constr -> - HintsImmediate (List.map (fun c -> (None,c)) lc) - | IDENT "Unfold"; lqid = LIST1 global -> - HintsUnfold (List.map (fun g -> (None,g)) lqid) - | IDENT "Constructors"; lc = LIST1 global -> - HintsConstructors (None,lc) - | IDENT "Extern"; n = natural; c = Constr.constr_pattern ; "=>"; - tac = tactic -> - HintsExtern (None,n,c,tac) - | IDENT"Destruct"; - id = base_ident; ":="; - pri = natural; - dloc = destruct_location; - hyptyp = Constr.constr_pattern; - "=>"; tac = tactic -> - HintsDestruct(id,pri,dloc,hyptyp,tac) ] ] - ; - constr_body: - [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,t) ] ] - ; -END diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml index 8f5aad33..45647903 100644 --- a/parsing/g_rsyntax.ml +++ b/parsing/g_rsyntax.ml @@ -6,215 +6,47 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Coqast -open Ast open Pp open Util open Names open Pcoq -open Extend open Topconstr open Libnames -(**********************************************************************) -(* Parsing with Grammar *) -(**********************************************************************) - -let get_r_sign loc = - let mkid id = - mkRefC (Qualid (loc,Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "R0"), - mkid (id_of_string "R1"), - mkid (id_of_string "Rplus"), - mkid (id_of_string "Rmult"), - mkid (id_of_string "NRplus"), - mkid (id_of_string "NRmult"))) - -let get_r_sign_ast loc = - let mkid id = - Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "R0"), - mkid (id_of_string "R1"), - mkid (id_of_string "Rplus"), - mkid (id_of_string "Rmult"), - mkid (id_of_string "NRplus"), - mkid (id_of_string "NRmult"))) - -(* We have the following interpretation: - [| 0 |] = 0 - [| 1 |] = 1 - [| 2 |] = 1 + 1 - [| 3 |] = 1 + (1 + 1) - [| 2n |] = 2 * [| n |] for n >= 2 - [| 2n+1 |] = 1 + 2 * [| n |] for n >= 2 - [| -n |] = - [| n |] for n >= 0 -*) - -let int_decomp n = -let div2 k = -let x = k mod 2 in -let y = k - x in (x,y/2) in -let rec list_ch m = -if m< 2 then [m] -else let (x1,x2) = div2 m in x1::(list_ch x2) -in list_ch n - -let _ = if !Options.v7 then -let r_of_int n dloc = - let (a0,a1,plus,mult,_,_) = get_r_sign dloc in - let list_ch = int_decomp n in - let a2 = mkAppC (plus, [a1; a1]) in - let rec mk_r l = - match l with - | [] -> failwith "Error r_of_int" - | [a] -> if a=1 then a1 else a0 - | [a;b] -> if a==1 then mkAppC (plus, [a1; a2]) else a2 - | a::l' -> if a=1 then mkAppC (plus, [a1; mkAppC (mult, [a2; mk_r l'])]) else mkAppC (mult, [a2; mk_r l']) - in mk_r list_ch -in -let r_of_string s dloc = - r_of_int (int_of_string s) dloc -in -let rsyntax_create name = - let e = - Pcoq.create_constr_entry (Pcoq.get_univ "rnatural") name in - Pcoq.Gram.Unsafe.clear_entry e; - e -in -let rnumber = rsyntax_create "rnumber" -in -let _ = - Gram.extend rnumber None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action r_of_string]] -in () - -(**********************************************************************) -(* Old ast printing *) -(**********************************************************************) - exception Non_closed_number -let _ = if !Options.v7 then -let int_of_r p = - let (a0,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - let rec int_of_r_rec p = - match p with - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) & alpha_eq(c,a1) -> 2 - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) -> - (match c with - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,mult) -> 1 + int_of_r_rec c - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> 3 - | _ -> raise Non_closed_number) - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,mult) -> - (match a with - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> - (match c with - | g when alpha_eq(g,a1) -> raise Non_closed_number - | g when alpha_eq(g,a0) -> raise Non_closed_number - | _ -> 2 * int_of_r_rec c) - | _ -> raise Non_closed_number) - | a when alpha_eq(a,a0) -> 0 - | a when alpha_eq(a,a1) -> 1 - | _ -> raise Non_closed_number in - try - Some (int_of_r_rec p) - with - Non_closed_number -> None -in -let replace_plus p = - let (_,_,_,_,astnrplus,_) = get_r_sign_ast dummy_loc in - ope ("REXPR",[ope("APPLIST",[astnrplus;p])]) -in -let replace_mult p = - let (_,_,_,_,_,astnrmult) = get_r_sign_ast dummy_loc in - ope ("REXPR",[ope("APPLIST",[astnrmult;p])]) -in -let rec r_printer_odd std_pr p = - let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[plus;a1;p]))) with - | Some i -> str (string_of_int i) - | None -> std_pr (replace_plus p) -in -let rec r_printer_odd_outside std_pr p = - let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[plus;a1;p]))) with - | Some i -> str"``" ++ str (string_of_int i) ++ str"``" - | None -> std_pr (replace_plus p) -in -let rec r_printer_even std_pr p = - let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with - | Some i -> str (string_of_int i) - | None -> std_pr (replace_mult p) -in -let rec r_printer_even_outside std_pr p = - let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with - | Some i -> str"``" ++ str (string_of_int i) ++ str"``" - | None -> std_pr (replace_mult p) -in -let _ = Esyntax.Ppprim.add ("r_printer_odd", r_printer_odd) in -let _ = Esyntax.Ppprim.add ("r_printer_odd_outside", r_printer_odd_outside) in -let _ = Esyntax.Ppprim.add ("r_printer_even", r_printer_even) in -let _ = Esyntax.Ppprim.add ("r_printer_even_outside", r_printer_even_outside) -in () - (**********************************************************************) (* Parsing R via scopes *) (**********************************************************************) open Libnames open Rawterm -open Bignat +open Bigint let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] +let make_path dir id = Libnames.make_path dir (id_of_string id) + +let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) -let make_path dir id = Libnames.encode_kn dir (id_of_string id) +let make_path dir id = Libnames.encode_con dir (id_of_string id) -let glob_R = ConstRef (make_path rdefinitions "R") +let r_kn = make_path rdefinitions "R" +let glob_R = ConstRef r_kn let glob_R1 = ConstRef (make_path rdefinitions "R1") let glob_R0 = ConstRef (make_path rdefinitions "R0") let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") -(* V7 *) -let r_of_posint dloc n = - let ref_R0 = RRef (dloc, glob_R0) in - let ref_R1 = RRef (dloc, glob_R1) in - let ref_Rplus = RRef (dloc, glob_Rplus) in - let ref_Rmult = RRef (dloc, glob_Rmult) in - let a2 = RApp(dloc, ref_Rplus, [ref_R1; ref_R1]) in - let list_ch = int_decomp n in - let rec mk_r l = - match l with - | [] -> failwith "Error r_of_posint" - | [a] -> if a=1 then ref_R1 else ref_R0 - | a::[b] -> if a==1 then RApp (dloc, ref_Rplus, [ref_R1; a2]) else a2 - | a::l' -> if a=1 then RApp (dloc, ref_Rplus, [ref_R1; RApp (dloc, ref_Rmult, [a2; mk_r l'])]) else RApp (dloc, ref_Rmult, [a2; mk_r l']) - in mk_r list_ch - -(* int_of_string o bigint_to_string : temporary hack ... *) -(* utiliser les bigint de caml ? *) -let r_of_int2 dloc z = - match z with - | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (int_of_string (bigint_to_string (POS n)))]) - | POS n -> r_of_posint dloc (int_of_string (bigint_to_string z)) - -(* V8 *) let two = mult_2 one let three = add_1 two let four = mult_2 two (* Unary representation of strictly positive numbers *) let rec small_r dloc n = - if is_one n then RRef (dloc, glob_R1) + if equal one n then RRef (dloc, glob_R1) else RApp(dloc,RRef (dloc,glob_Rplus), [RRef (dloc, glob_R1);small_r dloc (sub_1 n)]) @@ -227,12 +59,13 @@ let r_of_posint dloc n = let (q,r) = div2_with_rest n in let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in - if is_nonzero n then r_of_pos n else RRef(dloc,glob_R0) + if n <> zero then r_of_pos n else RRef(dloc,glob_R0) let r_of_int dloc z = - match z with - | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc n]) - | POS n -> r_of_posint dloc n + if is_strictly_neg z then + RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + else + r_of_posint dloc z (**********************************************************************) (* Printing R via scopes *) @@ -268,8 +101,11 @@ in bignat_of_r let bigint_of_r = function - | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> NEG (bignat_of_r a) - | a -> POS (bignat_of_r a) + | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> + let n = bignat_of_r a in + if n = zero then raise Non_closed_number; + neg n + | a -> bignat_of_r a let uninterp_r p = try @@ -277,56 +113,11 @@ let uninterp_r p = with Non_closed_number -> None -let _ = Symbols.declare_numeral_interpreter "R_scope" - (glob_R,["Coq";"Reals";"Rdefinitions"]) - ((if !Options.v7 then r_of_int2 else r_of_int),None) +let _ = Notation.declare_numeral_interpreter "R_scope" + (r_path,["Coq";"Reals";"Rdefinitions"]) + r_of_int ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0); - RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);RRef(dummy_loc,glob_R1)], + RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult); + RRef(dummy_loc,glob_R1)], uninterp_r, - None) - -(************************************************************************) -(* Old ast printers via scope *) - -let _ = if !Options.v7 then -let bignat_of_pos p = - let (_,one,plus,_,_,_) = get_r_sign_ast dummy_loc in - let rec transl = function - | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one) - -> add_1(transl a) - | a when alpha_eq(a,one) -> Bignat.one - | _ -> raise Non_closed_number - in transl p -in -let bignat_option_of_pos p = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None -in -let r_printer_Rplus1 p = - match bignat_option_of_pos p with - | Some n -> Some (str (Bignat.to_string (add_1 n))) - | None -> None -in -let r_printer_Ropp p = - match bignat_option_of_pos p with - | Some n -> Some (str "-" ++ str (Bignat.to_string n)) - | None -> None -in -let r_printer_R1 _ = - Some (int 1) -in -let r_printer_R0 _ = - Some (int 0) -in -(* Declare pretty-printers for integers *) -let _ = - Esyntax.declare_primitive_printer "r_printer_Ropp" "R_scope" (r_printer_Ropp) -in let _ = - Esyntax.declare_primitive_printer "r_printer_Rplus1" "R_scope" (r_printer_Rplus1) -in let _ = - Esyntax.declare_primitive_printer "r_printer_R1" "R_scope" (r_printer_R1) -in let _ = - Esyntax.declare_primitive_printer "r_printer_R0" "R_scope" r_printer_R0 -in () + false) diff --git a/parsing/g_string_syntax.ml b/parsing/g_string_syntax.ml new file mode 100644 index 00000000..6d879fb2 --- /dev/null +++ b/parsing/g_string_syntax.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +open Pp +open Util +open Names +open Pcoq +open Libnames +open Topconstr +open G_ascii_syntax +open Rawterm +open Coqlib + +exception Non_closed_string + +(* make a string term from the string s *) + +let string_module = ["Coq";"Strings";"String"] + +let string_path = make_path string_module "string" + +let string_kn = make_kn string_module "string" +let static_glob_EmptyString = ConstructRef ((string_kn,0),1) +let static_glob_String = ConstructRef ((string_kn,0),2) + +let make_reference id = find_reference "String interpretation" string_module id +let glob_String = lazy (make_reference "String") +let glob_EmptyString = lazy (make_reference "EmptyString") + +open Lazy + +let interp_string dloc s = + let le = String.length s in + let rec aux n = + if n = le then RRef (dloc, force glob_EmptyString) else + RApp (dloc,RRef (dloc, force glob_String), + [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) + in aux 0 + +let uninterp_string r = + try + let b = Buffer.create 16 in + let rec aux = function + | RApp (_,RRef (_,k),[a;s]) when k = force glob_String -> + (match uninterp_ascii a with + | Some c -> Buffer.add_char b (Char.chr c); aux s + | _ -> raise Non_closed_string) + | RRef (_,z) when z = force glob_EmptyString -> + Some (Buffer.contents b) + | _ -> + raise Non_closed_string + in aux r + with + Non_closed_string -> None + +let _ = + Notation.declare_string_interpreter "string_scope" + (string_path,["Coq";"Strings";"String"]) + interp_string + ([RRef (dummy_loc,static_glob_String); + RRef (dummy_loc,static_glob_EmptyString)], + uninterp_string, true) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index fd64defc..1974d8bc 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -6,75 +6,124 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_tactic.ml4,v 1.83.2.5 2005/05/15 12:47:04 herbelin Exp $ *) +(* $Id: g_tactic.ml4 8651 2006-03-21 21:54:43Z jforest $ *) open Pp -open Ast open Pcoq open Util open Tacexpr open Rawterm open Genarg +open Topconstr + +let compute = Cbv all_flags + +let tactic_kw = [ "->"; "<-" ] +let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let lpar_id_coloneq = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",s)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string s + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* idem for (x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + Gram.Entry.of_parser "test_lpar_idnum_coloneq" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; (("IDENT"|"INT"),_)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* idem for (x:t) *) +let lpar_id_colon = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",id)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string id + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +let guess_lpar_ipat s strm = + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("",("("|"["))] -> () + | [_; ("IDENT",_)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", s')] when s = s' -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure + +let guess_lpar_coloneq = + Gram.Entry.of_parser "guess_lpar_coloneq" (guess_lpar_ipat ":=") + +let guess_lpar_colon = + Gram.Entry.of_parser "guess_lpar_colon" (guess_lpar_ipat ":") + open Constr open Prim open Tactic -let tactic_kw = - [ "using"; "Orelse"; "Proof"; "Qed"; "And"; "()"; "|-" ] -let _ = - if !Options.v7 then - List.iter (fun s -> Lexer.add_token ("",s)) tactic_kw +let mk_fix_tac (loc,id,bl,ann,ty) = + let n = + match bl,ann with + [([_],_)], None -> 1 + | _, Some x -> + let ids = List.map snd (List.flatten (List.map fst bl)) in + (try list_index (snd x) ids + with Not_found -> error "no such fix variable") + | _ -> error "cannot guess decreasing argument of fix" in + (id,n,CProdN(loc,bl,ty)) -(* Functions overloaded by quotifier *) +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = option_app (fun (aloc,_) -> + Util.user_err_loc + (aloc,"Constr:mk_cofix_tac", + Pp.str"Annotation forbidden in cofix expression")) ann in + (id,CProdN(loc,bl,ty)) +(* Functions overloaded by quotifier *) let induction_arg_of_constr c = - try ElimOnIdent (Topconstr.constr_loc c,snd (coerce_to_id c)) + try ElimOnIdent (constr_loc c,snd(coerce_to_id c)) with _ -> ElimOnConstr c -let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] - -let error_oldelim _ = error "OldElim no longer supported" - -let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2) - (* Auxiliary grammar rules *) -if !Options.v7 then GEXTEND Gram - GLOBAL: simple_tactic constrarg bindings constr_with_bindings - quantified_hypothesis red_expr int_or_var castedopenconstr open_constr + GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis + bindings red_expr int_or_var open_constr casted_open_constr simple_intropattern; int_or_var: [ [ n = integer -> Genarg.ArgArg n | id = identref -> Genarg.ArgVar id ] ] ; - autoarg_depth: - [ [ n = OPT natural -> n ] ] - ; - autoarg_adding: - [ [ IDENT "Adding" ; "["; l = LIST1 global; "]" -> l | -> [] ] ] - ; - autoarg_destructing: - [ [ IDENT "Destructing" -> true | -> false ] ] - ; - autoarg_usingTDB: - [ [ "Using"; "TDB" -> true | -> false ] ] - ; - autoargs: - [ [ a0 = autoarg_depth; l = autoarg_adding; - a2 = autoarg_destructing; a3 = autoarg_usingTDB -> (a0,l,a2,a3) ] ] - ; - (* Either an hypothesis or a ltac ref (variable or pattern patvar) *) - id_or_ltac_ref: - [ [ id = base_ident -> AI (loc,id) - | "?"; n = natural -> AI (loc,Pattern.patvar_of_int n) ] ] - ; - (* Either a global ref or a ltac ref (variable or pattern patvar) *) - global_or_ltac_ref: - [ [ qid = global -> qid - | "?"; n = natural -> Libnames.Ident (loc,Pattern.patvar_of_int n) ] ] - ; (* An identifier or a quotation meta-variable *) id_or_meta: [ [ id = identref -> AI id @@ -88,18 +137,10 @@ GEXTEND Gram | id = METAIDENT -> MetaId (loc,id) ] ] ; - constrarg: - [ [ IDENT "Inst"; id = identref; "["; c = constr; "]" -> - ConstrContext (id, c) - | IDENT "Eval"; rtc = Tactic.red_expr; "in"; c = constr -> - ConstrEval (rtc,c) - | IDENT "Check"; c = constr -> ConstrTypeOf c - | c = constr -> ConstrTerm c ] ] - ; open_constr: [ [ c = constr -> ((),c) ] ] - ; - castedopenconstr: + ; + casted_open_constr: [ [ c = constr -> ((),c) ] ] ; induction_arg: @@ -108,40 +149,45 @@ GEXTEND Gram ] ] ; quantified_hypothesis: - [ [ id = base_ident -> NamedHyp id + [ [ id = ident -> NamedHyp id | n = natural -> AnonHyp n ] ] ; conversion: - [ [ nl = LIST1 integer; c1 = constr; "with"; c2 = constr -> - (Some (nl,c1), c2) - | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2) - | c = constr -> (None, c) ] ] + [ [ c = constr -> (None, c) + | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2) + | c1 = constr; "at"; nl = LIST1 integer; "with"; c2 = constr -> + (Some (nl,c1), c2) ] ] + ; + occurrences: + [ [ "at"; nl = LIST1 integer -> nl + | -> [] ] ] ; pattern_occ: - [ [ nl = LIST0 integer; c = constr -> (nl,c) ] ] + [ [ c = constr; nl = occurrences -> (nl,c) ] ] + ; + unfold_occ: + [ [ c = global; nl = occurrences -> (nl,c) ] ] ; intropatterns: [ [ l = LIST0 simple_intropattern -> l ]] ; simple_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc - | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] - | IDENT "_" -> IntroWildcard - | id = base_ident -> IntroIdentifier id + | "("; tc = LIST0 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] + | "()" -> IntroOrAndPattern [[]] + | "_" -> IntroWildcard + | "?" -> IntroAnonymous + | id = ident -> IntroIdentifier id ] ] ; simple_binding: - [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c) - | n = natural; ":="; c = constr -> (loc, AnonHyp n, c) ] ] + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ] ; bindings: - [ [ c1 = constr; ":="; c2 = constr; bl = LIST0 simple_binding -> - ExplicitBindings - ((join_to_constr loc c2,NamedHyp (snd(coerce_to_id c1)), c2) :: bl) - | n = natural; ":="; c = constr; bl = LIST0 simple_binding -> - ExplicitBindings ((join_to_constr loc c,AnonHyp n, c) :: bl) - | c1 = constr; bl = LIST0 constr -> - ImplicitBindings (c1 :: bl) ] ] + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + ExplicitBindings bl + | bl = LIST1 constr -> ImplicitBindings bl ] ] ; constr_with_bindings: [ [ c = constr; l = with_bindings -> (c, l) ] ] @@ -149,222 +195,246 @@ GEXTEND Gram with_bindings: [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] ; - unfold_occ: - [ [ nl = LIST0 integer; c = global_or_ltac_ref -> (nl,c) ] ] - ; red_flag: - [ [ IDENT "Beta" -> FBeta - | IDENT "Delta" -> FDeltaBut [] - | IDENT "Iota" -> FIota - | IDENT "Zeta" -> FZeta - | IDENT "Delta"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FConst idl - | IDENT "Delta"; "-"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FDeltaBut idl + [ [ IDENT "beta" -> FBeta + | IDENT "delta" -> FDeltaBut [] + | IDENT "iota" -> FIota + | IDENT "zeta" -> FZeta + | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl + | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl ] ] ; red_tactic: - [ [ IDENT "Red" -> Red false - | IDENT "Hnf" -> Hnf - | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po - | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) - | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) - | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta]) - | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul - | IDENT "Fold"; cl = LIST1 constr -> Fold cl - | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl ] ] + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "compute" -> compute + | IDENT "vm_compute" -> CbvVm + | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul + | IDENT "fold"; cl = LIST1 constr -> Fold cl + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ] ; (* This is [red_tactic] including possible extensions *) red_expr: - [ [ IDENT "Red" -> Red false - | IDENT "Hnf" -> Hnf - | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po - | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) - | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) - | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta]) - | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul - | IDENT "Fold"; cl = LIST1 constr -> Fold cl - | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "compute" -> compute + | IDENT "vm_compute" -> CbvVm + | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul + | IDENT "fold"; cl = LIST1 constr -> Fold cl + | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl | s = IDENT -> ExtraRedExpr s ] ] ; hypident: - [ [ id = id_or_meta -> id,[],(InHyp,ref None) - | "("; "Type"; "of"; id = id_or_meta; ")" -> - id,[],(InHypTypeOnly,ref None) + [ [ id = id_or_meta -> + id,InHyp + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypTypeOnly + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypValueOnly ] ] ; + hypident_occ: + [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ] + ; clause: - [ [ "in"; idl = LIST1 hypident -> - {onhyps=Some idl;onconcl=false; concl_occs=[]} - | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ] + [ [ "in"; "*"; occs=occurrences -> + {onhyps=None;onconcl=true;concl_occs=occs} + | "in"; "*"; "|-"; (b,occs)=concl_occ -> + {onhyps=None; onconcl=b; concl_occs=occs} + | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ -> + {onhyps=Some hl; onconcl=b; concl_occs=occs} + | "in"; hl=LIST0 hypident_occ SEP"," -> + {onhyps=Some hl; onconcl=false; concl_occs=[]} + | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ] + ; + concl_occ: + [ [ "*"; occs = occurrences -> (true,occs) + | -> (false, []) ] ] ; simple_clause: [ [ "in"; idl = LIST1 id_or_meta -> idl | -> [] ] ] ; - pattern_occ_hyp_tail_list: - [ [ pl = pattern_occ_hyp_list -> pl - | -> {onhyps=Some[];onconcl=false; concl_occs=[]} ] ] - ; - pattern_occ_hyp_list: - [ [ nl = LIST1 natural; IDENT "Goal" -> - {onhyps=Some[];onconcl=true;concl_occs=nl} - | nl = LIST1 natural; id = id_or_meta; cls = pattern_occ_hyp_tail_list - -> {cls with - onhyps=option_app(fun l -> (id,nl,(InHyp,ref None))::l) - cls.onhyps} - | IDENT "Goal" -> {onhyps=Some[];onconcl=true;concl_occs=[]} - | id = id_or_meta; cls = pattern_occ_hyp_tail_list -> - {cls with - onhyps=option_app(fun l -> (id,[],(InHyp,ref None))::l) - cls.onhyps} ] ] - ; - clause_pattern: - [ [ "in"; p = pattern_occ_hyp_list -> p - | -> {onhyps=None; onconcl=true; concl_occs=[] } ] ] - ; fixdecl: - [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ] + [ [ "("; id = ident; bl=LIST0 Constr.binder; ann=fixannot; + ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ] ; - cofixdecl: - [ [ id = base_ident; ":"; c = constr -> (id,c) ] ] + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] ; hintbases: [ [ "with"; "*" -> None | "with"; l = LIST1 IDENT -> Some l | -> Some [] ] ] ; + auto_using: + [ [ "using"; l = LIST1 constr SEP "," -> l + | -> [] ] ] + ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; with_names: - [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] + [ [ "as"; ipat = simple_intropattern -> ipat | -> IntroAnonymous ] ] + ; + by_tactic: + [ [ IDENT "by"; tac = tactic -> TacComplete tac | -> TacId [] ] ] ; simple_tactic: [ [ (* Basic tactics *) - IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> + IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> TacIntrosUntil id - | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl - | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref -> + | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl + | IDENT "intro"; id = ident; IDENT "after"; id2 = identref -> TacIntroMove (Some id, Some id2) - | IDENT "Intro"; IDENT "after"; id2 = identref -> + | IDENT "intro"; IDENT "after"; id2 = identref -> TacIntroMove (None, Some id2) - | IDENT "Intro"; id = base_ident -> TacIntroMove (Some id,None) - | IDENT "Intro" -> TacIntroMove (None, None) + | IDENT "intro"; id = ident -> TacIntroMove (Some id, None) + | IDENT "intro" -> TacIntroMove (None, None) - | IDENT "Assumption" -> TacAssumption - | IDENT "Exact"; c = constr -> TacExact c + | IDENT "assumption" -> TacAssumption + | IDENT "exact"; c = constr -> TacExact c + | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c - | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl - | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator -> + | IDENT "apply"; cl = constr_with_bindings -> TacApply cl + | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> TacElim (cl,el) - | IDENT "OldElim"; c = constr -> - (* TacOldElim c *) error_oldelim () - | IDENT "ElimType"; c = constr -> TacElimType c - | IDENT "Case"; cl = constr_with_bindings -> TacCase cl - | IDENT "CaseType"; c = constr -> TacCaseType c - | IDENT "Fix"; n = natural -> TacFix (None,n) - | IDENT "Fix"; id = base_ident; n = natural -> TacFix (Some id,n) - | IDENT "Fix"; id = base_ident; n = natural; "with"; fd = LIST0 fixdecl -> - TacMutualFix (id,n,fd) - | IDENT "Cofix" -> TacCofix None - | IDENT "Cofix"; id = base_ident -> TacCofix (Some id) - | IDENT "Cofix"; id = base_ident; "with"; fd = LIST0 cofixdecl -> - TacMutualCofix (id,fd) - - | IDENT "Cut"; c = constr -> TacCut c - | IDENT "Assert"; c = constr -> TacTrueCut (Names.Anonymous,c) - | IDENT "Assert"; c = constr; ":"; t = constr -> - TacTrueCut (Names.Name (snd(coerce_to_id c)),t) - | IDENT "Assert"; c = constr; ":="; b = constr -> - TacForward (false,Names.Name (snd (coerce_to_id c)),b) - | IDENT "Pose"; c = constr; ":="; b = constr -> - TacForward (true,Names.Name (snd(coerce_to_id c)),b) - | IDENT "Pose"; b = constr -> TacForward (true,Names.Anonymous,b) - | IDENT "Generalize"; lc = LIST1 constr -> TacGeneralize lc - | IDENT "Generalize"; IDENT "Dependent"; c = constr -> TacGeneralizeDep c - | IDENT "LetTac"; (_,na) = name; ":="; c = constr; p = clause_pattern - -> TacLetTac (na,c,p) - | IDENT "Instantiate"; n = natural; c = constr; cls = clause -> - TacInstantiate (n,c,cls) - | IDENT "Specialize"; n = OPT natural; lcb = constr_with_bindings -> + | IDENT "elimtype"; c = constr -> TacElimType c + | IDENT "case"; cl = constr_with_bindings -> TacCase cl + | IDENT "casetype"; c = constr -> TacCaseType c + | "fix"; n = natural -> TacFix (None,n) + | "fix"; id = ident; n = natural -> TacFix (Some id,n) + | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> + TacMutualFix (id,n,List.map mk_fix_tac fd) + | "cofix" -> TacCofix None + | "cofix"; id = ident -> TacCofix (Some id) + | "cofix"; id = ident; "with"; fd = LIST1 fixdecl -> + TacMutualCofix (id,List.map mk_cofix_tac fd) + + | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" -> + TacLetTac (Names.Name id,b,nowhere) + | IDENT "pose"; b = constr -> + TacLetTac (Names.Anonymous,b,nowhere) + | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")"; p = clause -> + TacLetTac (Names.Name id,c,p) + | IDENT "set"; c = constr; p = clause -> + TacLetTac (Names.Anonymous,c,p) + + (* Begin compatibility *) + | IDENT "assert"; id = lpar_id_coloneq; c = lconstr; ")" -> + TacAssert (None,IntroIdentifier id,c) + | IDENT "assert"; id = lpar_id_colon; c = lconstr; ")"; tac=by_tactic -> + TacAssert (Some tac,IntroIdentifier id,c) + (* End compatibility *) + + | IDENT "assert"; c = constr; ipat = with_names; tac = by_tactic -> + TacAssert (Some tac,ipat,c) + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = with_names -> + TacAssert (None,ipat,c) + + | IDENT "cut"; c = constr -> TacCut c + | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc + | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c + (* | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")"; "in"; + hid = hypident -> + let (id,(hloc,_)) = hid in + TacInstantiate (n,c,HypLocation (id,hloc)) + | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")" -> + TacInstantiate (n,c,ConclLocation ()) *) + + | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings -> TacSpecialize (n,lcb) - | IDENT "LApply"; c = constr -> TacLApply c + | IDENT "lapply"; c = constr -> TacLApply c (* Derived basic tactics *) - | IDENT "Induction"; h = quantified_hypothesis -> TacSimpleInduction (h,ref []) - | IDENT "NewInduction"; c = induction_arg; el = OPT eliminator; - ids = with_names -> TacNewInduction (c,el,(ids,ref [])) - | IDENT "Double"; IDENT "Induction"; h1 = quantified_hypothesis; + | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> + TacSimpleInduction h + | IDENT "induction"; lc = LIST1 induction_arg; ids = with_names; + el = OPT eliminator -> TacNewInduction (lc,el,ids) + | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) - | IDENT "Destruct"; h = quantified_hypothesis -> TacSimpleDestruct h - | IDENT "NewDestruct"; c = induction_arg; el = OPT eliminator; - ids = with_names -> TacNewDestruct (c,el,(ids,ref [])) - | IDENT "Decompose"; IDENT "Record" ; c = constr -> TacDecomposeAnd c - | IDENT "Decompose"; IDENT "Sum"; c = constr -> TacDecomposeOr c - | IDENT "Decompose"; "["; l = LIST1 global_or_ltac_ref; "]"; c = constr + | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis -> + TacSimpleDestruct h + | IDENT "destruct"; lc = LIST1 induction_arg; ids = with_names; + el = OPT eliminator -> TacNewDestruct (lc,el,ids) + | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c + | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c + | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr -> TacDecompose (l,c) (* Automation tactic *) - | IDENT "Trivial"; db = hintbases -> TacTrivial db - | IDENT "Auto"; n = OPT int_or_var; db = hintbases -> TacAuto (n, db) - - | IDENT "AutoTDB"; n = OPT natural -> TacAutoTDB n - | IDENT "CDHyp"; id = identref -> TacDestructHyp (true,id) - | IDENT "DHyp"; id = identref -> TacDestructHyp (false,id) - | IDENT "DConcl" -> TacDestructConcl - | IDENT "SuperAuto"; l = autoargs -> TacSuperAuto l - | IDENT "Auto"; n = OPT int_or_var; IDENT "Decomp"; p = OPT natural -> + | IDENT "trivial"; lems = auto_using; db = hintbases -> + TacTrivial (lems,db) + | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAuto (n,lems,db) + +(* Obsolete since V8.0 + | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n + | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id) + | IDENT "dhyp"; id = identref -> TacDestructHyp (false,id) + | IDENT "dconcl" -> TacDestructConcl + | IDENT "superauto"; l = autoargs -> TacSuperAuto l +*) + | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural -> TacDAuto (n, p) (* Context management *) - | IDENT "Clear"; l = LIST1 id_or_ltac_ref -> TacClear l - | IDENT "ClearBody"; l = LIST1 id_or_ltac_ref -> TacClearBody l - | IDENT "Move"; id1 = id_or_ltac_ref; IDENT "after"; - id2 = id_or_ltac_ref -> TacMove (true,id1,id2) - | IDENT "Rename"; id1 = id_or_ltac_ref; IDENT "into"; - id2 = id_or_ltac_ref -> TacRename (id1,id2) + | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l) + | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l) + | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l + | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> + TacMove (true,id1,id2) + | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> + TacRename (id1,id2) (* Constructors *) - | IDENT "Left"; bl = with_bindings -> TacLeft bl - | IDENT "Right"; bl = with_bindings -> TacRight bl - | IDENT "Split"; bl = with_bindings -> TacSplit (false,bl) - | IDENT "Exists"; bl = bindings -> TacSplit (true,bl) - | IDENT "Exists" -> TacSplit (true,NoBindings) - | IDENT "Constructor"; n = num_or_meta; l = with_bindings -> + | IDENT "left"; bl = with_bindings -> TacLeft bl + | IDENT "right"; bl = with_bindings -> TacRight bl + | IDENT "split"; bl = with_bindings -> TacSplit (false,bl) + | "exists"; bl = bindings -> TacSplit (true,bl) + | "exists" -> TacSplit (true,NoBindings) + | IDENT "constructor"; n = num_or_meta; l = with_bindings -> TacConstructor (n,l) - | IDENT "Constructor"; t = OPT tactic -> TacAnyConstructor t + | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t (* Equivalence relations *) - | IDENT "Reflexivity" -> TacReflexivity - | IDENT "Symmetry"; cls = clause -> TacSymmetry cls - | IDENT "Transitivity"; c = constr -> TacTransitivity c + | IDENT "reflexivity" -> TacReflexivity + | IDENT "symmetry"; cls = clause -> TacSymmetry cls + | IDENT "transitivity"; c = constr -> TacTransitivity c (* Equality and inversion *) - | IDENT "Dependent"; k = - [ IDENT "Simple"; IDENT "Inversion" -> SimpleInversion - | IDENT "Inversion" -> FullInversion - | IDENT "Inversion_clear" -> FullInversionClear ]; + | IDENT "dependent"; k = + [ IDENT "simple"; IDENT "inversion" -> SimpleInversion + | IDENT "inversion" -> FullInversion + | IDENT "inversion_clear" -> FullInversionClear ]; hyp = quantified_hypothesis; ids = with_names; co = OPT ["with"; c = constr -> c] -> TacInversion (DepInversion (k,co,ids),hyp) - | IDENT "Simple"; IDENT "Inversion"; + | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) - | IDENT "Inversion"; + | IDENT "inversion"; hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) - | IDENT "Inversion_clear"; + | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) - | IDENT "Inversion"; hyp = quantified_hypothesis; + | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = simple_clause -> TacInversion (InversionUsing (c,cl), hyp) (* Conversion *) | r = red_tactic; cl = clause -> TacReduce (r, cl) (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) - | IDENT "Change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl) - + | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl) ] ] ; END;; diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4 deleted file mode 100644 index 5ffd2fd7..00000000 --- a/parsing/g_tacticnew.ml4 +++ /dev/null @@ -1,405 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_tacticnew.ml4,v 1.35.2.7 2005/05/15 12:47:05 herbelin Exp $ *) - -open Pp -open Ast -open Pcoq -open Util -open Tacexpr -open Rawterm -open Genarg - -let compute = Cbv all_flags - -let tactic_kw = - [ "->"; "<-" ] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) tactic_kw - -(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) -(* admissible notation "(x t)" *) -let lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" - (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",s)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; - Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* idem for (x:=t) and (1:=t) *) -let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" - (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; (("IDENT"|"INT"),_)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* idem for (x:t) *) -let lpar_id_colon = - Gram.Entry.of_parser "lpar_id_colon" - (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",id)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; - Names.id_of_string id - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -open Constr -open Prim -open Tactic - -let mk_fix_tac (loc,id,bl,ann,ty) = - let n = - match bl,ann with - [([_],_)], None -> 1 - | _, Some x -> - let ids = List.map snd (List.flatten (List.map fst bl)) in - (try list_index (snd x) ids - with Not_found -> error "no such fix variable") - | _ -> error "cannot guess decreasing argument of fix" in - (id,n,Topconstr.CProdN(loc,bl,ty)) - -let mk_cofix_tac (loc,id,bl,ann,ty) = - let _ = option_app (fun (aloc,_) -> - Util.user_err_loc - (aloc,"Constr:mk_cofix_tac", - Pp.str"Annotation forbidden in cofix expression")) ann in - (id,Topconstr.CProdN(loc,bl,ty)) - -(* Functions overloaded by quotifier *) -let induction_arg_of_constr c = - try ElimOnIdent (Topconstr.constr_loc c,snd(coerce_to_id c)) - with _ -> ElimOnConstr c - -let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] - -let error_oldelim _ = error "OldElim no longer supported" - -let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2) - -(* Auxiliary grammar rules *) - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr castedopenconstr - simple_intropattern; - - int_or_var: - [ [ n = integer -> Genarg.ArgArg n - | id = identref -> Genarg.ArgVar id ] ] - ; - (* An identifier or a quotation meta-variable *) - id_or_meta: - [ [ id = identref -> AI id - - (* This is used in quotations *) - | id = METAIDENT -> MetaId (loc,id) ] ] - ; - (* A number or a quotation meta-variable *) - num_or_meta: - [ [ n = integer -> AI n - | id = METAIDENT -> MetaId (loc,id) - ] ] - ; - open_constr: - [ [ c = constr -> ((),c) ] ] - ; - castedopenconstr: - [ [ c = constr -> ((),c) ] ] - ; - induction_arg: - [ [ n = natural -> ElimOnAnonHyp n - | c = constr -> induction_arg_of_constr c - ] ] - ; - quantified_hypothesis: - [ [ id = base_ident -> NamedHyp id - | n = natural -> AnonHyp n ] ] - ; - conversion: - [ [ c = constr -> (None, c) - | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2) - | c1 = constr; "at"; nl = LIST1 integer; "with"; c2 = constr -> - (Some (nl,c1), c2) ] ] - ; - occurrences: - [ [ "at"; nl = LIST1 integer -> nl - | -> [] ] ] - ; - pattern_occ: - [ [ c = constr; nl = occurrences -> (nl,c) ] ] - ; - unfold_occ: - [ [ c = global; nl = occurrences -> (nl,c) ] ] - ; - intropatterns: - [ [ l = LIST0 simple_intropattern -> l ]] - ; - simple_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc - | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] - | "_" -> IntroWildcard - | id = base_ident -> IntroIdentifier id - ] ] - ; - simple_binding: - [ [ "("; id = base_ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - ExplicitBindings bl - | bl = LIST1 constr -> ImplicitBindings bl ] ] - ; - constr_with_bindings: - [ [ c = constr; l = with_bindings -> (c, l) ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] - ; - red_flag: - [ [ IDENT "beta" -> FBeta - | IDENT "delta" -> FDeltaBut [] - | IDENT "iota" -> FIota - | IDENT "zeta" -> FZeta - | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl - | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl - ] ] - ; - red_tactic: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; po = OPT pattern_occ -> Simpl po - | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) - | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) - | IDENT "compute" -> compute - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ] - ; - (* This is [red_tactic] including possible extensions *) - red_expr: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; po = OPT pattern_occ -> Simpl po - | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) - | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) - | IDENT "compute" -> compute - | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl - | s = IDENT; OPT [ (* compat V8.0pl1 *) constr ] -> ExtraRedExpr s ] ] - ; - hypident: - [ [ id = id_or_meta -> id,(InHyp,ref None) - | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - id,(InHypTypeOnly,ref None) - | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - id,(InHypValueOnly,ref None) - ] ] - ; - hypident_occ: - [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ] - ; - clause: - [ [ "in"; "*"; occs=occurrences -> - {onhyps=None;onconcl=true;concl_occs=occs} - | "in"; "*"; "|-"; (b,occs)=concl_occ -> - {onhyps=None; onconcl=b; concl_occs=occs} - | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ -> - {onhyps=Some hl; onconcl=b; concl_occs=occs} - | "in"; hl=LIST0 hypident_occ SEP"," -> - {onhyps=Some hl; onconcl=false; concl_occs=[]} - | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ] - ; - concl_occ: - [ [ "*"; occs = occurrences -> (true,occs) - | -> (false, []) ] ] - ; - simple_clause: - [ [ "in"; idl = LIST1 id_or_meta -> idl - | -> [] ] ] - ; - fixdecl: - [ [ "("; id = base_ident; bl=LIST0 Constr.binder; ann=fixannot; - ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ] - ; - fixannot: - [ [ "{"; IDENT "struct"; id=name; "}" -> Some id - | -> None ] ] - ; - hintbases: - [ [ "with"; "*" -> None - | "with"; l = LIST1 IDENT -> Some l - | -> Some [] ] ] - ; - eliminator: - [ [ "using"; el = constr_with_bindings -> el ] ] - ; - with_names: - [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] - ; - simple_tactic: - [ [ - (* Basic tactics *) - IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> - TacIntrosUntil id - | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl - | IDENT "intro"; id = base_ident; IDENT "after"; id2 = identref -> - TacIntroMove (Some id, Some id2) - | IDENT "intro"; IDENT "after"; id2 = identref -> - TacIntroMove (None, Some id2) - | IDENT "intro"; id = base_ident -> TacIntroMove (Some id, None) - | IDENT "intro" -> TacIntroMove (None, None) - - | IDENT "assumption" -> TacAssumption - | IDENT "exact"; c = constr -> TacExact c - - | IDENT "apply"; cl = constr_with_bindings -> TacApply cl - | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> - TacElim (cl,el) - | IDENT "elimtype"; c = constr -> TacElimType c - | IDENT "case"; cl = constr_with_bindings -> TacCase cl - | IDENT "casetype"; c = constr -> TacCaseType c - | "fix"; n = natural -> TacFix (None,n) - | "fix"; id = base_ident; n = natural -> TacFix (Some id,n) - | "fix"; id = base_ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacMutualFix (id,n,List.map mk_fix_tac fd) - | "cofix" -> TacCofix None - | "cofix"; id = base_ident -> TacCofix (Some id) - | "cofix"; id = base_ident; "with"; fd = LIST1 fixdecl -> - TacMutualCofix (id,List.map mk_cofix_tac fd) - - | IDENT "cut"; c = constr -> TacCut c - | IDENT "assert"; id = lpar_id_colon; t = lconstr; ")" -> - TacTrueCut (Names.Name id,t) - | IDENT "assert"; id = lpar_id_coloneq; b = lconstr; ")" -> - TacForward (false,Names.Name id,b) - | IDENT "assert"; c = constr -> TacTrueCut (Names.Anonymous,c) - | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" -> - TacForward (true,Names.Name id,b) - | IDENT "pose"; b = constr -> TacForward (true,Names.Anonymous,b) - | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc - | IDENT "generalize"; IDENT "dependent"; c = constr -> - TacGeneralizeDep c - | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")"; - p = clause -> TacLetTac (Names.Name id,c,p) - | IDENT "set"; c = constr; p = clause -> - TacLetTac (Names.Anonymous,c,p) - | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")"; - cls = clause -> - TacInstantiate (n,c,cls) - - | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings -> - TacSpecialize (n,lcb) - | IDENT "lapply"; c = constr -> TacLApply c - - (* Derived basic tactics *) - | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> - TacSimpleInduction (h,ref []) - | IDENT "induction"; c = induction_arg; ids = with_names; - el = OPT eliminator -> TacNewInduction (c,el,(ids,ref [])) - | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; - h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) - | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis -> - TacSimpleDestruct h - | IDENT "destruct"; c = induction_arg; ids = with_names; - el = OPT eliminator -> TacNewDestruct (c,el,(ids,ref [])) - | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c - | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c - | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr - -> TacDecompose (l,c) - - (* Automation tactic *) - | IDENT "trivial"; db = hintbases -> TacTrivial db - | IDENT "auto"; n = OPT int_or_var; db = hintbases -> TacAuto (n, db) - -(* Obsolete since V8.0 - | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n - | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id) - | IDENT "dhyp"; id = identref -> TacDestructHyp (false,id) - | IDENT "dconcl" -> TacDestructConcl - | IDENT "superauto"; l = autoargs -> TacSuperAuto l -*) - | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural -> - TacDAuto (n, p) - - (* Context management *) - | IDENT "clear"; l = LIST1 id_or_meta -> TacClear l - | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l - | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> - TacMove (true,id1,id2) - | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> - TacRename (id1,id2) - - (* Constructors *) - | IDENT "left"; bl = with_bindings -> TacLeft bl - | IDENT "right"; bl = with_bindings -> TacRight bl - | IDENT "split"; bl = with_bindings -> TacSplit (false,bl) - | "exists"; bl = bindings -> TacSplit (true,bl) - | "exists" -> TacSplit (true,NoBindings) - | IDENT "constructor"; n = num_or_meta; l = with_bindings -> - TacConstructor (n,l) - | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t - - (* Equivalence relations *) - | IDENT "reflexivity" -> TacReflexivity - | IDENT "symmetry"; cls = clause -> TacSymmetry cls - | IDENT "transitivity"; c = constr -> TacTransitivity c - - (* Equality and inversion *) - | IDENT "dependent"; k = - [ IDENT "simple"; IDENT "inversion" -> SimpleInversion - | IDENT "inversion" -> FullInversion - | IDENT "inversion_clear" -> FullInversionClear ]; - hyp = quantified_hypothesis; - ids = with_names; co = OPT ["with"; c = constr -> c] -> - TacInversion (DepInversion (k,co,ids),hyp) - | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> - TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) - | IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> - TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) - | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> - TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) - | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = simple_clause -> - TacInversion (InversionUsing (c,cl), hyp) - - (* Conversion *) - | r = red_tactic; cl = clause -> TacReduce (r, cl) - (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) - | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl) - ] ] - ; -END;; diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 87183e18..18a424a8 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -6,35 +6,39 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_vernac.ml4,v 1.93.2.3 2004/10/12 10:11:28 herbelin Exp $ *) +(* $Id: g_vernac.ml4 8624 2006-03-13 17:38:17Z msozeau $ *) +(*i camlp4deps: "parsing/grammar.cma" i*) +open Pp +open Util open Names open Topconstr open Vernacexpr open Pcoq -open Pp open Tactic -open Util -open Constr -open Vernac_ -open Prim open Decl_kinds - open Genarg +open Extend +open Ppextend +open Goptions -let evar_constr loc = CHole loc +open Prim +open Constr +open Vernac_ +open Module -let class_rawexpr = G_basevernac.class_rawexpr -let thm_token = G_proofs.thm_token +let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] +let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) -let filter_com (b,e) = - let (b,e) = unloc (b,e) in - Pp.comments := List.filter (fun ((b',e'),s) -> b'<b || e'>e) !Pp.comments +let check_command = Gram.Entry.create "vernac:check_command" +let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" +let thm_token = Gram.Entry.create "vernac:thm_token" +let def_body = Gram.Entry.create "vernac:def_body" -if !Options.v7 then +let no_hook _ _ = () GEXTEND Gram GLOBAL: vernac gallina_ext; vernac: @@ -44,163 +48,121 @@ GEXTEND Gram | g = gallina_ext; "." -> g | c = command; "." -> c | c = syntax; "." -> c - | n = natural; ":"; tac = Tactic.tactic; "." -> VernacSolve (n,tac,true) - | n = natural; ":"; tac = Tactic.tactic; "!!" -> VernacSolve (n,tac,false) - | n = natural; ":"; v = check_command; "." -> v (Some n) - | "["; l = vernac_list_tail -> VernacList l - - (* For translation from V7 to V8 *) - | IDENT "V7only"; v = vernac -> - filter_com loc; VernacV7only v - | IDENT "V8only"; v = vernac -> VernacV8only v - -(* - (* This is for "Grammar vernac" rules *) - | id = METAIDENT -> VernacVar (Names.id_of_string id) -*) + | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l ] ] ; - - check_command: - [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = constr -> - fun g -> VernacCheckMayEval (Some r, g, c) - | IDENT "Check"; c = constr -> - fun g -> VernacCheckMayEval (None, g, c) ] ] - ; vernac: FIRST [ [ IDENT "Time"; v = vernac -> VernacTime v ] ] ; vernac: LAST - [ [ tac = Tactic.tactic; "." -> VernacSolve (1,tac,true) - | tac = Tactic.tactic; "!!" -> VernacSolve (1,tac,false) - | IDENT "Existential"; n = natural; c = constr_body -> - VernacSolveExistential (n,c) - ] ] - ; - constr_body: - [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t) - | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t) - | ":="; c = constr -> c ] ] + [ [ gln = OPT[n=natural; ":" -> n]; + tac = subgoal_command -> tac gln ] ] ; - vernac_list_tail: - [ [ v = located_vernac; l = vernac_list_tail -> v :: l - | "]"; "." -> [] ] ] + subgoal_command: + [ [ c = check_command; "." -> c + | tac = Tactic.tactic; + use_dft_tac = [ "." -> false | "..." -> true ] -> + (fun g -> + let g = match g with Some gl -> gl | _ -> 1 in + VernacSolve(g,tac,use_dft_tac)) ] ] ; located_vernac: [ [ v = vernac -> loc, v ] ] ; END + let test_plurial_form = function - | [_,([_],_)] -> + | [(_,([_],_))] -> Options.if_verbose warning - "Keywords Variables/Hypotheses/Parameters expect more than one assumption" + "Keywords Variables/Hypotheses/Parameters expect more than one assumption" | _ -> () +let no_coercion loc (c,x) = + if c then Util.user_err_loc + (loc,"no_coercion",Pp.str"no coercion allowed here"); + x + (* Gallina declarations *) -if !Options.v7 then GEXTEND Gram - GLOBAL: gallina gallina_ext thm_token; + GLOBAL: gallina gallina_ext thm_token def_body; + gallina: + (* Definition, Theorem, Variable, Axiom, ... *) + [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":"; + c = lconstr -> + VernacStartTheoremProof (thm, id, (bl, c), false, no_hook) + | stre = assumption_token; bl = assum_list -> + VernacAssumption (stre, bl) + | stre = assumptions_token; bl = assum_list -> + test_plurial_form bl; + VernacAssumption (stre, bl) + | IDENT "Boxed";"Definition";id = identref; b = def_body -> + VernacDefinition ((Global,true,Definition), id, b, no_hook) + | IDENT "Unboxed";"Definition";id = identref; b = def_body -> + VernacDefinition ((Global,false,Definition), id, b, no_hook) + | (f,d) = def_token; id = identref; b = def_body -> + VernacDefinition (d, id, b, f) + (* Gallina inductive declarations *) + | f = finite_token; + indl = LIST1 inductive_definition SEP "with" -> + VernacInductive (f,indl) + | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint (recs,true) + | IDENT "Unboxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint (recs,false) + | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint (recs,Options.boxed_definitions()) + | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + VernacCoFixpoint (corecs,false) + | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ] + ; + gallina_ext: + [ [ b = record_token; oc = opt_coercion; name = identref; + ps = LIST0 binder_let; ":"; + s = lconstr; ":="; cstr = OPT identref; "{"; + fs = LIST0 record_field SEP ";"; "}" -> + VernacRecord (b,(oc,name),ps,s,cstr,fs) +(* Non porté ? + | f = finite_token; s = csort; id = identref; + indpar = LIST0 simple_binder; ":="; lc = constructor_list -> + VernacInductive (f,[id,None,indpar,s,lc]) +*) + ] ] + ; thm_token: [ [ "Theorem" -> Theorem | IDENT "Lemma" -> Lemma | IDENT "Fact" -> Fact - | IDENT "Remark" -> Remark ] ] + | IDENT "Remark" -> Remark + | IDENT "Corollary" -> Corollary + | IDENT "Proposition" -> Proposition + | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) - | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition) - | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) + [ [ "Definition" -> + no_hook, (Global, Options.boxed_definitions(), Definition) + | IDENT "Let" -> + no_hook, (Local, Options.boxed_definitions(), Definition) + | IDENT "Example" -> + no_hook, (Global, Options.boxed_definitions(), Example) + | IDENT "SubClass" -> Class.add_subclass_hook, (Global, false, SubClass) | IDENT "Local"; IDENT "SubClass" -> - Class.add_subclass_hook, (Local, SubClass) ] ] + Class.add_subclass_hook, (Local, false, SubClass) ] ] ; assumption_token: [ [ "Hypothesis" -> (Local, Logical) | "Variable" -> (Local, Definitional) | "Axiom" -> (Global, Logical) | "Parameter" -> (Global, Definitional) - | IDENT "Conjecture" -> (Global,Conjectural) ] ] + | IDENT "Conjecture" -> (Global, Conjectural) ] ] ; assumptions_token: [ [ IDENT "Hypotheses" -> (Local, Logical) | IDENT "Variables" -> (Local, Definitional) + | IDENT "Axioms" -> (Global, Logical) | IDENT "Parameters" -> (Global, Definitional) ] ] ; - of_type_with_opt_coercion: - [ [ ":>" -> true - | ":"; ">" -> true - | ":" -> false ] ] - ; - params: - [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; - c = constr -> (coe,(idl,c)) - ] ] - ; - ne_params_list: - [ [ ll = LIST1 params SEP ";" -> ll ] ] - ; - name_comma_list_tail: - [ [ ","; nal = LIST1 name SEP "," -> nal | -> [] ] ] - ; - ident_comma_list_tail: - [ [ ","; nal = LIST1 identref SEP "," -> nal | -> [] ] ] - ; - decl_notation: - [ [ "where"; ntn = STRING; ":="; c = constr; - scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] - ; - type_option: - [ [ ":"; c = constr -> c - | -> evar_constr loc ] ] - ; - opt_casted_constr: - [ [ c = constr; ":"; t = constr -> CCast(loc,c,t) - | c = constr -> c ] ] - ; - vardecls: - [ [ na = name; nal = name_comma_list_tail; c = type_option - -> LocalRawAssum (na::nal,c) - | na = name; "="; c = opt_casted_constr -> - LocalRawDef (na,c) - | na = name; ":="; c = opt_casted_constr -> - LocalRawDef (na,c) - ] ] - ; - binders: - [ [ "["; bl = LIST1 vardecls SEP ";"; "]" -> bl ] ] - ; - binders_list: - [ [ bls = LIST0 binders -> List.flatten bls ] ] - ; - reduce: - [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r - | -> None ] ] - ; - def_body: - [ [ bl = binders_list; ":="; red = reduce; c = constr; ":"; t = constr -> - DefineBody (bl, red, c, Some t) - | bl = binders_list; ":"; t = constr; ":="; red = reduce; c = constr -> - DefineBody (bl, red, c, Some t) - | bl = binders_list; ":="; red = reduce; c = constr -> - DefineBody (bl, red, c, None) - | bl = binders_list; ":"; t = constr -> - ProveBody (bl, t) ] ] - ; - gallina: - (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = binders_list; ":"; c = constr -> - VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ())) - | (f,d) = def_token; id = identref; b = def_body -> - VernacDefinition (d, id, b, f) - | stre = assumption_token; bl = ne_params_list -> - VernacAssumption (stre, bl) - | stre = assumptions_token; bl = ne_params_list -> - test_plurial_form bl; - VernacAssumption (stre, bl) - ] ] - ; - (* Gallina inductive declarations *) finite_token: [ [ "Inductive" -> true | "CoInductive" -> false ] ] @@ -208,192 +170,250 @@ GEXTEND Gram record_token: [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ] ; - constructor: - [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; - c = constr -> List.map (fun id -> (coe,(id,c))) idl ] ] - ; - constructor_list: - [ [ "|"; l = LIST1 constructor SEP "|" -> List.flatten l - | l = LIST1 constructor SEP "|" -> List.flatten l - | -> [] ] ] - ; - block_old_style: - [ [ ind = oneind_old_style; "with"; indl = block_old_style -> ind :: indl - | ind = oneind_old_style -> [ind] ] ] + (* Simple definitions *) + def_body: + [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr -> + (match c with + CCast(_,c,k,t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None)) + | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> + DefineBody (bl, red, c, Some t) + | bl = LIST0 binder_let; ":"; t = lconstr -> + ProveBody (bl, t) ] ] ; - oneind_old_style: - [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list -> - (id,c,lc) ] ] + reduce: + [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r + | -> None ] ] ; - oneind: - [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; - ":="; lc = constructor_list; ntn = OPT decl_notation -> + decl_notation: + [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; + scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ] + ; + (* Inductives and records *) + inductive_definition: + [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr; + ":="; lc = constructor_list; ntn = decl_notation -> (id,ntn,indpar,c,lc) ] ] ; - simple_binders_list: - [ [ bl = ne_simple_binders_list -> bl + constructor_list: + [ [ "|"; l = LIST1 constructor SEP "|" -> l + | l = LIST1 constructor SEP "|" -> l | -> [] ] ] ; +(* + csort: + [ [ s = sort -> CSort (loc,s) ] ] + ; +*) opt_coercion: [ [ ">" -> true | -> false ] ] ; - onescheme: - [ [ id = identref; ":="; dep = dep; ind = global; IDENT "Sort"; - s = sort -> (id,dep,ind,s) ] ] - ; - schemes: - [ [ recl = LIST1 onescheme SEP "with" -> recl ] ] - ; - dep: - [ [ IDENT "Induction"; IDENT "for" -> true - | IDENT "Minimality"; IDENT "for" -> false ] ] + (* (co)-fixpoints *) + rec_definition: + [ [ id = ident; bl = LIST1 binder_let; + annot = rec_annotation; type_ = type_cstr; + ":="; def = lconstr; ntn = decl_notation -> + let names = List.map snd (names_of_local_assums bl) in + let ni = + match fst annot with + Some id -> + (try list_index (Name id) names - 1 + with Not_found -> Util.user_err_loc + (loc,"Fixpoint", + Pp.str "No argument named " ++ Nameops.pr_id id)) + | None -> + if List.length names > 1 then + Util.user_err_loc + (loc,"Fixpoint", + Pp.str "the recursive argument needs to be specified"); + 0 in + ((id, (ni, snd annot), bl, type_, def),ntn) ] ] + ; + corec_definition: + [ [ id = ident; bl = LIST0 binder_let; c = type_cstr; ":="; + def = lconstr -> + (id,bl,c ,def) ] ] + ; + rec_annotation: + [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec) + | "{"; IDENT "wf"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CWfRec rel) + | -> (None, CStructRec) + ] ] ; - onerec: - [ [ id = base_ident; bl = ne_fix_binders; ":"; type_ = constr; - ":="; def = constr; ntn = OPT decl_notation -> - let ni = List.length (List.flatten (List.map fst bl)) - 1 in - let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in - ((id, ni, bl, type_, def), ntn) ] ] + type_cstr: + [ [ ":"; c=lconstr -> c + | -> CHole loc ] ] ; - specifrec: - [ [ l = LIST1 onerec SEP "with" -> l ] ] + (* Inductive schemes *) + scheme: + [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global; + IDENT "Sort"; s = sort -> + (id,dep,ind,s) ] ] ; - onecorec: - [ [ id = base_ident; ":"; c = constr; ":="; def = constr -> - (id,[],c,def) ] ] + dep_scheme: + [ [ IDENT "Induction" -> true + | IDENT "Minimality" -> false ] ] ; - specifcorec: - [ [ l = LIST1 onecorec SEP "with" -> l ] ] + (* Various Binders *) +(* + (* ... without coercions *) + binder_nodef: + [ [ b = binder_let -> + (match b with + LocalRawAssum(l,ty) -> (l,ty) + | LocalRawDef _ -> + Util.user_err_loc + (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ] ; +*) + (* ... with coercions *) record_field: - [ [ id = name; oc = of_type_with_opt_coercion; t = constr -> - (oc,AssumExpr (id,t)) - | id = name; oc = of_type_with_opt_coercion; t = constr; - ":="; b = constr -> - (oc,DefExpr (id,b,Some t)) - | id = name; ":="; b = constr -> - (false,DefExpr (id,b,None)) ] ] - ; - fields: - [ [ fs = LIST0 record_field SEP ";" -> fs ] ] - ; - simple_binders: - [ [ "["; bll = LIST1 vardecls SEP ";"; "]" -> bll ] ] - ; - ne_simple_binders_list: - [ [ bll = LIST1 simple_binders -> (List.flatten bll) ] ] - ; - fix_params: - [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) - | idl = LIST1 name SEP "," -> (idl, evar_constr dummy_loc) - ] ] - ; - fix_binders: - [ [ "["; bll = LIST1 fix_params SEP ";"; "]" -> bll ] ] - ; - ne_fix_binders: - [ [ bll = LIST1 fix_binders -> List.flatten bll ] ] + [ [ id = name -> (false,AssumExpr(id,CHole loc)) + | id = name; oc = of_type_with_opt_coercion; t = lconstr -> + (oc,AssumExpr (id,t)) + | id = name; oc = of_type_with_opt_coercion; + t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t)) + | id = name; ":="; b = lconstr -> + match b with + CCast(_,b,_,t) -> (false,DefExpr(id,b,Some t)) + | _ -> (false,DefExpr(id,b,None)) ] ] + ; + assum_list: + [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ] + ; + assum_coe: + [ [ "("; a = simple_assum_coe; ")" -> a ] ] + ; + simple_assum_coe: + [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + (oc,(idl,c)) ] ] ; - rec_constructor: - [ [ c = identref -> Some c - | -> None ] ] - ; - gallina_ext: - [ [ IDENT "Mutual"; bl = ne_simple_binders_list ; f = finite_token; - indl = block_old_style -> - let indl' = List.map (fun (id,ar,c) -> (id,None,bl,ar,c)) indl in - VernacInductive (f,indl') - | b = record_token; oc = opt_coercion; name = identref; - ps = simple_binders_list; ":"; - s = constr; ":="; c = rec_constructor; "{"; fs = fields; "}" -> - VernacRecord (b,(oc,name),ps,s,c,fs) - ] ] - ; - gallina: - [ [ IDENT "Mutual"; f = finite_token; indl = LIST1 oneind SEP "with" -> - VernacInductive (f,indl) - | f = finite_token; indl = LIST1 oneind SEP "with" -> - VernacInductive (f,indl) - | "Fixpoint"; recs = specifrec -> VernacFixpoint recs - | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs - | IDENT "Scheme"; l = schemes -> VernacScheme l - | f = finite_token; s = csort; id = identref; - indpar = simple_binders_list; ":="; lc = constructor_list -> - VernacInductive (f,[id,None,indpar,s,lc]) ] ] + constructor: + [ [ id = identref; l = LIST0 binder_let; + coe = of_type_with_opt_coercion; c = lconstr -> + (coe,(id,G_constr.mkCProdN loc l c)) + | id = identref; l = LIST0 binder_let -> + (false,(id,G_constr.mkCProdN loc l (CHole loc))) ] ] ; - csort: - [ [ s = sort -> CSort (loc,s) ] ] + of_type_with_opt_coercion: + [ [ ":>" -> true + | ":"; ">" -> true + | ":" -> false ] ] ; +END + + +(* Modules and Sections *) +GEXTEND Gram + GLOBAL: gallina_ext module_expr module_type; + gallina_ext: - [ [ -(* Sections *) - IDENT "Section"; id = identref -> VernacBeginSection id - | IDENT "Chapter"; id = identref -> VernacBeginSection id ] ] - ; - module_vardecls: - [ [ id = identref; idl = ident_comma_list_tail; ":"; - mty = Module.module_type -> (id::idl,mty) ] ] + [ [ (* Interactive module declaration *) + IDENT "Module"; export = export_token; id = identref; + bl = LIST0 module_binder; mty_o = OPT of_module_type; + mexpr_o = OPT is_module_expr -> + VernacDefineModule (export, id, bl, mty_o, mexpr_o) + + | IDENT "Module"; "Type"; id = identref; + bl = LIST0 module_binder; mty_o = OPT is_module_type -> + VernacDeclareModuleType (id, bl, mty_o) + + | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; + bl = LIST0 module_binder; mty_o = of_module_type -> + VernacDeclareModule (export, id, bl, mty_o) + (* Section beginning *) + | IDENT "Section"; id = identref -> VernacBeginSection id + | IDENT "Chapter"; id = identref -> VernacBeginSection id + + (* This end a Section a Module or a Module Type *) + | IDENT "End"; id = identref -> VernacEndSegment id + + (* Requiring an already compiled module *) + | IDENT "Require"; export = export_token; specif = specif_token; + qidl = LIST1 global -> + VernacRequire (export, specif, qidl) + | IDENT "Require"; export = export_token; specif = specif_token; + filename = ne_string -> + VernacRequireFrom (export, specif, filename) + | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) + | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ] ; - module_binders: - [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ] + export_token: + [ [ IDENT "Import" -> Some false + | IDENT "Export" -> Some true + | -> None ] ] ; - module_binders_list: - [ [ bls = LIST0 module_binders -> List.flatten bls ] ] + specif_token: + [ [ IDENT "Implementation" -> Some false + | IDENT "Specification" -> Some true + | -> None ] ] ; of_module_type: - [ [ ":"; mty = Module.module_type -> (mty, true) - | "<:"; mty = Module.module_type -> (mty, false) ] ] + [ [ ":"; mty = module_type -> (mty, true) + | "<:"; mty = module_type -> (mty, false) ] ] ; is_module_type: - [ [ ":="; mty = Module.module_type -> mty ] ] + [ [ ":="; mty = module_type -> mty ] ] ; is_module_expr: - [ [ ":="; mexpr = Module.module_expr -> mexpr ] ] + [ [ ":="; mexpr = module_expr -> mexpr ] ] ; - gallina_ext: - [ [ - (* Interactive module declaration *) - IDENT "Module"; id = identref; - bl = module_binders_list; mty_o = OPT of_module_type; - mexpr_o = OPT is_module_expr -> - VernacDefineModule (id, bl, mty_o, mexpr_o) - - | IDENT "Module"; "Type"; id = identref; - bl = module_binders_list; mty_o = OPT is_module_type -> - VernacDeclareModuleType (id, bl, mty_o) - - | IDENT "Declare"; IDENT "Module"; id = identref; - bl = module_binders_list; mty_o = OPT of_module_type; - mexpr_o = OPT is_module_expr -> - VernacDeclareModule (id, bl, mty_o, mexpr_o) - (* This end a Section a Module or a Module Type *) + (* Module binder *) + module_binder: + [ [ "("; export = export_token; idl = LIST1 identref; ":"; + mty = module_type; ")" -> (export,idl,mty) ] ] + ; - | IDENT "End"; id = identref -> VernacEndSegment id + (* Module expressions *) + module_expr: + [ [ qid = qualid -> CMEident qid + | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) + | "("; me = module_expr; ")" -> me +(* ... *) + ] ] + ; + with_declaration: + [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr -> + CWith_Definition (fqid,c) + | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid -> + CWith_Module (fqid,qid) + ] ] + ; + module_type: + [ [ qid = qualid -> CMTEident qid +(* ... *) + | mty = module_type; "with"; decl = with_declaration -> + CMTEwith (mty,decl) ] ] + ; +END +(* Extensions: implicits, coercions, etc. *) +GEXTEND Gram + GLOBAL: gallina_ext; -(* Transparent and Opaque *) - | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) + gallina_ext: + [ [ (* Transparent and Opaque *) + IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l) -(* Canonical structure *) + (* Canonical structure *) | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical qid | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in + let s = coerce_global_to_id qid in VernacDefinition - ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook) - (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed - (they were unused and undocumented) *) + ((Global,false,CanonicalStructure),(dummy_loc,s),d, + (fun _ -> Recordops.declare_canonical_structure)) -(* Coercions *) + (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in - VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + let s = coerce_global_to_id qid in + VernacDefinition ((Global,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in - VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + let s = coerce_global_to_id qid in + VernacDefinition ((Local,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (Local, f, s, t) @@ -406,114 +426,230 @@ GEXTEND Gram | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (Global, qid, s, t) - | IDENT "Class"; IDENT "Local"; c = global -> - Pp.warning "Class is obsolete"; VernacNop - | IDENT "Class"; c = global -> - Pp.warning "Class is obsolete"; VernacNop -(* Implicit *) -(* - | IDENT "Syntactic"; "Definition"; id = identref; ":="; c = constr; - n = OPT [ "|"; n = natural -> n ] -> - VernacSyntacticDefinition (id,c,n) -*) - | IDENT "Syntactic"; "Definition"; id = ident; ":="; c = constr; - n = OPT [ "|"; n = natural -> n ] -> - let c = match n with - | Some n -> - let l = list_tabulate (fun _ -> (CHole (loc),None)) n in - CApp (loc,(None,c),l) - | None -> c in - VernacSyntacticDefinition (id,c,false,true) - | IDENT "Implicits"; qid = global; "["; l = LIST0 natural; "]" -> - let l = List.map (fun n -> ExplByPos n) l in - VernacDeclareImplicits (qid,Some l) - | IDENT "Implicits"; qid = global -> VernacDeclareImplicits (qid,None) - - | IDENT "Implicit"; ["Variable"; "Type" | IDENT "Variables"; "Type"]; - idl = LIST1 identref SEP ","; ":"; c = constr -> VernacReserve (idl,c) - - (* For compatibility *) - | IDENT "Implicit"; IDENT "Arguments"; IDENT "On" -> - VernacSetOption - (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue true) - | IDENT "Implicit"; IDENT "Arguments"; IDENT "Off" -> - VernacSetOption - (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue false) - ] ] + (* Implicit *) + | IDENT "Implicit"; IDENT "Arguments"; qid = global; + pos = OPT [ "["; l = LIST0 ident; "]" -> l ] -> + let pos = option_app (List.map (fun id -> ExplByName id)) pos in + VernacDeclareImplicits (qid,pos) + + | IDENT "Implicit"; ["Type" | IDENT "Types"]; + idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ] ; END -(* Modules management *) -if !Options.v7 then GEXTEND Gram - GLOBAL: command; + GLOBAL: command check_command class_rawexpr; - export_token: - [ [ IDENT "Import" -> false - | IDENT "Export" -> true - | -> false ] ] - ; - specif_token: - [ [ IDENT "Implementation" -> Some false - | IDENT "Specification" -> Some true - | -> None ] ] - ; command: - [ [ "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; - s = [ s = STRING -> s | s = IDENT -> s ] -> + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l + + (* System directory *) + | IDENT "Pwd" -> VernacChdir None + | IDENT "Cd" -> VernacChdir None + | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir) + + (* Toplevel control *) + | IDENT "Drop" -> VernacToplevelControl Drop + | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop + | IDENT "Quit" -> VernacToplevelControl Quit + + | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; + s = [ s = ne_string -> s | s = IDENT -> s ] -> VernacLoad (verbosely, s) -(* | "Compile"; - verbosely = - [ IDENT "Verbose" -> "Verbose" - | -> "" ]; - IDENT "Module"; - only_spec = - [ IDENT "Specification" -> "Specification" - | -> "" ]; - mname = [ s = STRING -> s | s = IDENT -> s ]; - fname = OPT [ s = STRING -> s | s = IDENT -> s ] -> ExtraVernac - let fname = match fname with Some s -> s | None -> mname in - <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec) - ($STR $mname) ($STR $fname))>> -*) - | IDENT "Read"; IDENT "Module"; qidl = LIST1 global -> - VernacRequire (None, None, qidl) - | IDENT "Require"; export = export_token; specif = specif_token; - qidl = LIST1 global -> VernacRequire (Some export, specif, qidl) -(* | IDENT "Require"; export = export_token; specif = specif_token; - id = identref; filename = STRING -> - VernacRequireFrom (export, specif, id, filename) *) - | IDENT "Require"; export = export_token; specif = specif_token; - filename = STRING -> - VernacRequireFrom (Some export, specif, filename) - | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 STRING -> + | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> VernacDeclareMLModule l - | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) - | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) - ] -] + + (* Dump of the universe graph - to file or to stdout *) + | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string -> + VernacPrint (PrintUniverses fopt) + + | IDENT "Locate"; l = locatable -> VernacLocate l + + (* Managing load paths *) + | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; + alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) + | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> + VernacRemoveLoadPath dir + + (* For compatibility *) + | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> + VernacAddLoadPath (true, dir, alias) + | IDENT "DelPath"; dir = ne_string -> + VernacRemoveLoadPath dir + + (* Type-Checking (pas dans le refman) *) + | "Type"; c = lconstr -> VernacGlobalCheck c + + (* Printing (careful factorization of entries) *) + | IDENT "Print"; p = printable -> VernacPrint p + | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + VernacPrint (PrintModuleType qid) + | IDENT "Print"; IDENT "Module"; qid = global -> + VernacPrint (PrintModule qid) + | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) + | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid) + + (* Searching the environment *) + | IDENT "Search"; qid = global; l = in_or_out_modules -> + VernacSearch (SearchHead qid, l) + | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> + VernacSearch (SearchPattern c, l) + | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> + VernacSearch (SearchRewrite c, l) + | IDENT "SearchAbout"; + sl = [ "["; l = LIST1 [ r = global -> SearchRef r + | s = ne_string -> SearchString s ]; "]" -> l + | qid = global -> [SearchRef qid] ]; + l = in_or_out_modules -> + VernacSearch (SearchAbout sl, l) + + | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> + VernacAddMLPath (false, dir) + | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> + VernacAddMLPath (true, dir) + + (* Pour intervenir sur les tables de paramètres *) + | "Set"; table = IDENT; field = IDENT; v = option_value -> + VernacSetOption (SecondaryTable (table,field),v) + | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacAddOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; field = IDENT -> + VernacSetOption (SecondaryTable (table,field),BoolValue true) + | IDENT "Unset"; table = IDENT; field = IDENT -> + VernacUnsetOption (SecondaryTable (table,field)) + | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacRemoveOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; value = option_value -> + VernacSetOption (PrimaryTable table, value) + | "Set"; table = IDENT -> + VernacSetOption (PrimaryTable table, BoolValue true) + | IDENT "Unset"; table = IDENT -> + VernacUnsetOption (PrimaryTable table) + + | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Print"; IDENT "Table"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacAddOption (SecondaryTable (table,field), v) + + (* Un value global ci-dessous va être caché par un field au dessus! *) + | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + VernacAddOption (PrimaryTable table, v) + + | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacMemOption (SecondaryTable (table,field), v) + | IDENT "Test"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value -> + VernacMemOption (PrimaryTable table, v) + | IDENT "Test"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + -> VernacRemoveOption (SecondaryTable (table,field), v) + | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + VernacRemoveOption (PrimaryTable table, v) ] ] ; -END + check_command: (* TODO: rapprocher Eval et Check *) + [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> + fun g -> VernacCheckMayEval (Some r, g, c) + | IDENT "Check"; c = lconstr -> + fun g -> VernacCheckMayEval (None, g, c) ] ] + ; + printable: + [ [ IDENT "Term"; qid = global -> PrintName qid + | IDENT "All" -> PrintFullContext + | IDENT "Section"; s = global -> PrintSectionContext s + | IDENT "Grammar"; ent = IDENT -> + (* This should be in "syntax" section but is here for factorization*) + PrintGrammar ("", ent) + | IDENT "LoadPath" -> PrintLoadPath + | IDENT "Modules" -> PrintModules -if !Options.v7 then -GEXTEND Gram - GLOBAL: command; + | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath + | IDENT "ML"; IDENT "Modules" -> PrintMLModules + | IDENT "Graph" -> PrintGraph + | IDENT "Classes" -> PrintClasses + | IDENT "Ltac"; qid = global -> PrintLtac qid + | IDENT "Coercions" -> PrintCoercions + | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr + -> PrintCoercionPaths (s,t) + | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions + | IDENT "Tables" -> PrintTables +(* Obsolete: was used for cooking V6.3 recipes ?? + | IDENT "Proof"; qid = global -> PrintOpaqueName qid +*) + | IDENT "Hint" -> PrintHintGoal + | IDENT "Hint"; qid = global -> PrintHint qid + | IDENT "Hint"; "*" -> PrintHintDb + | IDENT "HintDb"; s = IDENT -> PrintHintDbName s + | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s + | IDENT "Setoids" -> PrintSetoids + | IDENT "Scopes" -> PrintScopes + | IDENT "Scope"; s = IDENT -> PrintScope s + | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s + | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ] + ; + class_rawexpr: + [ [ IDENT "Funclass" -> FunClass + | IDENT "Sortclass" -> SortClass + | qid = global -> RefClass qid ] ] + ; + locatable: + [ [ qid = global -> LocateTerm qid + | IDENT "File"; f = ne_string -> LocateFile f + | IDENT "Library"; qid = global -> LocateLibrary qid + | IDENT "Module"; qid = global -> LocateModule qid + | s = ne_string -> LocateNotation s ] ] + ; + option_value: + [ [ n = integer -> IntValue n + | s = STRING -> StringValue s ] ] + ; + option_ref_value: + [ [ id = global -> QualidRefValue id + | s = STRING -> StringRefValue s ] ] + ; + as_dirpath: + [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] + ; + in_or_out_modules: + [ [ IDENT "inside"; l = LIST1 global -> SearchInside l + | IDENT "outside"; l = LIST1 global -> SearchOutside l + | -> SearchOutside [] ] ] + ; + comment: + [ [ c = constr -> CommentConstr c + | s = STRING -> CommentString s + | n = natural -> CommentInt n ] ] + ; +END; +GEXTEND Gram command: [ [ - (* State management *) IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s - | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s + | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s - | IDENT "Restore"; IDENT "State"; s = STRING -> VernacRestoreState s + | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s (* Resetting *) | IDENT "Reset"; id = identref -> VernacResetName id | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial | IDENT "Back" -> VernacBack 1 | IDENT "Back"; n = natural -> VernacBack n + | IDENT "BackTo"; n = natural -> VernacBackTo n + | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> + VernacBacktrack (n,m,p) (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> VernacDebug true @@ -522,3 +658,86 @@ GEXTEND Gram ] ]; END ;; + +(* Grammar extensions *) + +GEXTEND Gram + GLOBAL: syntax; + + syntax: + [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (local,true,sc) + + | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (local,false,sc) + + | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> + VernacDelimiters (sc,key) + + | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; + refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) + + | IDENT "Arguments"; IDENT "Scope"; qid = global; + "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) + + | IDENT "Infix"; local = locality; + op = ne_string; ":="; p = global; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + VernacInfix (local,(op,modl),p,sc) + | IDENT "Notation"; local = locality; id = ident; ":="; c = constr; + b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> + VernacSyntacticDefinition (id,c,local,b) + | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + VernacNotation (local,c,(s,modl),sc) + + | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; + pil = LIST1 production_item; ":="; t = Tactic.tactic + -> VernacTacticNotation (n,pil,t) + + | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; + l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] + -> VernacSyntaxExtension (local,(s,l)) + + (* "Print" "Grammar" should be here but is in "command" entry in order + to factorize with other "Print"-based vernac entries *) + ] ] + ; + tactic_level: + [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] + ; + locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; + level: + [ [ IDENT "level"; n = natural -> NumLevel n + | IDENT "next"; IDENT "level" -> NextLevel ] ] + ; + syntax_modifier: + [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) + | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; + lev = level -> SetItemLevel (x::l,lev) + | "at"; IDENT "level"; n = natural -> SetLevel n + | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA + | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA + | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA + | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) + | IDENT "only"; IDENT "parsing" -> SetOnlyParsing + | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ] + ; + syntax_extension_type: + [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference + | IDENT "bigint" -> ETBigint + ] ] + ; + opt_scope: + [ [ "_" -> None | sc = IDENT -> Some sc ] ] + ; + production_item: + [ [ s = ne_string -> VTerm s + | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> + VNonTerm (loc,nt,po) ] ] + ; +END diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4 deleted file mode 100644 index 976cc259..00000000 --- a/parsing/g_vernacnew.ml4 +++ /dev/null @@ -1,728 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_vernacnew.ml4,v 1.63.2.2 2004/10/12 10:10:29 herbelin Exp $ *) - -open Pp -open Util -open Names -open Coqast -open Topconstr -open Vernacexpr -open Pcoq -open Tactic -open Decl_kinds -open Genarg -open Extend -open Ppextend -open Goptions - -open Prim -open Constr -open Vernac_ -open Module - - -let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw - -(* Rem: do not join the different GEXTEND into one, it breaks native *) -(* compilation on PowerPC and Sun architectures *) - -let check_command = Gram.Entry.create "vernac:check_command" -let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" -let thm_token = Gram.Entry.create "vernac:thm_token" -let def_body = Gram.Entry.create "vernac:def_body" - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: vernac gallina_ext; - vernac: - (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) - (* "." is still in the stream and discard_to_dot works correctly *) - [ [ g = gallina; "." -> g - | g = gallina_ext; "." -> g - | c = command; "." -> c - | c = syntax; "." -> c - | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l - ] ] - ; - vernac: FIRST - [ [ IDENT "Time"; v = vernac -> VernacTime v ] ] - ; - vernac: LAST - [ [ gln = OPT[n=natural; ":" -> n]; - tac = subgoal_command -> tac gln ] ] - ; - subgoal_command: - [ [ c = check_command; "." -> c - | tac = Tactic.tactic; - use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = match g with Some gl -> gl | _ -> 1 in - VernacSolve(g,tac,use_dft_tac)) ] ] - ; - located_vernac: - [ [ v = vernac -> loc, v ] ] - ; -END - - -let test_plurial_form = function - | [(_,([_],_))] -> - Options.if_verbose warning - "Keywords Variables/Hypotheses/Parameters expect more than one assumption" - | _ -> () - -let no_coercion loc (c,x) = - if c then Util.user_err_loc - (loc,"no_coercion",Pp.str"no coercion allowed here"); - x - -(* Gallina declarations *) -if not !Options.v7 then -GEXTEND Gram - GLOBAL: gallina gallina_ext thm_token def_body; - - gallina: - (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":"; - c = lconstr -> - VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ())) - | (f,d) = def_token; id = identref; b = def_body -> - VernacDefinition (d, id, b, f) - | stre = assumption_token; bl = assum_list -> - VernacAssumption (stre, bl) - | stre = assumptions_token; bl = assum_list -> - test_plurial_form bl; - VernacAssumption (stre, bl) - (* Gallina inductive declarations *) - | f = finite_token; - indl = LIST1 inductive_definition SEP "with" -> - VernacInductive (f,indl) - | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint recs - | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint corecs - | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ] - ; - gallina_ext: - [ [ b = record_token; oc = opt_coercion; name = identref; - ps = LIST0 binder_let; ":"; - s = lconstr; ":="; cstr = OPT identref; "{"; - fs = LIST0 record_field SEP ";"; "}" -> - VernacRecord (b,(oc,name),ps,s,cstr,fs) -(* Non porté ? - | f = finite_token; s = csort; id = identref; - indpar = LIST0 simple_binder; ":="; lc = constructor_list -> - VernacInductive (f,[id,None,indpar,s,lc]) -*) - ] ] - ; - thm_token: - [ [ "Theorem" -> Theorem - | IDENT "Lemma" -> Lemma - | IDENT "Fact" -> Fact - | IDENT "Remark" -> Remark ] ] - ; - def_token: - [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) - | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition) - | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) - | IDENT "Local"; IDENT "SubClass" -> - Class.add_subclass_hook, (Local, SubClass) ] ] - ; - assumption_token: - [ [ "Hypothesis" -> (Local, Logical) - | "Variable" -> (Local, Definitional) - | "Axiom" -> (Global, Logical) - | "Parameter" -> (Global, Definitional) - | IDENT "Conjecture" -> (Global, Conjectural) ] ] - ; - assumptions_token: - [ [ IDENT "Hypotheses" -> (Local, Logical) - | IDENT "Variables" -> (Local, Definitional) - | IDENT "Axioms" -> (Global, Logical) - | IDENT "Parameters" -> (Global, Definitional) ] ] - ; - finite_token: - [ [ "Inductive" -> true - | "CoInductive" -> false ] ] - ; - record_token: - [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ] - ; - (* Simple definitions *) - def_body: - [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr -> - (match c with - CCast(_,c,t) -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) - | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - DefineBody (bl, red, c, Some t) - | bl = LIST0 binder_let; ":"; t = lconstr -> - ProveBody (bl, t) ] ] - ; - reduce: - [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r - | -> None ] ] - ; - decl_notation: - [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; - scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ] - ; - (* Inductives and records *) - inductive_definition: - [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr; - ":="; lc = constructor_list; ntn = decl_notation -> - (id,ntn,indpar,c,lc) ] ] - ; - constructor_list: - [ [ "|"; l = LIST1 constructor SEP "|" -> l - | l = LIST1 constructor SEP "|" -> l - | -> [] ] ] - ; -(* - csort: - [ [ s = sort -> CSort (loc,s) ] ] - ; -*) - opt_coercion: - [ [ ">" -> true - | -> false ] ] - ; - (* (co)-fixpoints *) - rec_definition: - [ [ id = base_ident; bl = LIST1 binder_let; - annot = OPT rec_annotation; type_ = type_cstr; - ":="; def = lconstr; ntn = decl_notation -> - let names = List.map snd (names_of_local_assums bl) in - let ni = - match annot with - Some id -> - (try list_index (Name id) names - 1 - with Not_found -> Util.user_err_loc - (loc,"Fixpoint", - Pp.str "No argument named " ++ Nameops.pr_id id)) - | None -> - if List.length names > 1 then - Util.user_err_loc - (loc,"Fixpoint", - Pp.str "the recursive argument needs to be specified"); - 0 in - ((id, ni, bl, type_, def),ntn) ] ] - ; - corec_definition: - [ [ id = base_ident; bl = LIST0 binder_let; c = type_cstr; ":="; - def = lconstr -> - (id,bl,c ,def) ] ] - ; - rec_annotation: - [ [ "{"; IDENT "struct"; id=IDENT; "}" -> id_of_string id ] ] - ; - type_cstr: - [ [ ":"; c=lconstr -> c - | -> CHole loc ] ] - ; - (* Inductive schemes *) - scheme: - [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global; - IDENT "Sort"; s = sort -> - (id,dep,ind,s) ] ] - ; - dep_scheme: - [ [ IDENT "Induction" -> true - | IDENT "Minimality" -> false ] ] - ; - (* Various Binders *) -(* - (* ... without coercions *) - binder_nodef: - [ [ b = binder_let -> - (match b with - LocalRawAssum(l,ty) -> (l,ty) - | LocalRawDef _ -> - Util.user_err_loc - (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ] - ; -*) - (* ... with coercions *) - record_field: - [ [ id = name -> (false,AssumExpr(id,CHole loc)) - | id = name; oc = of_type_with_opt_coercion; t = lconstr -> - (oc,AssumExpr (id,t)) - | id = name; oc = of_type_with_opt_coercion; - t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t)) - | id = name; ":="; b = lconstr -> - match b with - CCast(_,b,t) -> (false,DefExpr(id,b,Some t)) - | _ -> (false,DefExpr(id,b,None)) ] ] - ; - assum_list: - [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ] - ; - assum_coe: - [ [ "("; a = simple_assum_coe; ")" -> a ] ] - ; - simple_assum_coe: - [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> - (oc,(idl,c)) ] ] - ; - constructor: - [ [ id = identref; l = LIST0 binder_let; - coe = of_type_with_opt_coercion; c = lconstr -> - (coe,(id,G_constrnew.mkCProdN loc l c)) - | id = identref; l = LIST0 binder_let -> - (false,(id,G_constrnew.mkCProdN loc l (CHole loc))) ] ] - ; - of_type_with_opt_coercion: - [ [ ":>" -> true - | ":"; ">" -> true - | ":" -> false ] ] - ; -END - - -(* Modules and Sections *) -if not !Options.v7 then -GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type; - - gallina_ext: - [ [ (* Interactive module declaration *) - IDENT "Module"; id = identref; - bl = LIST0 module_binder; mty_o = OPT of_module_type; - mexpr_o = OPT is_module_expr -> - VernacDefineModule (id, bl, mty_o, mexpr_o) - - | IDENT "Module"; "Type"; id = identref; - bl = LIST0 module_binder; mty_o = OPT is_module_type -> - VernacDeclareModuleType (id, bl, mty_o) - - | IDENT "Declare"; IDENT "Module"; id = identref; - bl = LIST0 module_binder; mty_o = OPT of_module_type; - mexpr_o = OPT is_module_expr -> - VernacDeclareModule (id, bl, mty_o, mexpr_o) - (* Section beginning *) - | IDENT "Section"; id = identref -> VernacBeginSection id - | IDENT "Chapter"; id = identref -> VernacBeginSection id - - (* This end a Section a Module or a Module Type *) - | IDENT "End"; id = identref -> VernacEndSegment id - - (* Requiring an already compiled module *) - | IDENT "Require"; export = export_token; specif = specif_token; - qidl = LIST1 global -> - VernacRequire (export, specif, qidl) - | IDENT "Require"; export = export_token; specif = specif_token; - filename = ne_string -> - VernacRequireFrom (export, specif, filename) - | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) - | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ] - ; - export_token: - [ [ IDENT "Import" -> Some false - | IDENT "Export" -> Some true - | -> None ] ] - ; - specif_token: - [ [ IDENT "Implementation" -> Some false - | IDENT "Specification" -> Some true - | -> None ] ] - ; - of_module_type: - [ [ ":"; mty = module_type -> (mty, true) - | "<:"; mty = module_type -> (mty, false) ] ] - ; - is_module_type: - [ [ ":="; mty = module_type -> mty ] ] - ; - is_module_expr: - [ [ ":="; mexpr = module_expr -> mexpr ] ] - ; - - (* Module binder *) - module_binder: - [ [ "("; idl = LIST1 identref; ":"; mty = module_type; ")" -> - (idl,mty) ] ] - ; - - (* Module expressions *) - module_expr: - [ [ qid = qualid -> CMEident qid - | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) - | "("; me = module_expr; ")" -> me -(* ... *) - ] ] - ; - with_declaration: - [ [ "Definition"; id = identref; ":="; c = Constr.lconstr -> - CWith_Definition (id,c) - | IDENT "Module"; id = identref; ":="; qid = qualid -> - CWith_Module (id,qid) - ] ] - ; - module_type: - [ [ qid = qualid -> CMTEident qid -(* ... *) - | mty = module_type; "with"; decl = with_declaration -> - CMTEwith (mty,decl) ] ] - ; -END - -(* Extensions: implicits, coercions, etc. *) -if not !Options.v7 then -GEXTEND Gram - GLOBAL: gallina_ext; - - gallina_ext: - [ [ (* Transparent and Opaque *) - IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) - | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l) - - (* Canonical structure *) - | IDENT "Canonical"; IDENT "Structure"; qid = global -> - VernacCanonical qid - | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in - VernacDefinition - ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook) - - (* Coercions *) - | IDENT "Coercion"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in - VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) - | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in - VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) - | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; - ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (Local, f, s, t) - | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (Global, f, s, t) - | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (Local, qid, s, t) - | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; - t = class_rawexpr -> - VernacCoercion (Global, qid, s, t) - - (* Implicit *) - | IDENT "Implicit"; IDENT "Arguments"; qid = global; - pos = OPT [ "["; l = LIST0 ident; "]" -> l ] -> - let pos = option_app (List.map (fun id -> ExplByName id)) pos in - VernacDeclareImplicits (qid,pos) - - | IDENT "Implicit"; ["Type" | IDENT "Types"]; - idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ] - ; -END - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: command check_command class_rawexpr; - - command: - [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l - - (* System directory *) - | IDENT "Pwd" -> VernacChdir None - | IDENT "Cd" -> VernacChdir None - | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir) - - (* Toplevel control *) - | IDENT "Drop" -> VernacToplevelControl Drop - | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop - | IDENT "Quit" -> VernacToplevelControl Quit - - | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; - s = [ s = ne_string -> s | s = IDENT -> s ] -> - VernacLoad (verbosely, s) - | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> - VernacDeclareMLModule l - - (* Dump of the universe graph - to file or to stdout *) - | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string -> - VernacPrint (PrintUniverses fopt) - - | IDENT "Locate"; l = locatable -> VernacLocate l - - (* Managing load paths *) - | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; - alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) - | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> - VernacRemoveLoadPath dir - - (* For compatibility *) - | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> - VernacAddLoadPath (true, dir, alias) - | IDENT "DelPath"; dir = ne_string -> - VernacRemoveLoadPath dir - - (* Type-Checking (pas dans le refman) *) - | "Type"; c = lconstr -> VernacGlobalCheck c - - (* Printing (careful factorization of entries) *) - | IDENT "Print"; p = printable -> VernacPrint p - | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) - | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> - VernacPrint (PrintModuleType qid) - | IDENT "Print"; IDENT "Module"; qid = global -> - VernacPrint (PrintModule qid) - | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) - | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid) - - (* Searching the environment *) - | IDENT "Search"; qid = global; l = in_or_out_modules -> - VernacSearch (SearchHead qid, l) - | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchPattern c, l) - | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchRewrite c, l) - | IDENT "SearchAbout"; - sl = [ "["; l = LIST1 [ r = global -> SearchRef r - | s = ne_string -> SearchString s ]; "]" -> l - | qid = global -> [SearchRef qid] ]; - l = in_or_out_modules -> - VernacSearch (SearchAbout sl, l) - - | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - VernacAddMLPath (false, dir) - | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - VernacAddMLPath (true, dir) - - (* Pour intervenir sur les tables de paramètres *) - | "Set"; table = IDENT; field = IDENT; v = option_value -> - VernacSetOption (SecondaryTable (table,field),v) - | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> - VernacAddOption (SecondaryTable (table,field),lv) - | "Set"; table = IDENT; field = IDENT -> - VernacSetOption (SecondaryTable (table,field),BoolValue true) - | IDENT "Unset"; table = IDENT; field = IDENT -> - VernacUnsetOption (SecondaryTable (table,field)) - | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> - VernacRemoveOption (SecondaryTable (table,field),lv) - | "Set"; table = IDENT; value = option_value -> - VernacSetOption (PrimaryTable table, value) - | "Set"; table = IDENT -> - VernacSetOption (PrimaryTable table, BoolValue true) - | IDENT "Unset"; table = IDENT -> - VernacUnsetOption (PrimaryTable table) - - | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT -> - VernacPrintOption (SecondaryTable (table,field)) - | IDENT "Print"; IDENT "Table"; table = IDENT -> - VernacPrintOption (PrimaryTable table) - - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value - -> VernacAddOption (SecondaryTable (table,field), v) - - (* Un value global ci-dessous va être caché par un field au dessus! *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> - VernacAddOption (PrimaryTable table, v) - - | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value - -> VernacMemOption (SecondaryTable (table,field), v) - | IDENT "Test"; table = IDENT; field = IDENT -> - VernacPrintOption (SecondaryTable (table,field)) - | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value -> - VernacMemOption (PrimaryTable table, v) - | IDENT "Test"; table = IDENT -> - VernacPrintOption (PrimaryTable table) - - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value - -> VernacRemoveOption (SecondaryTable (table,field), v) - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - VernacRemoveOption (PrimaryTable table, v) ] ] - ; - check_command: (* TODO: rapprocher Eval et Check *) - [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> - fun g -> VernacCheckMayEval (Some r, g, c) - | IDENT "Check"; c = lconstr -> - fun g -> VernacCheckMayEval (None, g, c) ] ] - ; - printable: - [ [ IDENT "Term"; qid = global -> PrintName qid - | IDENT "All" -> PrintFullContext - | IDENT "Section"; s = global -> PrintSectionContext s - | IDENT "Grammar"; ent = IDENT -> - (* This should be in "syntax" section but is here for factorization*) - PrintGrammar ("", ent) - | IDENT "LoadPath" -> PrintLoadPath - | IDENT "Modules" -> PrintModules - - | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath - | IDENT "ML"; IDENT "Modules" -> PrintMLModules - | IDENT "Graph" -> PrintGraph - | IDENT "Classes" -> PrintClasses - | IDENT "Coercions" -> PrintCoercions - | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr - -> PrintCoercionPaths (s,t) - | IDENT "Tables" -> PrintTables -(* Obsolete: was used for cooking V6.3 recipes ?? - | IDENT "Proof"; qid = global -> PrintOpaqueName qid -*) - | IDENT "Hint" -> PrintHintGoal - | IDENT "Hint"; qid = global -> PrintHint qid - | IDENT "Hint"; "*" -> PrintHintDb - | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | IDENT "Scopes" -> PrintScopes - | IDENT "Scope"; s = IDENT -> PrintScope s - | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s - | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ] - ; - class_rawexpr: - [ [ IDENT "Funclass" -> FunClass - | IDENT "Sortclass" -> SortClass - | qid = global -> RefClass qid ] ] - ; - locatable: - [ [ qid = global -> LocateTerm qid - | IDENT "File"; f = ne_string -> LocateFile f - | IDENT "Library"; qid = global -> LocateLibrary qid - | s = ne_string -> LocateNotation s ] ] - ; - option_value: - [ [ n = integer -> IntValue n - | s = STRING -> StringValue s ] ] - ; - option_ref_value: - [ [ id = global -> QualidRefValue id - | s = STRING -> StringRefValue s ] ] - ; - as_dirpath: - [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] - ; - in_or_out_modules: - [ [ IDENT "inside"; l = LIST1 global -> SearchInside l - | IDENT "outside"; l = LIST1 global -> SearchOutside l - | -> SearchOutside [] ] ] - ; - comment: - [ [ c = constr -> CommentConstr c - | s = STRING -> CommentString s - | n = natural -> CommentInt n ] ] - ; -END; - -if not !Options.v7 then -GEXTEND Gram - command: - [ [ -(* State management *) - IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s - | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s - | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s - | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s - -(* Resetting *) - | IDENT "Reset"; id = identref -> VernacResetName id - | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial - | IDENT "Back" -> VernacBack 1 - | IDENT "Back"; n = natural -> VernacBack n - -(* Tactic Debugger *) - | IDENT "Debug"; IDENT "On" -> VernacDebug true - | IDENT "Debug"; IDENT "Off" -> VernacDebug false - - ] ]; - END -;; - -(* Grammar extensions *) - -if not !Options.v7 then -GEXTEND Gram - GLOBAL: syntax; - - syntax: - [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,true,sc) - - | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,false,sc) - - | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> - VernacDelimiters (sc,key) - - | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - - | IDENT "Arguments"; IDENT "Scope"; qid = global; - "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) - - | IDENT "Infix"; local = locality; - op = ne_string; ":="; p = global; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (local,(op,modl),p,None,sc) - | IDENT "Notation"; local = locality; id = ident; ":="; c = constr; - b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> - VernacSyntacticDefinition (id,c,local,b) - | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,Some(s,modl),None,sc) - - | IDENT "Tactic"; IDENT "Notation"; s = ne_string; - pil = LIST0 production_item; ":="; t = Tactic.tactic -> - VernacTacticGrammar ["",(s,pil),t] - - | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (local,Some(s,l),None) - - (* "Print" "Grammar" should be here but is in "command" entry in order - to factorize with other "Print"-based vernac entries *) - ] ] - ; - locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; - level: - [ [ IDENT "level"; n = natural -> NumLevel n - | IDENT "next"; IDENT "level" -> NextLevel ] ] - ; - syntax_modifier: - [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) - | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; - lev = level -> SetItemLevel (x::l,lev) - | "at"; IDENT "level"; n = natural -> SetLevel n - | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA - | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA - | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA - | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) - | IDENT "only"; IDENT "parsing" -> SetOnlyParsing - | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ] - ; - syntax_extension_type: - [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference - | IDENT "bigint" -> ETBigint - ] ] - ; - opt_scope: - [ [ "_" -> None | sc = IDENT -> Some sc ] ] - ; - production_item: - [[ s = ne_string -> VTerm s - | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> - VNonTerm (loc,NtShort nt,po) ]] - ; -END - -(* Reinstall tactic and vernac extensions *) -let _ = - if not !Options.v7 then - Egrammar.reset_extend_grammars_v8() diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 new file mode 100644 index 00000000..b4580750 --- /dev/null +++ b/parsing/g_xml.ml4 @@ -0,0 +1,247 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: g_xml.ml4 8624 2006-03-13 17:38:17Z msozeau $ *) + +open Pp +open Util +open Names +open Term +open Pcoq +open Rawterm +open Genarg +open Tacexpr +open Libnames + +open Nametab + +(* Generic xml parser without raw data *) + +type attribute = string * (loc * string) +type xml = XmlTag of loc * string * attribute list * xml list + +let check_tags loc otag ctag = + if otag <> ctag then + user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ + str "does not match open xml tag " ++ str otag) + +let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e) + +GEXTEND Gram + GLOBAL: xml_eoi; + + xml_eoi: + [ [ x = xml; EOI -> x ] ] + ; + xml: + [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml; + "<"; "/"; ctag = IDENT; ">" -> + check_tags loc otag ctag; + XmlTag (loc,ctag,attrs,l) + | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" -> + XmlTag (loc,tag,attrs,[]) + ] ] + ; + attr: + [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ] + ; +END + +(* Interpreting attributes *) + +let nmtoken (loc,a) = + try int_of_string a + with Failure _ -> user_err_loc (loc,"",str "nmtoken expected") + +let interp_xml_attr_qualid = function + | "uri", s -> qualid_of_string s + | _ -> error "Ill-formed xml attribute" + +let get_xml_attr s al = + try List.assoc s al + with Not_found -> error ("No attribute "^s) + +(* Interpreting specific attributes *) + +let ident_of_cdata (loc,a) = id_of_string a + +let uri_of_data s = + let n = String.index s ':' in + let p = String.index s '.' in + let s = String.sub s (n+2) (p-n-2) in + for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done; + qualid_of_string s + +let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a) + +let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a) + +let inductive_of_cdata a = match global_of_cdata a with + | IndRef (kn,_) -> kn + | _ -> failwith "kn" + +let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a)) + +let sort_of_cdata (loc,a) = match a with + | "Prop" -> RProp Null + | "Set" -> RProp Pos + | "Type" -> RType None + | _ -> user_err_loc (loc,"",str "sort expected") + +let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) + +let get_xml_inductive_kn al = inductive_of_cdata (get_xml_attr "uri" al) + +let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) + +let get_xml_inductive al = + (get_xml_inductive_kn al, nmtoken (get_xml_attr "noType" al)) + +let get_xml_constructor al = + (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al)) + +let get_xml_name al = + try Name (ident_of_cdata (List.assoc "binder" al)) + with Not_found -> Anonymous + +let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al) + +let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al) + +(* Interpreting constr as a rawconstr *) + +let rec interp_xml_constr = function + | XmlTag (loc,"REL",al,[]) -> + RVar (loc, get_xml_ident al) + | XmlTag (loc,"VAR",al,[]) -> failwith "" + | XmlTag (loc,"LAMBDA",al,[x1;x2]) -> + let na,t = interp_xml_decl x1 in + RLambda (loc, na, t, interp_xml_target x2) + | XmlTag (loc,"PROD",al,[x1;x2]) -> + let na,t = interp_xml_decl x1 in + RProd (loc, na, t, interp_xml_target x2) + | XmlTag (loc,"LETIN",al,[x1;x2]) -> + let na,t = interp_xml_def x1 in + RLetIn (loc, na, t, interp_xml_target x2) + | XmlTag (loc,"APPLY",_,x::xl) -> + RApp (loc, interp_xml_constr x, List.map interp_xml_constr xl) + | XmlTag (loc,"META",al,xl) -> + failwith "META: TODO" + | XmlTag (loc,"CONST",al,[]) -> + RRef (loc, ConstRef (get_xml_constant al)) + | XmlTag (loc,"MUTCASE",al,x::y::yl) -> (* BUGGE *) + failwith "XML MUTCASE TO DO"; +(* + ROrderedCase (loc,RegularStyle,Some (interp_xml_patternsType x), + interp_xml_inductiveTerm y, + Array.of_list (List.map interp_xml_pattern yl), + ref None) +*) + | XmlTag (loc,"MUTIND",al,[]) -> + RRef (loc, IndRef (get_xml_inductive al)) + | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> + RRef (loc, ConstructRef (get_xml_constructor al)) + | XmlTag (loc,"FIX",al,xl) -> + let li,lnct = List.split (List.map interp_xml_FixFunction xl) in + let ln,lc,lt = list_split3 lnct in + RRec (loc, RFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) + | XmlTag (loc,"COFIX",al,xl) -> + let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in + RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) + | XmlTag (loc,"CAST",al,[x1;x2]) -> + RCast (loc, interp_xml_term x1, DEFAULTcast, interp_xml_type x2) + | XmlTag (loc,"SORT",al,[]) -> + RSort (loc, get_xml_sort al) + | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s) + +and interp_xml_tag s = function + | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl) + | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", + str "Expect tag " ++ str s ++ str " but find " ++ str s) + +and interp_xml_constr_alias s x = + match interp_xml_tag s x with + | (_,_,[x]) -> interp_xml_constr x + | (loc,_,_) -> + user_err_loc (loc,"",str "wrong number of arguments (expect one)") + +and interp_xml_term x = interp_xml_constr_alias "term" x +and interp_xml_type x = interp_xml_constr_alias "type" x +and interp_xml_target x = interp_xml_constr_alias "target" x +and interp_xml_body x = interp_xml_constr_alias "body" x +and interp_xml_pattern x = interp_xml_constr_alias "pattern" x +and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x +and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x + +and interp_xml_decl_alias s x = + match interp_xml_tag s x with + | (_,al,[x]) -> (get_xml_name al, interp_xml_constr x) + | (loc,_,_) -> + user_err_loc (loc,"",str "wrong number of arguments (expect one)") + +and interp_xml_def x = interp_xml_decl_alias "def" x +and interp_xml_decl x = interp_xml_decl_alias "decl" x + +and interp_xml_recursionOrder x = + let (loc, al, l) = interp_xml_tag "RecursionOrder" x in + let (locs, s) = get_xml_attr "type" al in + match s with + "Structural" -> + (match l with [] -> RStructRec + | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected none)")) + | "WellFounded" -> + (match l with + [c] -> RWfRec (interp_xml_type c) + | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)")) + | _ -> + user_err_loc (locs,"",str "invalid recursion order") + + +and interp_xml_FixFunction x = + match interp_xml_tag "FixFunction" x with + | (loc,al,[x1;x2;x3]) -> + ((nmtoken (get_xml_attr "recIndex" al), + interp_xml_recursionOrder x1), + (get_xml_ident al, interp_xml_type x2, interp_xml_body x3)) + | (loc,al,[x1;x2]) -> (* For backwards compatibility *) + ((nmtoken (get_xml_attr "recIndex" al), RStructRec), + (get_xml_ident al, interp_xml_type x1, interp_xml_body x2)) + | (loc,_,_) -> + user_err_loc (loc,"",str "wrong number of arguments (expect one)") + +and interp_xml_CoFixFunction x = + match interp_xml_tag "CoFixFunction" x with + | (loc,al,[x1;x2]) -> + (get_xml_ident al, interp_xml_type x1, interp_xml_body x2) + | (loc,_,_) -> + user_err_loc (loc,"",str "wrong number of arguments (expect one)") + +(* Interpreting tactic argument *) + +let rec (interp_xml_tactic_expr : xml -> glob_tactic_expr) = function + | XmlTag (loc,"TACARG",[],[x]) -> + TacArg (interp_xml_tactic_arg x) + | _ -> error "Ill-formed xml tree" + +and interp_xml_tactic_arg = function + | XmlTag (loc,"TERM",[],[x]) -> + ConstrMayEval (ConstrTerm (interp_xml_constr x,None)) + | XmlTag (loc,"CALL",al,xl) -> + let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in + TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl) +(* + | XmlTag (loc,"TACTIC",[],[x]) -> + Tacexp (interp_xml_tactic_expr x) + | _ -> error "Ill-formed xml tree" +*) + | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s) + +let parse_tactic_arg ch = + interp_xml_tactic_arg + (Pcoq.Gram.Entry.parse xml_eoi + (Pcoq.Gram.parsable (Stream.of_channel ch))) diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml index 2d8d2ddd..554040d1 100644 --- a/parsing/g_zsyntax.ml +++ b/parsing/g_zsyntax.ml @@ -6,148 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_zsyntax.ml,v 1.16.2.2 2004/11/10 13:00:44 herbelin Exp $ *) +(* $Id: g_zsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *) -open Coqast open Pcoq open Pp open Util open Names -open Ast -open Extend open Topconstr open Libnames -open Bignat - -(**********************************************************************) -(* V7 parsing via Grammar *) - -let get_z_sign loc = - let mkid id = - mkRefC (Qualid (loc,Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "xI"), - mkid (id_of_string "xO"), - mkid (id_of_string "xH")), - (mkid (id_of_string "ZERO"), - mkid (id_of_string "POS"), - mkid (id_of_string "NEG"))) - -let pos_of_bignat xI xO xH x = - let rec pos_of x = - match div2_with_rest x with - | (q, true) when is_nonzero q -> mkAppC (xI, [pos_of q]) - | (q, false) -> mkAppC (xO, [pos_of q]) - | (_, true) -> xH - in - pos_of x - -let z_of_string pos_or_neg s dloc = - let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in - let v = Bignat.of_string s in - if is_nonzero v then - if pos_or_neg then - mkAppC (aPOS, [pos_of_bignat xI xO xH v]) - else - mkAppC (aNEG, [pos_of_bignat xI xO xH v]) - else - aZERO - -(* Declare the primitive parser with Grammar and without the scope mechanism *) -let zsyntax_create name = - let e = - Pcoq.create_constr_entry (Pcoq.get_univ "znatural") name in - Pcoq.Gram.Unsafe.clear_entry e; - e - -let number = zsyntax_create "number" - -let negnumber = zsyntax_create "negnumber" - -let _ = - Gram.extend number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action (z_of_string true)]] - -let _ = - Gram.extend negnumber None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action (z_of_string false)]] - -(**********************************************************************) -(* Old v7 ast printing *) - -open Coqlib +open Bigint exception Non_closed_number -let get_z_sign_ast loc = - let ast_of_id id = - Termast.ast_of_ref - (reference_of_constr - (gen_constant_in_modules "Z-printer" zarith_base_modules id)) - in - ((ast_of_id "xI", - ast_of_id "xO", - ast_of_id "xH"), - (ast_of_id "ZERO", - ast_of_id "POS", - ast_of_id "NEG")) - -let _ = if !Options.v7 then -let rec bignat_of_pos c1 c2 c3 p = - match p with - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) -> - mult_2 (bignat_of_pos c1 c2 c3 a) - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c2) -> - add_1 (mult_2 (bignat_of_pos c1 c2 c3 a)) - | a when alpha_eq(a,c3) -> Bignat.one - | _ -> raise Non_closed_number -in -let bignat_option_of_pos xI xO xH p = - try - Some (bignat_of_pos xO xI xH p) - with Non_closed_number -> - None -in -let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) in -let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) in - -let inside_printer posneg std_pr p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - match (bignat_option_of_pos xI xO xH p) with - | Some n -> - if posneg then - (str (Bignat.to_string n)) - else - (str "(-" ++ str (Bignat.to_string n) ++ str ")") - | None -> - let pr = if posneg then pr_pos else pr_neg in - str "(" ++ pr (std_pr (ope("ZEXPR",[p]))) ++ str ")" -in -let outside_zero_printer std_pr p = str "`0`" -in -let outside_printer posneg std_pr p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - match (bignat_option_of_pos xI xO xH p) with - | Some n -> - if posneg then - (str "`" ++ str (Bignat.to_string n) ++ str "`") - else - (str "`-" ++ str (Bignat.to_string n) ++ str "`") - | None -> - let pr = if posneg then pr_pos else pr_neg in - str "(" ++ pr (std_pr p) ++ str ")" -in -(* For printing with Syntax and without the scope mechanism *) -let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) in -let _ = Esyntax.Ppprim.add ("negative_printer", (outside_printer false)) in -let _ = Esyntax.Ppprim.add ("positive_printer_inside", (inside_printer true))in -let _ = Esyntax.Ppprim.add ("negative_printer_inside", (inside_printer false)) -in () - (**********************************************************************) (* Parsing positive via scopes *) (**********************************************************************) @@ -156,16 +26,19 @@ open Libnames open Rawterm let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) let positive_module = ["Coq";"NArith";"BinPos"] +let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) + +let positive_path = make_path positive_module "positive" (* TODO: temporary hack *) -let make_path dir id = Libnames.encode_kn dir id - -let positive_path = - make_path (make_dir positive_module) (id_of_string "positive") -let glob_positive = IndRef (positive_path,0) -let path_of_xI = ((positive_path,0),1) -let path_of_xO = ((positive_path,0),2) -let path_of_xH = ((positive_path,0),3) +let make_kn dir id = Libnames.encode_kn dir id + +let positive_kn = + make_kn (make_dir positive_module) (id_of_string "positive") +let glob_positive = IndRef (positive_kn,0) +let path_of_xI = ((positive_kn,0),1) +let path_of_xO = ((positive_kn,0),2) +let path_of_xH = ((positive_kn,0),3) let glob_xI = ConstructRef path_of_xI let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH @@ -177,34 +50,18 @@ let pos_of_bignat dloc x = let rec pos_of x = match div2_with_rest x with | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) - | (q,true) when is_nonzero q -> RApp (dloc,ref_xI,[pos_of q]) + | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x -let interp_positive dloc = function - | POS n when is_nonzero n -> pos_of_bignat dloc n - | _ -> - user_err_loc (dloc, "interp_positive", - str "Only strictly positive numbers in type \"positive\"!") - -let rec pat_pos_of_bignat dloc x name = - match div2_with_rest x with - | (q,false) -> - PatCstr (dloc,path_of_xO,[pat_pos_of_bignat dloc q Anonymous],name) - | (q,true) when is_nonzero q -> - PatCstr (dloc,path_of_xI,[pat_pos_of_bignat dloc q Anonymous],name) - | (q,true) -> - PatCstr (dloc,path_of_xH,[],name) - let error_non_positive dloc = user_err_loc (dloc, "interp_positive", - str "No non-positive numbers in type \"positive\"!") + str "Only strictly positive numbers in type \"positive\"") -let pat_interp_positive dloc = function - | NEG n -> error_non_positive dloc - | POS n -> - if is_nonzero n then pat_pos_of_bignat dloc n else error_non_positive dloc +let interp_positive dloc n = + if is_strictly_pos n then pos_of_bignat dloc n + else error_non_positive dloc (**********************************************************************) (* Printing positive via scopes *) @@ -213,12 +70,12 @@ let pat_interp_positive dloc = function let rec bignat_of_pos = function | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) - | RRef (_, a) when a = glob_xH -> Bignat.one + | RRef (_, a) when a = glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = try - Some (POS (bignat_of_pos p)) + Some (bignat_of_pos p) with Non_closed_number -> None @@ -226,61 +83,49 @@ let uninterp_positive p = (* Declaring interpreters and uninterpreters for positive *) (************************************************************************) -let _ = Symbols.declare_numeral_interpreter "positive_scope" - (glob_positive,positive_module) - (interp_positive,Some pat_interp_positive) - ([RRef (dummy_loc, glob_xI); +let _ = Notation.declare_numeral_interpreter "positive_scope" + (positive_path,positive_module) + interp_positive + ([RRef (dummy_loc, glob_xI); RRef (dummy_loc, glob_xO); RRef (dummy_loc, glob_xH)], uninterp_positive, - None) + true) (**********************************************************************) (* Parsing N via scopes *) (**********************************************************************) let binnat_module = ["Coq";"NArith";"BinNat"] -let n_path = make_path (make_dir binnat_module) - (id_of_string (if !Options.v7 then "entier" else "N")) -let glob_n = IndRef (n_path,0) -let path_of_N0 = ((n_path,0),1) -let path_of_Npos = ((n_path,0),2) +let n_kn = make_kn (make_dir binnat_module) (id_of_string "N") +let glob_n = IndRef (n_kn,0) +let path_of_N0 = ((n_kn,0),1) +let path_of_Npos = ((n_kn,0),2) let glob_N0 = ConstructRef path_of_N0 let glob_Npos = ConstructRef path_of_Npos -let n_of_posint dloc pos_or_neg n = - if is_nonzero n then +let n_path = make_path binnat_module "N" + +let n_of_binnat dloc pos_or_neg n = + if n <> zero then RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) else RRef (dloc, glob_N0) -let n_of_int dloc n = - match n with - | POS n -> n_of_posint dloc true n - | NEG n -> - user_err_loc (dloc, "", - str "No negative number in type N") - -let pat_n_of_binnat dloc n name = - if is_nonzero n then - PatCstr (dloc, path_of_Npos, [pat_pos_of_bignat dloc n Anonymous], name) - else - PatCstr (dloc, path_of_N0, [], name) +let error_negative dloc = + user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\"") -let pat_n_of_int dloc n name = - match n with - | POS n -> pat_n_of_binnat dloc n name - | NEG n -> - user_err_loc (dloc, "", - str "No negative number in type N") +let n_of_int dloc n = + if is_pos_or_zero n then n_of_binnat dloc true n + else error_negative dloc (**********************************************************************) (* Printing N via scopes *) (**********************************************************************) let bignat_of_n = function - | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> POS (bignat_of_pos a) - | RRef (_, a) when a = glob_N0 -> POS (Bignat.zero) + | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a + | RRef (_, a) when a = glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = @@ -290,60 +135,45 @@ let uninterp_n p = (************************************************************************) (* Declaring interpreters and uninterpreters for N *) -let _ = Symbols.declare_numeral_interpreter "N_scope" - (glob_n,binnat_module) - (n_of_int,Some pat_n_of_int) +let _ = Notation.declare_numeral_interpreter "N_scope" + (n_path,binnat_module) + n_of_int ([RRef (dummy_loc, glob_N0); RRef (dummy_loc, glob_Npos)], uninterp_n, - None) + true) (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) -let fast_integer_module = ["Coq";"ZArith";"BinInt"] -let z_path = make_path (make_dir fast_integer_module) (id_of_string "Z") -let glob_z = IndRef (z_path,0) -let path_of_ZERO = ((z_path,0),1) -let path_of_POS = ((z_path,0),2) -let path_of_NEG = ((z_path,0),3) +let binint_module = ["Coq";"ZArith";"BinInt"] +let z_path = make_path binint_module "Z" +let z_kn = make_kn (make_dir binint_module) (id_of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG -let z_of_posint dloc pos_or_neg n = - if is_nonzero n then - let sgn = if pos_or_neg then glob_POS else glob_NEG in +let z_of_int dloc n = + if n <> zero then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) else RRef (dloc, glob_ZERO) -let z_of_int dloc z = - match z with - | POS n -> z_of_posint dloc true n - | NEG n -> z_of_posint dloc false n - -let pat_z_of_posint dloc pos_or_neg n name = - if is_nonzero n then - let sgn = if pos_or_neg then path_of_POS else path_of_NEG in - PatCstr (dloc, sgn, [pat_pos_of_bignat dloc n Anonymous], name) - else - PatCstr (dloc, path_of_ZERO, [], name) - -let pat_z_of_int dloc n name = - match n with - | POS n -> pat_z_of_posint dloc true n name - | NEG n -> pat_z_of_posint dloc false n name - (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | RApp (_, RRef (_,b),[a]) when b = glob_POS -> POS (bignat_of_pos a) - | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> NEG (bignat_of_pos a) - | RRef (_, a) when a = glob_ZERO -> POS (Bignat.zero) + | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a + | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) + | RRef (_, a) when a = glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = @@ -354,56 +184,11 @@ let uninterp_z p = (************************************************************************) (* Declaring interpreters and uninterpreters for Z *) -let _ = Symbols.declare_numeral_interpreter "Z_scope" - (glob_z,fast_integer_module) - (z_of_int,Some pat_z_of_int) +let _ = Notation.declare_numeral_interpreter "Z_scope" + (z_path,binint_module) + z_of_int ([RRef (dummy_loc, glob_ZERO); RRef (dummy_loc, glob_POS); RRef (dummy_loc, glob_NEG)], uninterp_z, - None) - -(************************************************************************) -(* Old V7 ast Printers *) - -open Esyntax - -let _ = if !Options.v7 then -let bignat_of_pos p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - let c1 = xO in - let c2 = xI in - let c3 = xH in - let rec transl = function - | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a) - | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a)) - | a when alpha_eq(a,c3) -> Bignat.one - | _ -> raise Non_closed_number - in transl p -in -let bignat_option_of_pos p = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None -in -let z_printer posneg p = - match bignat_option_of_pos p with - | Some n -> - if posneg then - Some (str (Bignat.to_string n)) - else - Some (str "-" ++ str (Bignat.to_string n)) - | None -> None -in -let z_printer_ZERO _ = - Some (int 0) -in -(* Declare pretty-printers for integers *) -let _ = - declare_primitive_printer "z_printer_POS" "Z_scope" (z_printer true) in -let _ = - declare_primitive_printer "z_printer_NEG" "Z_scope" (z_printer false) in -let _ = - declare_primitive_printer "z_printer_ZERO" "Z_scope" z_printer_ZERO in -() + true) diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli index 6a7aeb14..11e0b6ac 100644 --- a/parsing/g_zsyntax.mli +++ b/parsing/g_zsyntax.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_zsyntax.mli,v 1.6.6.1 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_zsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Nice syntax for integers. *) diff --git a/parsing/g_zsyntaxnew.mli b/parsing/g_zsyntaxnew.mli index 51bb6d41..5168722e 100644 --- a/parsing/g_zsyntaxnew.mli +++ b/parsing/g_zsyntaxnew.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: g_zsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: g_zsyntaxnew.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Nice syntax for integers. *) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index bf5f3bfe..6119b86e 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lexer.ml4,v 1.24.2.6 2004/07/16 20:51:12 herbelin Exp $ i*) +(*i $Id: lexer.ml4 7870 2006-01-15 20:29:09Z herbelin $ i*) open Pp open Token @@ -82,23 +82,22 @@ let check_ident str = let rec loop_id = parser | [< ' ('$' | 'a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_'); s >] -> loop_id s - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207'); ' ('\128'..'\191'); s >] -> loop_id s - | [< ''\226'; 'c2; 'c3; s >] -> + (* utf-8 Greek letters U0380-03FF *) + | [< ' ('\xCE' | '\xCF'); ' ('\x80'..'\xBF'); s >] -> loop_id s + | [< ''\xE2'; 'c2; 'c3; s >] -> (match c2, c3 with - (* utf8 letter-like unicode 2100-214F *) - | (('\132', '\128'..'\191') | ('\133', '\128'..'\143')) -> + (* utf-8 letter-like U2100-214F *) + | ( ('\x84', '\x80'..'\xBF') + | ('\x85', '\x80'..'\x8F') + (* utf-8 subscript U2080-2089 *) + | ('\x82', '\x80'..'\x89')) -> loop_id s - (* utf8 symbols (see [parse_226_tail]) *) - | (('\134'..'\143' | '\152'..'\155' | '\159' - | '\164'..'\171'),_) -> + (* utf-8 symbols (see [parse_226_tail]) *) + | (('\x86'..'\x8F' | '\x94'..'\x9B' + | '\xA4'..'\xA5' | '\xA8'..'\xAB'),_) -> bad_token str - | _ -> (* default to iso 8859-1 "â" *) - if !Options.v7 then loop_id [< 'c2; 'c3; s >] - else bad_token str) - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255'); s >] -> - if !Options.v7 then loop_id s else bad_token str + | _ -> + bad_token str) | [< _ = Stream.empty >] -> () | [< >] -> bad_token str in @@ -170,27 +169,26 @@ let get_buff len = String.sub !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) -let rec ident_tail len strm = - if !Options.v7 then - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' | '@' as c); s >] -> - ident_tail (store len c) s - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> - ident_tail (store (store len c1) c2) s - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); s >] -> - ident_tail (store len c) s - | [< >] -> len - else - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> - ident_tail (store len c) s - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> - ident_tail (store (store len c1) c2) s - | [< >] -> len - +let rec ident_tail len = parser + | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> + ident_tail (store len c) s + (* utf-8 Greek letters U0380-03FF *) + | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' as c2) ; s >] -> + ident_tail (store (store len c1) c2) s + | [< s >] -> + match Stream.peek s with + | Some '\xE2' -> + (match List.tl (Stream.npeek 3 s) with + (* utf-8 subscript U2080-2089 *) + | ['\x82' as c2; ('\x80'..'\x89' as c3)] + (* utf-8 letter-like U2100-214F part 1 *) + | ['\x84' as c2; ('\x80'..'\xBF' as c3)] + (* utf-8 letter-like U2100-214F part 2 *) + | ['\x85' as c2; ('\x80'..'\x8F' as c3)] -> + Stream.junk s; Stream.junk s; Stream.junk s; + ident_tail (store (store (store len '\xE2') c2) c3) s + | _ -> len) + | _ -> len let rec number len = parser | [< ' ('0'..'9' as c); s >] -> number (store len c) s @@ -198,21 +196,11 @@ let rec number len = parser let escape len c = store len c -let rec string_v8 bp len = parser +let rec string bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> - if esc then string_v8 bp (store len '"') s else len - | [< 'c; s >] -> string_v8 bp (store len c) s - | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string - -let rec string_v7 bp len = parser - | [< ''"' >] -> len - | [< ''\\'; c = (parser [< ' ('"' | '\\' as c) >] -> c | [< >] -> '\\'); s >] - -> string_v7 bp (escape len c) s + if esc then string bp (store len '"') s else len + | [< 'c; s >] -> string bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string - | [< 'c; s >] -> string_v7 bp (store len c) s - -let string bp len s = - if !Options.v7 then string_v7 bp len s else string_v8 bp len s (* Hook for exporting comment into xml theory files *) let xml_output_comment = ref (fun _ -> ()) @@ -293,14 +281,14 @@ let rec comment bp = parser bp2 s >] -> comment bp s | [< ''*'; _ = parser - | [< '')' >] ep -> push_string "*)"; + | [< '')' >] -> push_string "*)"; | [< s >] -> real_push_char '*'; comment bp s >] -> () | [< ''"'; s >] -> if Options.do_translate() then (push_string"\"";comm_string bp2 s) else ignore (string bp2 0 s); comment bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment - | [< '_ as z; s >] ep -> real_push_char z; comment bp s + | [< 'z; s >] -> real_push_char z; comment bp s (* Parse a special token, using the [token_tree] *) @@ -334,100 +322,81 @@ type token_226_tail = | TokSymbol of string option | TokIdent of string +(* 1110xxxx 10yyyyzz 10zztttt utf-8 codes for xxxx=0010 *) let parse_226_tail tk = parser - | [< ''\132' as c2; ' ('\128'..'\191' as c3); - (* utf8 letter-like unicode 2100-214F *) - len = ident_tail (store (store (store 0 '\226') c2) c3) >] -> + | [< ''\x82' as c2; ' ('\x80'..'\x89' as c3); + (* utf-8 subscript U2080-2089 *) + len = ident_tail (store (store (store 0 '\xE2') c2) c3) >] -> + TokIdent (get_buff len) + | [< ''\x84' as c2; ' ('\x80'..'\xBF' as c3); + (* utf-8 letter-like U2100-214F part 1 *) + len = ident_tail (store (store (store 0 '\xE2') c2) c3) >] -> TokIdent (get_buff len) - | [< ''\133' as c2; ' ('\128'..'\143' as c3); - (* utf8 letter-like unicode 2100-214F *) - len = ident_tail (store (store (store 0 '\226') c2) c3) >] -> + | [< ''\x85' as c2; ' ('\x80'..'\x8F' as c3); + (* utf-8 letter-like U2100-214F part 2 *) + len = ident_tail (store (store (store 0 '\xE2') c2) c3) >] -> TokIdent (get_buff len) - | [< ' ('\134'..'\143' | '\152'..'\155' | '\159' - | '\164'..'\171' as c2); 'c3; - (* utf8 arrows A unicode 2190-21FF *) - (* utf8 mathematical operators unicode 2200-22FF *) - (* utf8 miscellaneous technical unicode 2300-23FF *) - (* utf8 miscellaneous symbols unicode 2600-26FF *) - (* utf8 Miscellaneous Mathematical Symbols-A unicode 27C0-27DF *) - (* utf8 Supplemental Arrows-A unicode 27E0-27FF *) - (* utf8 Supplemental Arrows-B unicode 2900-297F *) - (* utf8 Miscellaneous Mathematical Symbols-B unicode 2980-29FF *) - (* utf8 mathematical operators unicode 2A00-2AFF *) + | [< ' ('\x86'..'\x8F' | '\x94'..'\x9B' | '\xA4'..'\xA5' + | '\xA8'..'\xAB' as c2); 'c3; + (* utf-8 arrows A U2190-21FF *) + (* utf-8 mathematical operators U2200-22FF *) + (* utf-8 miscellaneous technical U2300-23FF *) + (* utf-8 box drawing U2500-257F has ceiling, etc. *) + (* utf-8 block elements U2580-259F *) + (* utf-8 geom. shapes U25A0-25FF (has triangles, losange, etc) *) + (* utf-8 miscellaneous symbols U2600-26FF *) + (* utf-8 arrows B U2900-297F *) + (* utf-8 mathematical operators U2A00-2AFF *) t = special (progress_special c3 (progress_special c2 - (progress_special '\226' tk))) >] -> + (progress_special '\xE2' tk))) >] -> TokSymbol t - | [< len = ident_tail (store 0 '\226') >] -> - TokIdent (get_buff len) - + | [< '_; '_ >] -> + (* Unsupported utf-8 code *) + TokSymbol None (* Parse what follows a dot *) -let parse_after_dot bp c strm = - if !Options.v7 then - match strm with parser - | [< ' ('_' | 'a'..'z' | 'A'..'Z' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); - len = ident_tail (store (store 0 c1) c2) >] -> - ("FIELD", get_buff len) - (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) - | [< ''\226' as c1; t = parse_226_tail - (progress_special '.' (Some !token_tree)) >] ep -> - (match t with - | TokSymbol (Some t) -> ("", t) - | TokSymbol None -> err (bp, ep) Undefined_token - | TokIdent t -> ("FIELD", t)) - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - | [< (t,_) = process_chars bp c >] -> t - else - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); - len = ident_tail (store (store 0 c1) c2) >] -> - ("FIELD", get_buff len) - (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) - | [< ''\226' as c1; t = parse_226_tail - (progress_special '.' (Some !token_tree)) >] ep -> - (match t with - | TokSymbol (Some t) -> ("", t) - | TokSymbol None -> err (bp, ep) Undefined_token - | TokIdent t -> ("FIELD", t)) - | [< (t,_) = process_chars bp c >] -> t +let parse_after_dot bp c = parser + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); + len = ident_tail (store 0 c) >] -> + ("FIELD", get_buff len) + (* utf-8 Greek letters U0380-03FF *) + | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' as c2); + len = ident_tail (store (store 0 c1) c2) >] -> + ("FIELD", get_buff len) + (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) + | [< ''\xE2'; t = parse_226_tail + (progress_special '.' (Some !token_tree)) >] ep -> + (match t with + | TokSymbol (Some t) -> ("", t) + | TokSymbol None -> err (bp, ep) Undefined_token + | TokIdent t -> ("FIELD", t)) + | [< (t,_) = process_chars bp c >] -> t (* Parse a token in a char stream *) let rec next_token = parser bp - | [< '' ' | '\t' | '\n' |'\r' as c; s >] ep -> + | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s | [< ''$'; len = ident_tail (store 0 '$') >] ep -> comment_stop bp; (("METAIDENT", get_buff len), (bp,ep)) | [< ''.' as c; t = parse_after_dot bp c >] ep -> comment_stop bp; - if !Options.v7 & t=("",".") then between_com := true; (t, (bp,ep)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ep -> let id = get_buff len in comment_stop bp; (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); + (* utf-8 Greek letters U0380-03FF [CE80-CEBF and CF80-CFBF] *) + | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' as c2); len = ident_tail (store (store 0 c1) c2) >] ep -> let id = get_buff len in comment_stop bp; (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) - | [< ''\226' as c1; t = parse_226_tail (Some !token_tree) >] ep -> + | [< ''\xE2'; t = parse_226_tail (Some !token_tree) >] ep -> comment_stop bp; (match t with | TokSymbol (Some t) -> ("", t), (bp, ep) @@ -435,21 +404,6 @@ let rec next_token = parser bp | TokIdent id -> (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)) - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; s >] -> - if !Options.v7 then - begin - match s with parser - [< len = ident_tail (store 0 c) >] ep -> - let id = get_buff len in - comment_stop bp; - (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) - end - else - begin - match s with parser - [< t = process_chars bp c >] -> comment_stop bp; t - end | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> comment_stop bp; (("INT", get_buff len), (bp, ep)) @@ -537,3 +491,41 @@ let tparse (p_con, p_prm) = else (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm) i*) + +(* Terminal symbols interpretation *) + +let is_ident_not_keyword s = + match s.[0] with + | 'a'..'z' | 'A'..'Z' | '_' -> not (is_keyword s) + | _ -> false + +let is_number s = + match s.[0] with + | '0'..'9' -> true + | _ -> false + +let strip s = + let len = + let rec loop i len = + if i = String.length s then len + else if s.[i] == ' ' then loop (i + 1) len + else loop (i + 1) (len + 1) + in + loop 0 0 + in + if len == String.length s then s + else + let s' = String.create len in + let rec loop i i' = + if i == String.length s then s' + else if s.[i] == ' ' then loop (i + 1) i' + else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end + in + loop 0 0 + +let terminal s = + let s = strip s in + if s = "" then failwith "empty token"; + if is_ident_not_keyword s then ("IDENT", s) + else if is_number s then ("INT", s) + else ("", s) diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 133bca65..f1ab6446 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lexer.mli,v 1.20.2.2 2004/07/16 19:30:39 herbelin Exp $ i*) +(*i $Id: lexer.mli 7732 2005-12-26 13:51:24Z herbelin $ i*) open Pp open Util @@ -48,3 +48,5 @@ val com_state: unit -> com_state val restore_com_state: com_state -> unit val set_xml_output_comment : (string -> unit) -> unit + +val terminal : string -> string * string diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index a8922536..d743fffa 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -6,19 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pcoq.ml4,v 1.80.2.4 2005/06/21 15:31:12 herbelin Exp $ i*) +(*i $Id: pcoq.ml4 7826 2006-01-09 22:00:34Z herbelin $ i*) open Pp open Util open Names +open Extend open Libnames open Rawterm open Topconstr -open Ast open Genarg open Tacexpr open Ppextend -open Extend (* The lexer of Coq *) @@ -52,7 +51,7 @@ let grammar_delete e rls = List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) (List.rev rls) -(* grammar_object is the superclass of all grammar entry *) +(* grammar_object is the superclass of all grammar entries *) module type Gramobj = sig type grammar_object @@ -65,8 +64,9 @@ struct let weaken_entry e = Obj.magic e end +type entry_type = argument_type type grammar_object = Gramobj.grammar_object -type typed_entry = entry_type * grammar_object G.Entry.e +type typed_entry = argument_type * grammar_object G.Entry.e let in_typed_entry t e = (t,Gramobj.weaken_entry e) let type_of_typed_entry (t,e) = t let object_of_typed_entry (t,e) = e @@ -182,7 +182,6 @@ let create_univ s = let uprim = create_univ "prim" let uconstr = create_univ "constr" -let umodule = create_univ "module" let utactic = create_univ "tactic" let uvernac = create_univ "vernac" @@ -311,10 +310,7 @@ module Prim = let reference = make_gen_entry uprim rawwit_ref "reference" (* parsed like ident but interpreted as a term *) - let hyp = gec_gen rawwit_ident "hyp" - - (* synonym of hyp/ident (before semantics split) for v7 compatibility *) - let var = gec_gen rawwit_ident "var" + let var = gec_gen rawwit_var "var" let name = Gram.Entry.create "Prim.name" let identref = Gram.Entry.create "Prim.identref" @@ -323,16 +319,11 @@ module Prim = let base_ident = Gram.Entry.create "Prim.base_ident" let qualid = Gram.Entry.create "Prim.qualid" + let fullyqualid = Gram.Entry.create "Prim.fullyqualid" let dirpath = Gram.Entry.create "Prim.dirpath" let ne_string = Gram.Entry.create "Prim.ne_string" - (* For old ast printer *) - let astpat = Gram.Entry.create "Prim.astpat" - let ast = Gram.Entry.create "Prim.ast" - let astlist = Gram.Entry.create "Prim.astlist" - let ast_eoi = eoi_entry ast - let astact = Gram.Entry.create "Prim.astact" end @@ -372,15 +363,14 @@ module Tactic = (* Entries that can be refered via the string -> Gram.Entry.e table *) (* Typically for tactic user extensions *) let open_constr = - make_gen_entry utactic rawwit_open_constr "open_constr" - let castedopenconstr = - make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr" + make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr" + let casted_open_constr = + make_gen_entry utactic (rawwit_open_constr_gen true) "casted_open_constr" let constr_with_bindings = make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings" let bindings = make_gen_entry utactic rawwit_bindings "bindings" -(*v7*) let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg" -(*v8*) let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval" + let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval" let quantified_hypothesis = make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis" let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var" @@ -390,10 +380,14 @@ module Tactic = (* Main entries for ltac *) let tactic_arg = Gram.Entry.create "tactic:tactic_arg" - let tactic = make_gen_entry utactic rawwit_tactic "tactic" + let tactic_expr = Gram.Entry.create "tactic:tactic_expr" + + let tactic_main_level = 5 + let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic" (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic + end @@ -411,32 +405,6 @@ module Vernac_ = let vernac_eoi = eoi_entry vernac end - -(* Prim is not re-initialized *) -let reset_all_grammars () = - let f = Gram.Unsafe.clear_entry in - List.iter f - [Constr.constr;Constr.operconstr;Constr.lconstr;Constr.annot; - Constr.constr_pattern;Constr.lconstr_pattern]; - f Constr.ident; f Constr.global; f Constr.sort; f Constr.pattern; - f Module.module_expr; f Module.module_type; - f Tactic.simple_tactic; - f Tactic.castedopenconstr; - f Tactic.constr_with_bindings; - f Tactic.bindings; - f Tactic.constrarg; - f Tactic.quantified_hypothesis; - f Tactic.int_or_var; - f Tactic.red_expr; - f Tactic.tactic_arg; - f Tactic.tactic; - f Vernac_.gallina; - f Vernac_.gallina_ext; - f Vernac_.command; - f Vernac_.syntax; - f Vernac_.vernac; - Lexer.init() - let main_entry = Gram.Entry.create "vernac" GEXTEND Gram @@ -445,88 +413,6 @@ GEXTEND Gram ; END -(* Quotations *) - -open Prim -open Constr -open Tactic -open Vernac_ - -(* current file and toplevel/vernac.ml *) -let globalizer = ref (fun x -> failwith "No globalizer") -let set_globalizer f = globalizer := f - -let define_ast_quotation default s (e:Coqast.t G.Entry.e) = - (if default then - GEXTEND Gram - ast: [ [ "<<"; c = e; ">>" -> c ] ]; - (* Uncomment this to keep compatibility with old grammar syntax - constr: [ [ "<<"; c = e; ">>" -> c ] ]; - vernac: [ [ "<<"; c = e; ">>" -> c ] ]; - tactic: [ [ "<<"; c = e; ">>" -> c ] ]; - *) - END); - (GEXTEND Gram - GLOBAL: ast constr command tactic; - ast: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - (* Uncomment this to keep compatibility with old grammar syntax - constr: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - command: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - tactic: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - *) - END) - -(* -let _ = define_ast_quotation false "ast" ast in () -*) - -let dynconstr = Gram.Entry.create "Constr.dynconstr" -let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern" - -GEXTEND Gram - dynconstr: - [ [ a = Constr.constr -> ConstrNode a - (* For compatibility *) - | "<<"; a = Constr.lconstr; ">>" -> ConstrNode a ] ] - ; - dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ]; -END - -(**********************************************************************) -(* The following is to dynamically set the parser in Grammar actions *) -(* and Syntax pattern, according to the universe of the rule defined *) - -type parser_type = - | ConstrParser - | CasesPatternParser - -let default_action_parser_ref = ref dynconstr - -let get_default_action_parser () = !default_action_parser_ref - -let entry_type_of_parser = function - | ConstrParser -> Some ConstrArgType - | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO" - -let parser_type_from_name = function - | "constr" -> ConstrParser - | "cases_pattern" -> CasesPatternParser - | "tactic" -> assert false - | "vernac" -> error "No longer supported" - | s -> ConstrParser - -let set_default_action_parser = function - | ConstrParser -> default_action_parser_ref := dynconstr - | CasesPatternParser -> default_action_parser_ref := dyncasespattern - -let default_action_parser = - Gram.Entry.of_parser "default_action_parser" - (fun strm -> Gram.Entry.parse_token (get_default_action_parser ()) strm) - (**********************************************************************) (* This determines (depending on the associativity of the current level and on the expected associativity) if a reference to constr_n is @@ -536,24 +422,9 @@ let default_action_parser = translated in camlp4 into "constr" without level) or to another level (to be translated into "constr LEVEL n") *) -let assoc_level = function - | Some Gramext.LeftA when !Options.v7 -> "L" - | _ -> "" - -let constr_level = function - | n,assoc -> (string_of_int n)^(assoc_level assoc) - -let constr_level2 = function - | n,assoc -> (string_of_int n)^(assoc_level (Some assoc)) - -let default_levels_v7 = - [10,Gramext.RightA; - 9,Gramext.RightA; - 8,Gramext.RightA; - 1,Gramext.RightA; - 0,Gramext.RightA] +let constr_level = string_of_int -let default_levels_v8 = +let default_levels = [200,Gramext.RightA; 100,Gramext.RightA; 99,Gramext.RightA; @@ -563,20 +434,16 @@ let default_levels_v8 = 1,Gramext.LeftA; 0,Gramext.RightA] -let default_pattern_levels_v8 = +let default_pattern_levels = [10,Gramext.LeftA; 0,Gramext.RightA] let level_stack = - ref - [if !Options.v7 then (default_levels_v7, default_levels_v7) - else (default_levels_v8, default_pattern_levels_v8)] + ref [(default_levels, default_pattern_levels)] (* At a same level, LeftA takes precedence over RightA and NoneA *) (* In case, several associativity exists for a level, we make two levels, *) (* first LeftA, then RightA and NoneA together *) -exception Found of Gramext.g_assoc - open Ppextend let admissible_assoc = function @@ -599,48 +466,35 @@ let error_level_assoc p current expected = pr_assoc expected ++ str " associative") let find_position forpat other assoc lev = - let default = if !Options.v7 then Some (10,Gramext.RightA) else None in let ccurrent,pcurrent as current = List.hd !level_stack in match lev with | None -> level_stack := current :: !level_stack; None, (if other then assoc else None), None | Some n -> - if !Options.v7 & n = 8 & assoc = Some Gramext.LeftA then - error "Left associativity not allowed at level 8"; - let after = ref default in + let after = ref None in let rec add_level q = function - | (p,_ as pa)::l when p > n -> pa :: add_level (Some pa) l - | (p,a as pa)::l as l' when p = n -> - if admissible_assoc (a,assoc) then raise (Found a); - (* No duplication of levels in v8 *) - if not !Options.v7 then error_level_assoc p a (out_some assoc); - (* Maybe this was (p,Left) and p occurs a second time *) - if a = Gramext.LeftA then - match l with - | (p,a)::_ as l' when p = n -> raise (Found a) - | _ -> after := Some pa; pa::(n,create_assoc assoc)::l - else - (* This was not (p,LeftA) hence assoc is RightA *) - (after := q; (n,create_assoc assoc)::l') - | l -> - after := q; (n,create_assoc assoc)::l + | (p,_ as pa)::l when p > n -> pa :: add_level (Some p) l + | (p,a)::l when p = n -> + if admissible_assoc (a,assoc) then raise Exit; + error_level_assoc p a (out_some assoc) + | l -> after := q; (n,create_assoc assoc)::l in try (* Create the entry *) let updated = - if forpat then (ccurrent, add_level default pcurrent) - else (add_level default ccurrent, pcurrent) in + if forpat then (ccurrent, add_level None pcurrent) + else (add_level None ccurrent, pcurrent) in level_stack := updated:: !level_stack; let assoc = create_assoc assoc in (if !after = None then Some Gramext.First - else Some (Gramext.After (constr_level2 (out_some !after)))), - Some assoc, Some (constr_level2 (n,assoc)) + else Some (Gramext.After (constr_level (out_some !after)))), + Some assoc, Some (constr_level n) with - Found a -> + Exit -> level_stack := current :: !level_stack; (* Just inherit the existing associativity and name (None) *) - Some (Gramext.Level (constr_level2 (n,a))), None, None + Some (Gramext.Level (constr_level n)), None, None let remove_levels n = level_stack := list_skipn n !level_stack @@ -663,19 +517,19 @@ let adjust_level assoc from = function | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) (* Compute production name on the right side *) (* If NonA or LeftA on the right-hand side, set to NEXT *) - | (NumLevel n,BorderProd (false,Some (Gramext.NonA|Gramext.LeftA))) -> + | (NumLevel n,BorderProd (Right,Some (Gramext.NonA|Gramext.LeftA))) -> Some None (* If RightA on the right-hand side, set to the explicit (current) level *) - | (NumLevel n,BorderProd (false,Some Gramext.RightA)) -> + | (NumLevel n,BorderProd (Right,Some Gramext.RightA)) -> Some (Some (n,true)) (* Compute production name on the left side *) (* If NonA on the left-hand side, adopt the current assoc ?? *) - | (NumLevel n,BorderProd (true,Some Gramext.NonA)) -> None + | (NumLevel n,BorderProd (Left,Some Gramext.NonA)) -> None (* If the expected assoc is the current one, set to SELF *) - | (NumLevel n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> + | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc -> None (* Otherwise, force the level, n or n-1, according to expected assoc *) - | (NumLevel n,BorderProd (true,Some a)) -> + | (NumLevel n,BorderProd (Left,Some a)) -> if a = Gramext.LeftA then Some (Some (n,true)) else Some None (* None means NEXT *) | (NextLevel,_) -> Some None @@ -686,39 +540,11 @@ let adjust_level assoc from = function | ETConstr (p,()) -> Some (Some (n,n=p)) | _ -> Some (Some (n,false)) -(* - (* If NonA on the right-hand side, set to NEXT *) - | (n,BorderProd (false,Some Gramext.NonA)) -> Some None - (* If NonA on the left-hand side, adopt the current assoc ?? *) - | (n,BorderProd (true,Some Gramext.NonA)) -> None - (* Associativity is None means force the level *) - | (n,BorderProd (_,None)) -> Some (Some (n,true)) - (* If left assoc at a left level, set NEXT on the right *) - | (n,BorderProd (false,Some (Gramext.LeftA as a))) - when Gramext.LeftA = camlp4_assoc assoc -> Some None - (* If right or none assoc expected is the current assoc, set explicit - level on the right side *) - | (n,BorderProd (false,Some a)) when a = camlp4_assoc assoc -> - Some (Some (n,true)) - (* If the expected assoc is the current one, SELF on the left sides *) - | (n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> None - (* Otherwise, force the level, n or n-1, according to expected assoc *) - | (n,BorderProd (left,Some a)) -> - if (left & a = Gramext.LeftA) or ((not left) & a = Gramext.RightA) - then Some (Some (n,true)) else Some (Some (n-1,false)) -(* | (8,InternalProd) -> None (* Or (Some 8) for factorization ? *)*) - | (n,InternalProd) -> - match from with - | ETConstr (p,()) when p = n+1 -> Some None - | ETConstr (p,()) -> Some (Some (n,n=p)) - | _ -> Some (Some (n,false)) -*) - let compute_entry allow_create adjust forpat = function | ETConstr (n,q) -> (if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr), - (if forpat & !Options.v7 then None else adjust (n,q)), false + adjust (n,q), false | ETIdent -> weaken_entry Constr.ident, None, false | ETBigint -> weaken_entry Prim.bigint, None, false | ETReference -> weaken_entry Constr.global, None, false @@ -734,42 +560,22 @@ let compute_entry allow_create adjust forpat = function object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) -let get_constr_entry forpat en = - match en with - ETConstr(200,()) when not !Options.v7 & not forpat -> - snd (get_entry (get_univ "constr") "binder_constr"), - None, - false - | _ -> compute_entry true (fun (n,()) -> Some n) forpat en +let get_constr_entry forpat = function + | ETConstr(200,()) when not forpat -> + weaken_entry Constr.binder_constr, None, false + | e -> + compute_entry true (fun (n,()) -> Some n) forpat e (* This computes the name to give to a production knowing the name and associativity of the level where it must be added *) let get_constr_production_entry ass from forpat en = - (* first 2 cases to help factorisation *) - match en with - | ETConstr (NumLevel 10,q) when !Options.v7 & not forpat -> - weaken_entry Constr.lconstr, None, false -(* - | ETConstr (8,q) when !Options.v7 -> - weaken_entry Constr.constr, None, false -*) - | _ -> compute_entry false (adjust_level ass from) forpat en - -let constr_prod_level assoc cur lev = - if !Options.v7 then - if cur then constr_level (lev,assoc) else - match lev with - | 4 when !Options.v7 -> "4L" - | n -> string_of_int n - else - (* No duplication L/R of levels in v8 *) - constr_level (lev,assoc) + compute_entry false (adjust_level ass from) forpat en let is_self from e = match from, e with ETConstr(n,()), ETConstr(NumLevel n', - BorderProd(false, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false - | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(true,_)) -> n=n' + BorderProd(Right, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false + | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n' | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint | ETPattern, ETPattern) -> true | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2' @@ -778,15 +584,14 @@ let is_self from e = let is_binder_level from e = match from, e with ETConstr(200,()), - ETConstr(NumLevel 200,(BorderProd(false,_)|InternalProd)) -> - not !Options.v7 + ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true | _ -> false let rec symbol_of_production assoc from forpat typ = if is_binder_level from typ then - let eobj = snd (get_entry (get_univ "constr") "operconstr") in - Gramext.Snterml (Gram.Entry.obj eobj,"200") - else if is_self from typ then Gramext.Sself + Gramext.Snterml (Gram.Entry.obj Constr.operconstr,"200") + else if is_self from typ then + Gramext.Sself else match typ with | ETConstrList (typ',[]) -> @@ -803,4 +608,15 @@ let rec symbol_of_production assoc from forpat typ = | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj) | (eobj,Some None,_) -> Gramext.Snext | (eobj,Some (Some (lev,cur)),_) -> - Gramext.Snterml (Gram.Entry.obj eobj,constr_prod_level assoc cur lev) + Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev) + +(*****************************) +(* Coercions between entries *) + +let coerce_reference_to_id = function + | Ident (_,id) -> id + | Qualid (loc,_) -> + user_err_loc (loc, "coerce_reference_to_id", + str "This expression should be a simple identifier") + +let coerce_global_to_id = coerce_reference_to_id diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 15a2c2cc..fe6fd083 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -6,18 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pcoq.mli,v 1.63.2.3 2005/06/21 15:31:12 herbelin Exp $ i*) +(*i $Id: pcoq.mli 7826 2006-01-09 22:00:34Z herbelin $ i*) open Util open Names open Rawterm -open Ast +open Extend open Genarg open Topconstr open Tacexpr open Vernacexpr open Libnames -open Extend (* The lexer and parser of Coq. *) @@ -25,21 +24,23 @@ val lexer : Token.lexer module Gram : Grammar.S with type te = Token.t +(* The superclass of all grammar entries *) type grammar_object + +(* The type of typed grammar objects *) type typed_entry -val type_of_typed_entry : typed_entry -> Extend.entry_type +type entry_type = argument_type + +val type_of_typed_entry : typed_entry -> entry_type val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e val get_constr_entry : bool -> constr_entry -> grammar_object Gram.Entry.e * int option * bool -val symbol_of_production : Gramext.g_assoc option -> constr_entry -> - bool -> constr_production_entry -> Token.t Gramext.g_symbol - val grammar_extend : - 'a Gram.Entry.e -> Gramext.position option -> + grammar_object Gram.Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * (Token.t Gramext.g_symbol list * Gramext.g_action) list) list -> unit @@ -80,22 +81,6 @@ val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_ val get_generic_entry : string -> grammar_object Gram.Entry.e val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type -type parser_type = - | ConstrParser - | CasesPatternParser - -val entry_type_of_parser : parser_type -> entry_type option -val parser_type_from_name : string -> parser_type - -(* Quotations in ast parser *) -val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit -val set_globalizer : (constr_expr -> Coqast.t) -> unit - -(* The default parser for actions in grammar rules *) - -val default_action_parser : dynamic_grammar Gram.Entry.e -val set_default_action_parser : parser_type -> unit - (* The main entry: reads an optional vernac command *) val main_entry : (loc * vernac_expr) option Gram.Entry.e @@ -113,20 +98,15 @@ module Prim : val identref : identifier located Gram.Entry.e val base_ident : identifier Gram.Entry.e val natural : int Gram.Entry.e - val bigint : Bignat.bigint Gram.Entry.e + val bigint : Bigint.bigint Gram.Entry.e val integer : int Gram.Entry.e val string : string Gram.Entry.e val qualid : qualid located Gram.Entry.e + val fullyqualid : identifier list located Gram.Entry.e val reference : reference Gram.Entry.e val dirpath : dir_path Gram.Entry.e val ne_string : string Gram.Entry.e - val hyp : identifier Gram.Entry.e - (* v7 only entries *) - val astpat: typed_ast Gram.Entry.e - val ast : Coqast.t Gram.Entry.e - val astlist : Coqast.t list Gram.Entry.e - val ast_eoi : Coqast.t Gram.Entry.e - val var : identifier Gram.Entry.e + val var : identifier located Gram.Entry.e end module Constr : @@ -157,17 +137,18 @@ module Tactic : sig open Rawterm val open_constr : open_constr_expr Gram.Entry.e - val castedopenconstr : open_constr_expr Gram.Entry.e + val casted_open_constr : open_constr_expr Gram.Entry.e val constr_with_bindings : constr_expr with_bindings Gram.Entry.e val bindings : constr_expr bindings Gram.Entry.e -(*v7*) val constrarg : (constr_expr,reference) may_eval Gram.Entry.e -(*v8*) val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e + val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e val quantified_hypothesis : quantified_hypothesis Gram.Entry.e val int_or_var : int or_var Gram.Entry.e val red_expr : raw_red_expr Gram.Entry.e val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e val simple_intropattern : Genarg.intro_pattern_expr Gram.Entry.e val tactic_arg : raw_tactic_arg Gram.Entry.e + val tactic_expr : raw_tactic_expr Gram.Entry.e + val tactic_main_level : int val tactic : raw_tactic_expr Gram.Entry.e val tactic_eoi : raw_tactic_expr Gram.Entry.e end @@ -183,7 +164,10 @@ module Vernac_ : val vernac_eoi : vernac_expr Gram.Entry.e end -val reset_all_grammars : unit -> unit +(* Binding entry names to campl4 entries *) + +val symbol_of_production : Gramext.g_assoc option -> constr_entry -> + bool -> constr_production_entry -> Token.t Gramext.g_symbol (* Registering/resetting the level of an entry *) @@ -192,3 +176,5 @@ val find_position : Gramext.position option * Gramext.g_assoc option * string option val remove_levels : int -> unit + +val coerce_global_to_id : reference -> identifier diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index ddf008cb..a43463c6 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,44 +6,64 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppconstr.ml,v 1.32.2.2 2004/12/29 10:17:11 herbelin Exp $ *) +(* $Id: ppconstr.ml 8624 2006-03-13 17:38:17Z msozeau $ *) (*i*) -open Ast open Util open Pp open Nametab open Names open Nameops open Libnames -open Coqast open Ppextend open Topconstr open Term open Pattern +open Rawterm +open Constrextern +open Termops (*i*) +let sep_p = fun _ -> str"." +let sep_v = fun _ -> str"," ++ spc() +let sep_pp = fun _ -> str":" +let sep_bar = fun _ -> spc() ++ str"| " +let pr_tight_coma () = str "," ++ cut () + let latom = 0 -let lannot = 1 -let lprod = 8 (* not 1 because the scope extends to 8 on the right *) -let llambda = 8 (* not 1 *) -let lif = 8 (* not 1 *) -let lletin = 8 (* not 1 *) -let lcases = 1 -let larrow = 8 -let lcast = 9 +let lannot = 100 +let lprod = 200 +let llambda = 200 +let lif = 200 +let lletin = 200 +let lfix = 200 +let larrow = 90 +let lcast = 100 +let larg = 9 let lapp = 10 -let ltop = (8,E) +let lposint = 0 +let lnegint = 35 (* must be consistent with Notation "- x" *) +let ltop = (200,E) +let lproj = 1 +let lsimple = (1,E) + +let prec_less child (parent,assoc) = + if parent < 0 && child = lprod then true + else + let parent = abs parent in + match assoc with + | E -> (<=) child parent + | L -> (<) child parent + | Prec n -> child<=n + | Any -> true -let prec_less child (parent,assoc) = match assoc with - | E -> child <= parent - | L -> child < parent - | Prec n -> child <= n - | Any -> true +let prec_of_prim_token = function + | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint + | String _ -> latom let env_assoc_value v env = try List.nth env (v-1) - with Not_found -> anomaly "Inconsistent environment for pretty-print rule" + with Not_found -> anomaly ("Inconsistent environment for pretty-print rule") let decode_constrlist_value = function | CAppExpl (_,_,l) -> l @@ -54,7 +74,7 @@ let decode_patlist_value = function | CPatCstr (_,_,l) -> l | _ -> anomaly "Ill-formed list argument of notation" -open Symbols +open Notation let rec print_hunk n decode pr env = function | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env) @@ -73,315 +93,596 @@ let pr_notation = pr_notation_gen decode_constrlist_value let pr_patnotation = pr_notation_gen decode_patlist_value let pr_delimiters key strm = - let left = "'"^key^":" and right = "'" in - let lspace = - if is_letter (left.[String.length left -1]) then str " " else mt () in - let rspace = - let c = right.[0] in - if is_letter c or is_digit c or c = '\'' then str " " else mt () in - str left ++ lspace ++ strm ++ rspace ++ str right + strm ++ str ("%"^key) -open Rawterm +let surround p = hov 1 (str"(" ++ p ++ str")") + +let pr_located pr ((b,e),x) = + if Options.do_translate() && (b,e)<>dummy_loc then + let (b,e) = unloc (b,e) in + comment b ++ pr x ++ comment e + else pr x + +let pr_com_at n = + if Options.do_translate() && n <> 0 then comment n + else mt() + +let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) -let pr_opt pr = function +let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) + +let pr_optc pr = function | None -> mt () - | Some x -> spc () ++ pr x + | Some x -> pr_sep_com spc pr x -let pr_universe u = str "<univ>" +let pr_universe = Univ.pr_uni let pr_sort = function | RProp Term.Null -> str "Prop" | RProp Term.Pos -> str "Set" | RType u -> str "Type" ++ pr_opt pr_universe u -let pr_explicitation = function - | None -> mt () - | Some (_,ExplByPos n) -> int n ++ str "!" - | Some (_,ExplByName n) -> anomaly "Argument made explicit by name" +let pr_id = pr_id +let pr_name = pr_name +let pr_qualid = pr_qualid let pr_expl_args pr (a,expl) = - pr_explicitation expl ++ pr (lapp,L) a + match expl with + | None -> pr (lapp,L) a + | Some (_,ExplByPos n) -> + anomaly("Explicitation by position not implemented") + | Some (_,ExplByName id) -> + str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" let pr_opt_type pr = function | CHole _ -> mt () - | t -> str ":" ++ pr ltop t - -let pr_tight_coma () = str "," ++ cut () + | t -> cut () ++ str ":" ++ pr t -let pr_name = function - | Anonymous -> str "_" - | Name id -> pr_id id - -let pr_located pr (loc,x) = pr x +let pr_opt_type_spc pr = function + | CHole _ -> mt () + | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t + +let pr_lident (b,_ as loc,id) = + if loc <> dummy_loc then + let (b,_) = unloc loc in + pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) + else pr_id id + +let pr_lname = function + (loc,Name id) -> pr_lident (loc,id) + | lna -> pr_located pr_name lna + +let pr_or_var pr = function + | Genarg.ArgArg x -> pr x + | Genarg.ArgVar (loc,s) -> pr_lident (loc,s) + +let pr_prim_token = function + | Numeral n -> Bigint.pr_bigint n + | String s -> qs s + +let las = lapp +let lpator = 100 + +let rec pr_patt sep inh p = + let (strm,prec) = match p with + | CPatAlias (_,p,id) -> + pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las + | CPatCstr (_,c,[]) -> pr_reference c, latom + | CPatCstr (_,c,args) -> + pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp + | CPatAtom (_,None) -> str "_", latom + | CPatAtom (_,Some r) -> pr_reference r, latom + | CPatOr (_,pl) -> + hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator + | CPatNotation (_,"( _ )",[p]) -> + pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom + | CPatNotation (_,s,env) -> pr_patnotation (pr_patt mt) s env + | CPatPrim (_,p) -> pr_prim_token p, latom + | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1 + in + let loc = cases_pattern_loc p in + pr_with_comments loc + (sep() ++ if prec_less prec inh then strm else surround strm) + +let pr_patt = pr_patt mt + + +let pr_eqn pr (loc,pl,rhs) = + spc() ++ hov 4 + (pr_with_comments loc + (str "| " ++ + hov 0 (prlist_with_sep sep_v (pr_patt ltop) pl ++ str " =>") ++ + pr_sep_com spc (pr ltop) rhs)) + +let begin_of_binder = function + LocalRawDef((loc,_),_) -> fst (unloc loc) + | LocalRawAssum((loc,_)::_,_) -> fst (unloc loc) + | _ -> assert false + +let begin_of_binders = function + | b::_ -> begin_of_binder b + | _ -> 0 + +let pr_binder many pr (nal,t) = + match t with + | CHole _ -> prlist_with_sep spc pr_lname nal + | _ -> + let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in + hov 1 (if many then surround s else s) + +let pr_binder_among_many pr_c = function + | LocalRawAssum (nal,t) -> + pr_binder true pr_c (nal,t) + | LocalRawDef (na,c) -> + let c,topt = match c with + | CCast(_,c,_,t) -> c, t + | _ -> c, CHole dummy_loc in + hov 1 (surround + (pr_lname na ++ pr_opt_type pr_c topt ++ + str":=" ++ cut() ++ pr_c c)) + +let pr_undelimited_binders pr_c = + prlist_with_sep spc (pr_binder_among_many pr_c) + +let pr_delimited_binders kw pr_c bl = + let n = begin_of_binders bl in + match bl with + | [LocalRawAssum (nal,t)] -> + pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,t) + | LocalRawAssum _ :: _ as bdl -> + pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl + | _ -> assert false let pr_let_binder pr x a = - hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ brk(0,1) ++ pr ltop a) - -let pr_binder pr (nal,t) = - hov 0 ( - prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++ - pr_opt_type pr t) - -let pr_binders pr bl = - hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl) - -let pr_local_binder pr = function - LocalRawAssum(nal,t) -> pr_binder pr (nal,t) - | LocalRawDef((_,na),t) -> pr_let_binder pr na t - -let pr_local_binders pr bl = - hv 0 (prlist_with_sep pr_semicolon (pr_local_binder pr) bl) - -let pr_global vars ref = pr_global_env vars ref - -let rec pr_lambda_tail pr bll = function - | CLambdaN (_,bl,a) -> - pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_binders pr bl) a - | CLetIn (_,x,a,b) -> - pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_let_binder pr (snd x) a) b - | a -> - bll, pr ltop a - -let rec pr_prod_tail pr bll = function - | CProdN (_,bl,a) -> - pr_prod_tail pr (bll ++ pr_semicolon () ++ pr_binders pr bl) a - | a -> bll, pr ltop a - -let pr_recursive_decl pr id binders t c = - pr_id id ++ binders ++ - brk (1,2) ++ str ": " ++ pr ltop t ++ str " :=" ++ - brk (1,2) ++ pr ltop c - + hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ + pr_sep_com (fun () -> brk(0,1)) (pr ltop) a) + +let rec extract_prod_binders = function +(* | CLetIn (loc,na,b,c) as x -> + let bl,c = extract_prod_binders c in + if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*) + | CProdN (loc,[],c) -> + extract_prod_binders c + | CProdN (loc,(nal,t)::bl,c) -> + let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in + LocalRawAssum (nal,t) :: bl, c + | c -> [], c + +let rec extract_lam_binders = function +(* | CLetIn (loc,na,b,c) as x -> + let bl,c = extract_lam_binders c in + if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*) + | CLambdaN (loc,[],c) -> + extract_lam_binders c + | CLambdaN (loc,(nal,t)::bl,c) -> + let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in + LocalRawAssum (nal,t) :: bl, c + | c -> [], c + let split_lambda = function | CLambdaN (loc,[[na],t],c) -> (na,t,c) | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c)) | _ -> anomaly "ill-formed fixpoint body" -let split_product = function - | CArrow (loc,t,c) -> ((loc,Anonymous),t,c) - | CProdN (loc,[[na],t],c) -> (na,t,c) - | CProdN (loc,([na],t)::bl,c) -> (na,t,CProdN(loc,bl,c)) - | CProdN (loc,(na::nal,t)::bl,c) -> (na,t,CProdN(loc,(nal,t)::bl,c)) +let rename na na' t c = + match (na,na') with + | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c) + | (_,Name id), (_,Anonymous) -> (na,t,c) + | _ -> (na',t,c) + +let split_product na' = function + | CArrow (loc,t,c) -> (na',t,c) + | CProdN (loc,[[na],t],c) -> rename na na' t c + | CProdN (loc,([na],t)::bl,c) -> rename na na' t (CProdN(loc,bl,c)) + | CProdN (loc,(na::nal,t)::bl,c) -> + rename na na' t (CProdN(loc,(nal,t)::bl,c)) | _ -> anomaly "ill-formed fixpoint body" -let concat_binder na t = function - | [] -> [[na],t] - | (nal,u)::bl' as bl -> if t=u then (na::nal,t)::bl' else ([na],t)::bl +let merge_binders (na1,ty1) cofun (na2,ty2) codom = + let na = + match snd na1, snd na2 with + Anonymous, Name id -> + if occur_var_constr_expr id cofun then + failwith "avoid capture" + else na2 + | Name id, Anonymous -> + if occur_var_constr_expr id codom then + failwith "avoid capture" + else na1 + | Anonymous, Anonymous -> na1 + | Name id1, Name id2 -> + if id1 <> id2 then failwith "not same name" else na1 in + let ty = + match ty1, ty2 with + CHole _, _ -> ty2 + | _, CHole _ -> ty1 + | _ -> + Constrextern.check_same_type ty1 ty2; + ty2 in + (LocalRawAssum ([na],ty), codom) + +let rec strip_domain bvar cofun c = + match c with + | CArrow(loc,a,b) -> + merge_binders bvar cofun ((dummy_loc,Anonymous),a) b + | CProdN(loc,[([na],ty)],c') -> + merge_binders bvar cofun (na,ty) c' + | CProdN(loc,([na],ty)::bl,c') -> + merge_binders bvar cofun (na,ty) (CProdN(loc,bl,c')) + | CProdN(loc,(na::nal,ty)::bl,c') -> + merge_binders bvar cofun (na,ty) (CProdN(loc,(nal,ty)::bl,c')) + | _ -> failwith "not a product" + +(* Note: binder sharing is lost *) +let rec strip_domains (nal,ty) cofun c = + match nal with + [] -> assert false + | [na] -> + let bnd, c' = strip_domain (na,ty) cofun c in + ([bnd],None,c') + | na::nal -> + let f = CLambdaN(dummy_loc,[(nal,ty)],cofun) in + let bnd, c1 = strip_domain (na,ty) f c in + (try + let bl, rest, c2 = strip_domains (nal,ty) cofun c1 in + (bnd::bl, rest, c2) + with Failure _ -> ([bnd],Some (nal,ty), c1)) + +(* Re-share binders *) +let rec factorize_binders = function + | ([] | [_] as l) -> l + | LocalRawAssum (nal,ty) as d :: (LocalRawAssum (nal',ty')::l as l') -> + (try + let _ = Constrextern.check_same_type ty ty' in + factorize_binders (LocalRawAssum (nal@nal',ty)::l) + with _ -> + d :: factorize_binders l') + | d :: l -> d :: factorize_binders l + +(* Extract lambdas when a type constraint occurs *) +let rec extract_def_binders c ty = + match c with + | CLambdaN(loc,bvar::lams,b) -> + (try + let f = CLambdaN(loc,lams,b) in + let bvar', rest, ty' = strip_domains bvar f ty in + let c' = + match rest, lams with + None,[] -> b + | None, _ -> f + | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in + let (bl,c2,ty2) = extract_def_binders c' ty' in + (factorize_binders (bvar'@bl), c2, ty2) + with Failure _ -> + ([],c,ty)) + | _ -> ([],c,ty) let rec split_fix n typ def = if n = 0 then ([],typ,def) else let (na,_,def) = split_lambda def in - let (_,t,typ) = split_product typ in + let (na,t,typ) = split_product na typ in let (bl,typ,def) = split_fix (n-1) typ def in - (concat_binder na t bl,typ,def) - -let pr_fixdecl pr (id,n,bl,t,c) = - pr_recursive_decl pr id - (brk (1,2) ++ str "[" ++ pr_local_binders pr bl ++ str "]") t c + (LocalRawAssum ([na],t)::bl,typ,def) + +let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = + let pr_body = + if dangling_with_for then pr_dangling else pr in + pr_id id ++ str" " ++ + hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++ + pr_opt_type_spc pr t ++ str " :=" ++ + pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c + +let pr_fixdecl pr prd dangling_with_for (id,(n,ro),bl,t,c) = + let annot = + let ids = names_of_local_assums bl in + match ro with + CStructRec -> + if List.length ids > 1 then + spc() ++ str "{struct " ++ pr_name (snd (List.nth ids n)) ++ str"}" + else mt() + | CWfRec c -> + spc () ++ str "{wf " ++ pr lsimple c ++ pr_name (snd (List.nth ids n)) ++ str"}" + in + pr_recursive_decl pr prd dangling_with_for id bl annot t c -let pr_cofixdecl pr (id,bl,t,c) = - let b = - if bl=[] then mt() else - brk(1,2) ++ str"[" ++ pr_local_binders pr bl ++ str "]" in - pr_recursive_decl pr id b t c +let pr_cofixdecl pr prd dangling_with_for (id,bl,t,c) = + pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c -let pr_recursive fix pr_decl id = function +let pr_recursive pr_decl id = function | [] -> anomaly "(co)fixpoint with no definition" - | d1::dl -> - hov 0 ( - str fix ++ spc () ++ pr_id id ++ brk (1,2) ++ str "{" ++ - (v 0 ( - (hov 0 (pr_decl d1)) ++ - (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix)) - dl))) ++ - str "}") + | [d1] -> pr_decl false d1 + | dl -> + prlist_with_sep (fun () -> fnl() ++ str "with ") + (pr_decl true) dl ++ + fnl() ++ str "for " ++ pr_id id + +let is_var id = function + | CRef (Ident (_,id')) when id=id' -> true + | _ -> false + +let tm_clash = function + | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) + when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false) + nal + -> Some id + | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) + when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false) + nal + -> Some id + | _ -> None + +let pr_case_item pr (tm,(na,indnalopt)) = + hov 0 (pr (lcast,E) tm ++ +(* + (match na with + | Name id when not (is_var id tm) -> spc () ++ str "as " ++ pr_id id + | Anonymous when tm_clash (tm,indnalopt) <> None -> + (* hide [tm] name to avoid conflicts *) + spc () ++ str "as _" (* ++ pr_id (out_some (tm_clash (tm,indnalopt)))*) + | _ -> mt ()) ++ +*) + (match na with (* Decision of printing "_" or not moved to constrextern.ml *) + | Some na -> spc () ++ str "as " ++ pr_name na + | None -> mt ()) ++ + (match indnalopt with + | None -> mt () +(* + | Some (_,ind,nal) -> + spc () ++ str "in " ++ + hov 0 (pr_reference ind ++ prlist (pr_arg pr_name) nal)) +*) + | Some t -> spc () ++ str "in " ++ pr lsimple t)) -let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr) -let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr) +let pr_case_type pr po = + match po with + | None | Some (CHole _) -> mt() + | Some p -> + spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p) -let rec pr_arrow pr = function - | CArrow (_,a,b) -> pr (larrow,L) a ++ cut () ++ str "->" ++ pr_arrow pr b - | a -> pr (larrow,E) a +let pr_return_type pr po = pr_case_type pr po -let pr_annotation pr = function - | None -> mt () - | Some t -> str "<" ++ pr ltop t ++ str ">" ++ brk (0,2) - -let rec pr_cases_pattern _inh = function - | CPatAlias (_,p,x) -> - pr_cases_pattern _inh p ++ spc () ++ str "as" ++ spc () ++ pr_id x - | CPatCstr (_,c,[]) -> pr_reference c - | CPatCstr (_,c,pl) -> - hov 0 ( - str "(" ++ pr_reference c ++ spc () ++ - prlist_with_sep spc (pr_cases_pattern _inh) pl ++ str ")") - | CPatAtom (_,Some c) -> pr_reference c - | CPatAtom (_,None) -> str "_" - | CPatNotation (_,"( _ )",[p]) -> - str"("++ pr_cases_pattern _inh p ++ str")" - | CPatNotation (_,s,env) -> fst (pr_patnotation pr_cases_pattern s env) - | CPatNumeral (_,n) -> Bignat.pr_bigint n - | CPatDelimiters (_,key,p) -> pr_delimiters key (pr_cases_pattern _inh p) - -let pr_cases_pattern = pr_cases_pattern (0,E) (* level unused *) - -let pr_eqn pr (_,patl,rhs) = - hov 0 ( - prlist_with_sep spc pr_cases_pattern patl ++ spc () ++ - str "=>" ++ - brk (1,1) ++ pr ltop rhs) ++ spc () - -let pr_cases pr (po,_) tml eqns = - hov 0 ( - pr_annotation pr po ++ - hv 0 ( - hv 0 ( - str "Cases" ++ brk (1,2) ++ - prlist_with_sep spc (fun (tm,_) -> pr ltop tm) tml ++ spc() ++ str "of") ++ brk(1,2) ++ - prlist_with_sep (fun () -> str "| ") (pr_eqn pr) eqns ++ - str "end")) +let pr_simple_return_type pr na po = + (match na with + | Some (Name id) -> + spc () ++ str "as " ++ pr_id id + | _ -> mt ()) ++ + pr_case_type pr po let pr_proj pr pr_app a f l = - hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") + hov 0 (pr lsimple a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") -let pr_explapp pr f l = - hov 0 ( - str "!" ++ pr_reference f ++ - prlist (fun a -> brk (1,1) ++ pr (lapp,L) a) l) +let pr_appexpl pr f l = + hov 2 ( + str "@" ++ pr_reference f ++ + prlist (pr_sep_com spc (pr (lapp,L))) l) let pr_app pr a l = - hov 0 ( - pr (lapp,L) a ++ - prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l) + hov 2 ( + pr (lapp,L) a ++ + prlist (fun a -> spc () ++ pr_expl_args pr a) l) -let rec pr inherited a = +let rec pr sep inherited a = let (strm,prec) = match a with | CRef r -> pr_reference r, latom - | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom - | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom - | CArrow _ -> hv 0 (pr_arrow pr a), larrow - | CProdN (_,bl,a) -> - let bll, a = pr_prod_tail pr (mt()) a in - hv 1 ( - hv 1 (str "(" ++ pr_binders pr bl ++ bll ++ str ")") ++ - brk (0,1) ++ a), lprod - | CLambdaN (_,bl,a) -> - let bll, a = pr_lambda_tail pr (mt()) a in - hv 1 ( - hv 1 (str "[" ++ pr_binders pr bl ++ bll ++ str "]") ++ - brk (0,1) ++ a), llambda - | CLetIn (_,x,a,b) -> - let bll, b = pr_lambda_tail pr (mt()) b in - hv 1 ( - hv 1 (str "[" ++ pr_let_binder pr (snd x) a ++ bll ++ str "]") ++ - brk (0,1) ++ b), lletin - | CAppExpl (_,((* V7 don't know about projections *)_,f),l) -> - pr_explapp pr f l, lapp - | CApp (_,(_,a),l) -> - pr_app pr a l, lapp - | CCases (_,po,tml,eqns) -> - pr_cases pr po tml eqns, lcases - | COrderedCase (_,IfStyle,po,c,[b1;b2]) -> - (* On force les parenthèses autour d'un "if" sous-terme (même si le - parsing est lui plus tolérant) *) + | CFix (_,id,fix) -> + hov 0 (str"fix " ++ + pr_recursive + (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix), + lfix + | CCoFix (_,id,cofix) -> + hov 0 (str "cofix " ++ + pr_recursive + (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix), + lfix + | CArrow (_,a,b) -> + hov 0 (pr mt (larrow,L) a ++ str " ->" ++ + pr (fun () ->brk(1,0)) (-larrow,E) b), + larrow + | CProdN _ -> + let (bl,a) = extract_prod_binders a in hov 0 ( - pr_annotation pr po ++ - hv 0 ( - str "if " ++ pr ltop c ++ spc () ++ - hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++ - hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lif - | CLetTuple _ | CIf _ -> - error "Let tuple not supported in v7" - - | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) -> + hov 2 (pr_delimited_binders (fun () -> str"forall" ++ spc()) + (pr mt ltop) bl) ++ + str "," ++ pr spc ltop a), + lprod + | CLambdaN _ -> + let (bl,a) = extract_lam_binders a in hov 0 ( - hov 0 ( - pr_annotation pr po ++ + hov 2 (pr_delimited_binders (fun () -> str"fun" ++ spc()) + (pr mt ltop) bl) ++ + + str " =>" ++ pr spc ltop a), + llambda + | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b) + when x=x' -> + hv 0 ( + hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++ + pr spc ltop b), + lletin + | CLetIn (_,x,a,b) -> + hv 0 ( + hov 2 (str "let " ++ pr_lname x ++ str " :=" ++ + pr spc ltop a ++ str " in") ++ + pr spc ltop b), + lletin + | CAppExpl (_,(Some i,f),l) -> + let l1,l2 = list_chop i l in + let c,l1 = list_sep_last l1 in + let p = pr_proj (pr mt) pr_appexpl c f l1 in + if l2<>[] then + p ++ prlist (pr spc (lapp,L)) l2, lapp + else + p, lproj + | CAppExpl (_,(None,Ident (_,var)),[t]) + | CApp (_,(_,CRef(Ident(_,var))),[t,None]) + when var = Topconstr.ldots_var -> + hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg + | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp + | CApp (_,(Some i,f),l) -> + let l1,l2 = list_chop i l in + let c,l1 = list_sep_last l1 in + assert (snd c = None); + let p = pr_proj (pr mt) pr_app (fst c) f l1 in + if l2<>[] then + p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp + else + p, lproj + | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp + | CCases (_,rtntypopt,c,eqns) -> + v 0 + (hv 0 (str "match" ++ brk (1,2) ++ hov 0 ( - str (if style=RegularStyle then "Case" else "Match") ++ - brk (1,1) ++ pr ltop c ++ spc () ++ - str (if style=RegularStyle then "of" else "with") ++ - brk (1,3) ++ - fnl () ++ hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl) ++ - str "end"))), lcases - | COrderedCase (_,_,_,_,_) -> - anomaly "malformed if or destructuring let" - | CHole _ -> str "?", latom -(* - | CEvar (_,n) -> str "?" ++ int n, latom -*) + prlist_with_sep sep_v + (pr_case_item (pr_dangling_with_for mt)) c + ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++ + spc () ++ str "with") ++ + prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"), + latom + | CLetTuple (_,nal,(na,po),c,b) -> + hv 0 ( + str "let " ++ + hov 0 (str "(" ++ + prlist_with_sep sep_v pr_name nal ++ + str ")" ++ + pr_simple_return_type (pr mt) na po ++ str " :=" ++ + pr spc ltop c ++ str " in") ++ + pr spc ltop b), + lletin + | CIf (_,c,(na,po),b1,b2) -> + (* On force les parenthèses autour d'un "if" sous-terme (même si le + parsing est lui plus tolérant) *) + hv 0 ( + hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++ + spc () ++ + hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++ + hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), + lif + + | CHole _ -> str "_", latom | CEvar (_,n) -> str (Evd.string_of_existential n), latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom | CSort (_,s) -> pr_sort s, latom - | CCast (_,a,b) -> - hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast + | CCast (_,a,_,b) -> + hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":" ++ pr mt (-lcast,E) b), + lcast | CNotation (_,"( _ )",[t]) -> - str"("++ pr (max_int,E) t ++ str")", latom - | CNotation (_,s,env) -> pr_notation pr s env - | CNumeral (_,p) -> Bignat.pr_bigint p, latom - | CDelimiters (_,sc,a) -> pr_delimiters sc (pr ltop a), latom + pr (fun()->str"(") (max_int,L) t ++ str")", latom + | CNotation (_,s,env) -> pr_notation (pr mt) s env + | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p + | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1 | CDynamic _ -> str "<dynamic>", latom in - if prec_less prec inherited then strm - else str"(" ++ strm ++ str")" - -let pr_constr = pr ltop - -let pr_pattern = pr_constr - -let pr_qualid qid = str (string_of_qualid qid) - -open Rawterm - -let pr_arg pr x = spc () ++ pr x + let loc = constr_loc a in + pr_with_comments loc + (sep() ++ if prec_less prec inherited then strm else surround strm) + +and pr_dangling_with_for sep inherited a = + match a with + | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a + | _ -> pr sep inherited a + +let pr = pr mt + +let rec strip_context n iscast t = + if n = 0 then + [], if iscast then match t with CCast (_,c,_,_) -> c | _ -> t else t + else match t with + | CLambdaN (loc,(nal,t)::bll,c) -> + let n' = List.length nal in + if n' > n then + let nal1,nal2 = list_chop n nal in + [LocalRawAssum (nal1,t)], CLambdaN (loc,(nal2,t)::bll,c) + else + let bl', c = strip_context (n-n') iscast + (if bll=[] then c else CLambdaN (loc,bll,c)) in + LocalRawAssum (nal,t) :: bl', c + | CProdN (loc,(nal,t)::bll,c) -> + let n' = List.length nal in + if n' > n then + let nal1,nal2 = list_chop n nal in + [LocalRawAssum (nal1,t)], CProdN (loc,(nal2,t)::bll,c) + else + let bl', c = strip_context (n-n') iscast + (if bll=[] then c else CProdN (loc,bll,c)) in + LocalRawAssum (nal,t) :: bl', c + | CArrow (loc,t,c) -> + let bl', c = strip_context (n-1) iscast c in + LocalRawAssum ([loc,Anonymous],t) :: bl', c + | CCast (_,c,_,_) -> strip_context n false c + | CLetIn (_,na,b,c) -> + let bl', c = strip_context (n-1) iscast c in + LocalRawDef (na,b) :: bl', c + | _ -> anomaly "strip_context" + +let pr_constr_expr c = pr lsimple c +let pr_lconstr_expr c = pr ltop c +let pr_pattern_expr c = pr lsimple c +let pr_cases_pattern_expr = pr_patt ltop + +let pr_binders = pr_undelimited_binders (pr ltop) + +let pr_pattern_occ prc = function + ([],c) -> prc c + | (nl,c) -> hov 1 (prc c ++ spc() ++ str"at " ++ + hov 0 (prlist_with_sep spc int nl)) + +let pr_unfold_occ pr_ref = function + ([],qid) -> pr_ref qid + | (nl,qid) -> hov 1 (pr_ref qid ++ spc() ++ str"at " ++ + hov 0 (prlist_with_sep spc int nl)) let pr_red_flag pr r = - (if r.rBeta then pr_arg str "Beta" else mt ()) ++ - (if r.rIota then pr_arg str "Iota" else mt ()) ++ - (if r.rZeta then pr_arg str "Zeta" else mt ()) ++ + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rIota then pr_arg str "iota" else mt ()) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ (if r.rConst = [] then - if r.rDelta then pr_arg str "Delta" + if r.rDelta then pr_arg str "delta" else mt () else - pr_arg str "Delta" ++ (if r.rDelta then str "-" else mt ()) ++ + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) open Genarg -let pr_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c +let pr_metaid id = str"?" ++ pr_id id -let pr_red_expr (pr_constr,pr_ref) = function - | Red false -> str "Red" - | Hnf -> str "Hnf" - | Simpl o -> str "Simpl" ++ pr_opt (pr_occurrences pr_constr) o +let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function + | Red false -> str "red" + | Hnf -> str "hnf" + | Simpl o -> str "simpl" ++ pr_opt (pr_pattern_occ pr_constr) o | Cbv f -> if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then - str "Compute" + str "compute" else - hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f) + hov 1 (str "cbv" ++ pr_red_flag pr_ref f) | Lazy f -> - hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f) + hov 1 (str "lazy" ++ pr_red_flag pr_ref f) | Unfold l -> - hov 1 (str "Unfold" ++ - prlist (fun (nl,qid) -> - prlist (pr_arg int) nl ++ spc () ++ pr_ref qid) l) - | Fold l -> hov 1 (str "Fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> hov 1 (str "Pattern " ++ prlist (pr_occurrences pr_constr) l) + hov 1 (str "unfold" ++ spc() ++ + prlist_with_sep pr_coma (pr_unfold_occ pr_ref) l) + | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (str "pattern" ++ + pr_arg (prlist_with_sep pr_coma (pr_pattern_occ pr_constr)) l) + | Red true -> error "Shouldn't be accessible from user" | ExtraRedExpr s -> str s + | CbvVm -> str "vm_compute" -let rec pr_may_eval pr pr2 = function +let rec pr_may_eval test prc prlc pr2 = function | ConstrEval (r,c) -> hov 0 - (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr2) r ++ - spc () ++ str "in" ++ brk (1,1) ++ pr c) + (str "eval" ++ brk (1,1) ++ + pr_red_expr (prc,prlc,pr2) r ++ + str " in" ++ spc() ++ prc c) | ConstrContext ((_,id),c) -> hov 0 - (str "Inst " ++ brk (1,1) ++ pr_id id ++ spc () ++ - str "[" ++ pr c ++ str "]") - | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c) - | ConstrTerm c -> pr c + (str "context " ++ pr_id id ++ spc () ++ + str "[" ++ prlc c ++ str "]") + | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c) + | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")") + | ConstrTerm c -> prc c -let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c) +let pr_may_eval a = pr_may_eval (fun _ -> false) a diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 039cd745..7441f130 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -5,8 +6,8 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(*i $Id: ppconstr.mli,v 1.7.2.2 2005/01/21 17:19:37 herbelin Exp $ i*) + +(*i $Id: ppconstr.mli 7907 2006-01-21 11:03:29Z herbelin $ i*) open Pp open Environ @@ -14,28 +15,55 @@ open Term open Libnames open Pcoq open Rawterm -open Extend -open Coqast open Topconstr open Names open Util +open Genarg + +val extract_lam_binders : + constr_expr -> local_binder list * constr_expr +val extract_prod_binders : + constr_expr -> local_binder list * constr_expr +val extract_def_binders : + constr_expr -> constr_expr -> + local_binder list * constr_expr * constr_expr +val split_fix : + int -> constr_expr -> constr_expr -> + local_binder list * constr_expr * constr_expr + +val prec_less : int -> int * Ppextend.parenRelation -> bool + +val pr_tight_coma : unit -> std_ppcmds -val split_fix : int -> constr_expr -> constr_expr -> - (name located list * constr_expr) list * constr_expr * constr_expr +val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds +val pr_metaid : identifier -> std_ppcmds -val pr_global : Idset.t -> global_reference -> std_ppcmds +val pr_lident : identifier located -> std_ppcmds +val pr_lname : name located -> std_ppcmds -val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_with_comments : loc -> std_ppcmds -> std_ppcmds +val pr_com_at : int -> std_ppcmds +val pr_sep_com : + (unit -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + constr_expr -> std_ppcmds + +val pr_id : identifier -> std_ppcmds val pr_name : name -> std_ppcmds val pr_qualid : qualid -> std_ppcmds + val pr_red_expr : - ('a -> std_ppcmds) * ('b -> std_ppcmds) -> + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) -> ('a,'b) red_expr_gen -> std_ppcmds -val pr_occurrences : ('a -> std_ppcmds) -> 'a occurrences -> std_ppcmds +val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('a,'b) may_eval -> std_ppcmds val pr_sort : rawsort -> std_ppcmds -val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds -val pr_constr : constr_expr -> std_ppcmds -val pr_cases_pattern : cases_pattern_expr -> std_ppcmds -val pr_may_eval : ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds -val pr_rawconstr : rawconstr -> std_ppcmds + +val pr_binders : local_binder list -> std_ppcmds +val pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds +val pr_constr_expr : constr_expr -> std_ppcmds +val pr_lconstr_expr : constr_expr -> std_ppcmds +val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 4103ea00..e6c12f4f 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -6,69 +6,64 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pptactic.ml,v 1.54.2.5 2005/12/23 22:16:46 herbelin Exp $ *) +(* $Id: pptactic.ml 8651 2006-03-21 21:54:43Z jforest $ *) open Pp open Names open Nameops open Util -open Extend open Tacexpr open Rawterm open Topconstr open Genarg open Libnames open Pattern +open Ppextend +open Ppconstr +open Printer -let pr_red_expr = Ppconstr.pr_red_expr -let pr_may_eval = Ppconstr.pr_may_eval -let pr_sort = Ppconstr.pr_sort -let pr_global x = - if Options.do_translate () then (* for pr_gen *) - Ppconstrnew.pr_global Idset.empty x - else - Ppconstr.pr_global Idset.empty x -let pr_name = Ppconstr.pr_name -let pr_opt = Ppconstr.pr_opt -let pr_occurrences = Ppconstr.pr_occurrences +let pr_global x = Nametab.pr_global_env Idset.empty x type grammar_terminals = string option list (* Extensions *) -let prtac_tab_v7 = Hashtbl.create 17 let prtac_tab = Hashtbl.create 17 -let declare_extra_tactic_pprule for_v8 s (tags,prods) = - Hashtbl.add prtac_tab_v7 (s,tags) prods; - if for_v8 then Hashtbl.add prtac_tab (s,tags) prods +let declare_extra_tactic_pprule (s,tags,prods) = + Hashtbl.add prtac_tab (s,tags) prods -let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab_v7 (s,tags) +let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags) type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + type 'a glob_extra_genarg_printer = - (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (rawconstr_and_expr -> std_ppcmds) -> + (rawconstr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds -let genarg_pprule_v7 = ref Stringmap.empty let genarg_pprule = ref Stringmap.empty -let declare_extra_genarg_pprule for_v8 (rawwit, f) (globwit, g) (wit, h) = +let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) = let s = match unquote wit with | ExtraArgType s -> s | _ -> error "Can declare a pretty-printing rule only for extra argument types" in - let f prc prtac x = f prc prtac (out_gen rawwit x) in - let g prc prtac x = g prc prtac (out_gen globwit x) in - let h prc prtac x = h prc prtac (out_gen wit x) in - genarg_pprule_v7 := Stringmap.add s (f,g,h) !genarg_pprule_v7; - if for_v8 then - genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule + let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in + let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in + let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in + genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule let pr_arg pr x = spc () ++ pr x @@ -84,14 +79,10 @@ let pr_and_short_name pr (c,_) = pr c let pr_located pr (loc,x) = pr x -let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) - let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Libnames.ConstRef sp) -let pr_inductive ind = pr_global (Libnames.IndRef ind) - let pr_quantified_hypothesis = function | AnonHyp n -> int n | NamedHyp id -> pr_id id @@ -108,12 +99,7 @@ let pr_bindings prc prlc = function prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - prlist_with_sep spc - (fun b -> if Options.do_translate () or not !Options.v7 then - str"(" ++ pr_binding prlc b ++ str")" - else - pr_binding prc b) - l + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_bindings_no_with prc prlc = function @@ -122,21 +108,11 @@ let pr_bindings_no_with prc prlc = function prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ - prlist_with_sep spc - (fun b -> if Options.do_translate () or not !Options.v7 then - str"(" ++ pr_binding prlc b ++ str")" - else - pr_binding prc b) - l + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = - if Options.do_translate () then - (* translator calls pr_with_bindings on rawconstr: we cast it! *) - let bl' = Ppconstrnew.translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in - prc c ++ hv 0 (pr_bindings prc prlc bl') - else - prc c ++ hv 0 (pr_bindings prc prlc bl) + prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_with_constr prc = function | None -> mt () @@ -146,109 +122,10 @@ let pr_with_names = function | None -> mt () | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) -let pr_hyp_location pr_id = function - | id, _, (InHyp,_) -> spc () ++ pr_id id - | id, _, (InHypTypeOnly,_) -> - spc () ++ str "(Type of " ++ pr_id id ++ str ")" - | id, _, _ -> error "Unsupported hyp location in v7" - -let pr_clause pr_id = function - | [] -> mt () - | l -> spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) - - -let pr_clauses pr_id cls = - match cls with - { onhyps = Some l; onconcl = false } -> - spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) - | { onhyps = Some []; onconcl = true } -> mt() - | _ -> error "this clause has both hypothesis and conclusion" - -let pr_simple_clause pr_id = function - | [] -> mt () - | l -> spc () ++ - hov 0 (str "in" ++ spc () ++ prlist_with_sep spc pr_id l) - -let pr_clause_pattern pr_id cls = - pr_opt - (prlist (fun (id,occs,_) -> - prlist (pr_arg int) occs ++ spc () ++ pr_id id)) cls.onhyps ++ - if cls.onconcl then - prlist (pr_arg int) cls.concl_occs ++ spc() ++ str"Goal" - else mt() - -let pr_subterms pr occl = - hov 0 (pr_occurrences pr occl ++ spc () ++ str "with") - -let pr_induction_arg prc = function - | ElimOnConstr c -> prc c - | ElimOnIdent (_,id) -> pr_id id - | ElimOnAnonHyp n -> int n - -let pr_induction_kind = function - | SimpleInversion -> str "Simple Inversion" - | FullInversion -> str "Inversion" - | FullInversionClear -> str "Inversion_clear" - -let pr_match_pattern pr_pat = function - | Term a -> pr_pat a - | Subterm (None,a) -> str "[" ++ pr_pat a ++ str "]" - | Subterm (Some id,a) -> pr_id id ++ str "[" ++ pr_pat a ++ str "]" - -let pr_match_hyps pr_pat = function - | Hyp ((_,na),mp) -> pr_name na ++ str ":" ++ pr_match_pattern pr_pat mp - -let pr_match_rule m pr_pat pr = function - | Pat ([],mp,t) when m -> - str "[" ++ pr_match_pattern pr_pat mp ++ str "]" - ++ spc () ++ str "->" ++ brk (1,2) ++ pr t - | Pat (rl,mp,t) -> - str "[" ++ prlist_with_sep pr_semicolon - (pr_match_hyps pr_pat) rl ++ spc () ++ - str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "]" ++ - spc () ++ str "->" ++ brk (1,2) ++ pr t - | All t -> str "_" ++ spc () ++ str "->" ++ brk (1,2) ++ pr t - -let pr_funvar = function - | None -> spc () ++ str "()" - | Some id -> spc () ++ pr_id id - -let pr_let_clause k pr = function - | ((_,id),None,t) -> hv 0(str k ++ pr_id id ++ str " =" ++ brk (1,1) ++ pr t) - | ((_,id),Some c,t) -> str "TODO(LETCLAUSE)" - -let pr_let_clauses pr = function - | hd::tl -> - hv 0 - (pr_let_clause "Let " pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "And " pr t) tl) - | [] -> anomaly "LetIn must declare at least one binding" - -let pr_rec_clause pr ((_,id),(l,t)) = - pr_id id ++ prlist pr_funvar l ++ str "->" ++ spc () ++ pr t - -let pr_rec_clauses pr l = - prlist_with_sep (fun () -> fnl () ++ str "And ") (pr_rec_clause pr) l - -let pr_hintbases = function - | None -> spc () ++ str "with *" - | Some [] -> mt () - | Some l -> - spc () ++ str "with" ++ hv 0 (prlist (fun s -> spc () ++ str s) l) - -let pr_autoarg_adding = function - | [] -> mt () - | l -> - spc () ++ str "Adding [" ++ - hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" - -let pr_autoarg_destructing = function - | true -> spc () ++ str "Destructing" - | false -> mt () - -let pr_autoarg_usingTDB = function - | true -> spc () ++ str "Using TDB" - | false -> mt () +let rec pr_message_token prid = function + | MsgString s -> qs s + | MsgInt n -> int n + | MsgIdent id -> prid id let rec pr_raw_generic prc prlc prtac prref x = match Genarg.genarg_tag x with @@ -259,24 +136,20 @@ let rec pr_raw_generic prc prlc prtac prref x = | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen rawwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen rawwit_ident x)) - | HypArgType -> pr_arg - (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen rawwit_var x) + | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x) + | VarArgType -> pr_arg (pr_located pr_id) (out_gen rawwit_var x) | RefArgType -> pr_arg prref (out_gen rawwit_ref x) | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x) | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc prref) + pr_arg (pr_may_eval prc prlc prref) (out_gen rawwit_constr_may_eval x) | QuantHypArgType -> pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr - (prc,prref)) (out_gen rawwit_red_expr x) - | TacticArgType -> pr_arg prtac (out_gen rawwit_tactic x) - | OpenConstrArgType -> pr_arg prc (snd (out_gen rawwit_open_constr x)) - | CastedOpenConstrArgType -> - pr_arg prc (snd (out_gen rawwit_casted_open_constr x)) + pr_arg (pr_red_expr (prc,prlc,prref)) (out_gen rawwit_red_expr x) + | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (rawwit_tactic n) x) + | OpenConstrArgType b -> pr_arg prc (snd (out_gen (rawwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x) | BindingsArgType -> @@ -293,10 +166,7 @@ let rec pr_raw_generic prc prlc prtac prref x = pr_raw_generic prc prlc prtac prref b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi1 (Stringmap.find s tab) prc prtac x + try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "] " @@ -309,23 +179,22 @@ let rec pr_glob_generic prc prlc prtac x = | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen globwit_ident x)) - | HypArgType -> pr_arg (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen globwit_var x) + | IdentArgType -> pr_arg pr_id (out_gen globwit_ident x) + | VarArgType -> pr_arg (pr_located pr_id) (out_gen globwit_var x) | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x) | SortArgType -> pr_arg pr_sort (out_gen globwit_sort x) | ConstrArgType -> pr_arg prc (out_gen globwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc + pr_arg (pr_may_eval prc prlc (pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_constr_may_eval x) | QuantHypArgType -> pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x) | RedExprArgType -> pr_arg (pr_red_expr - (prc,pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_red_expr x) - | TacticArgType -> pr_arg prtac (out_gen globwit_tactic x) - | OpenConstrArgType -> pr_arg prc (snd (out_gen globwit_open_constr x)) - | CastedOpenConstrArgType -> - pr_arg prc (snd (out_gen globwit_casted_open_constr x)) + (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference))) + (out_gen globwit_red_expr x) + | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (globwit_tactic n) x) + | OpenConstrArgType b -> pr_arg prc (snd (out_gen (globwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x) | BindingsArgType -> @@ -342,10 +211,7 @@ let rec pr_glob_generic prc prlc prtac x = pr_glob_generic prc prlc prtac b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi2 (Stringmap.find s tab) prc prtac x + try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "] " open Closure @@ -359,8 +225,8 @@ let rec pr_generic prc prlc prtac x = | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen wit_intro_pattern x) - | IdentArgType -> pr_arg pr_id (Constrextern.v7_to_v8_id (out_gen wit_ident x)) - | HypArgType -> pr_arg prc (out_gen wit_var x) + | IdentArgType -> pr_arg pr_id (out_gen wit_ident x) + | VarArgType -> pr_arg pr_id (out_gen wit_var x) | RefArgType -> pr_arg pr_global (out_gen wit_ref x) | SortArgType -> pr_arg prc (Term.mkSort (out_gen wit_sort x)) | ConstrArgType -> pr_arg prc (out_gen wit_constr x) @@ -369,11 +235,10 @@ let rec pr_generic prc prlc prtac x = | QuantHypArgType -> pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr (prc,pr_evaluable_reference)) (out_gen wit_red_expr x) - | TacticArgType -> pr_arg prtac (out_gen wit_tactic x) - | OpenConstrArgType -> pr_arg prc (snd (out_gen wit_open_constr x)) - | CastedOpenConstrArgType -> - pr_arg prc (snd (out_gen wit_casted_open_constr x)) + pr_arg (pr_red_expr (prc,prlc,pr_evaluable_reference)) + (out_gen wit_red_expr x) + | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (wit_tactic n) x) + | OpenConstrArgType b -> pr_arg prc (snd (out_gen (wit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x) | BindingsArgType -> @@ -390,10 +255,7 @@ let rec pr_generic prc prlc prtac x = pr_generic prc prlc prtac b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi3 (Stringmap.find s tab) prc prtac x + try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "]" let rec pr_tacarg_using_rule pr_gen = function @@ -402,364 +264,735 @@ let rec pr_tacarg_using_rule pr_gen = function | [], [] -> mt () | _ -> failwith "Inconsistent arguments of extended tactic" -let pr_extend_gen prgen s l = - let tab = - if Options.do_translate() or not !Options.v7 then prtac_tab - else prtac_tab_v7 - in +let surround p = hov 1 (str"(" ++ p ++ str")") + +let pr_extend_gen prgen lev s l = try let tags = List.map genarg_tag l in - (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *) - let s = - let n = String.length s in - if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "v7" - then String.sub s 0 (n-2) ^ "v8" - else s in - let (s,pl) = Hashtbl.find tab (s,tags) in - str s ++ pr_tacarg_using_rule prgen (pl,l) + let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in + let p = pr_tacarg_using_rule prgen (pl,l) in + if lev' > lev then surround p else p with Not_found -> str s ++ prlist prgen l ++ str " (* Generic printer *)" -let make_pr_tac (pr_tac,pr_tac0,pr_constr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend) = +let pr_raw_extend prc prlc prtac = + pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference) +let pr_glob_extend prc prlc prtac = + pr_extend_gen (pr_glob_generic prc prlc prtac) +let pr_extend prc prlc prtac = + pr_extend_gen (pr_generic prc prlc prtac) + +(**********************************************************************) +(* The tactic printer *) + +let sep_v = fun _ -> str"," ++ spc() + +let strip_prod_binders_expr n ty = + let rec strip_ty acc n ty = + match ty with + Topconstr.CProdN(_,bll,a) -> + let nb = + List.fold_left (fun i (nal,_) -> i + List.length nal) 0 bll in + if nb >= n then (List.rev (bll@acc), a) + else strip_ty (bll@acc) (n-nb) a + | Topconstr.CArrow(_,a,b) -> + if n=1 then + (List.rev (([(dummy_loc,Anonymous)],a)::acc), b) + else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + +let pr_ltac_or_var pr = function + | ArgArg x -> pr x + | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) + +let pr_arg pr x = spc () ++ pr x + +let pr_ltac_constant sp = + pr_qualid (Nametab.shortest_qualid_of_tactic sp) + +let pr_evaluable_reference_env env = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> + Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) + +let pr_inductive env ind = + Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.IndRef ind) + +let pr_quantified_hypothesis = function + | AnonHyp n -> int n + | NamedHyp id -> pr_id id + +let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h + +let pr_esubst prc l = + let pr_qhyp = function + (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" + | (_,NamedHyp id,c) -> + str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" + in + prlist_with_sep spc pr_qhyp l + +let pr_bindings_gen for_ex prlc prc = function + | ImplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ + prlist_with_sep spc prc l) + | ExplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ + pr_esubst prlc l) + | NoBindings -> mt () + +let pr_bindings prlc prc = pr_bindings_gen false prlc prc + +let pr_with_bindings prlc prc (c,bl) = + hov 1 (prc c ++ pr_bindings prlc prc bl) + +let pr_with_constr prc = function + | None -> mt () + | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) + +let pr_with_names = function + | IntroAnonymous -> mt () + | ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) + +let pr_pose prlc prc na c = match na with + | Anonymous -> spc() ++ prc c + | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) + +let pr_assertion _prlc prc ipat c = match ipat with +(* Use this "optimisation" or use only the general case ? + | IntroIdentifier id -> + spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) +*) + | ipat -> + spc() ++ prc c ++ pr_with_names ipat + +let pr_assumption prlc prc ipat c = match ipat with +(* Use this "optimisation" or use only the general case ? + | IntroIdentifier id -> + spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) +*) + | ipat -> + spc() ++ prc c ++ pr_with_names ipat + +let pr_by_tactic prt = function + | TacId [] -> mt () + | tac -> spc() ++ str "by " ++ prt tac + +let pr_occs pp = function + [] -> pp + | nl -> hov 1 (pp ++ spc() ++ str"at " ++ + hov 0 (prlist_with_sep spc int nl)) + +let pr_hyp_location pr_id = function + | id, occs, InHyp -> spc () ++ pr_occs (pr_id id) occs + | id, occs, InHypTypeOnly -> + spc () ++ pr_occs (str "(type of " ++ pr_id id ++ str ")") occs + | id, occs, InHypValueOnly -> + spc () ++ pr_occs (str "(value of " ++ pr_id id ++ str ")") occs + +let pr_in pp = spc () ++ hov 0 (str "in" ++ pp) + +let pr_simple_clause pr_id = function + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) + +let pr_clauses pr_id = function + { onhyps=None; onconcl=true; concl_occs=nl } -> + pr_in (pr_occs (str " *") nl) + | { onhyps=None; onconcl=false } -> pr_in (str " * |-") + | { onhyps=Some l; onconcl=true; concl_occs=nl } -> + pr_in (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l + ++ pr_occs (str" |- *") nl) + | { onhyps=Some l; onconcl=false } -> + pr_in (prlist_with_sep (fun()->str",") (pr_hyp_location pr_id) l) + +let pr_clause_pattern pr_id = function + | (None, []) -> mt () + | (glopt,l) -> + str " in" ++ + prlist + (fun (id,nl) -> prlist (pr_arg int) nl + ++ spc () ++ pr_id id) l ++ + pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt + +let pr_induction_arg prc = function + | ElimOnConstr c -> prc c + | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) + | ElimOnAnonHyp n -> int n + +let pr_induction_kind = function + | SimpleInversion -> str "simple inversion" + | FullInversion -> str "inversion" + | FullInversionClear -> str "inversion_clear" + +let pr_lazy lz = if lz then str "lazy " else mt () + +let pr_match_pattern pr_pat = function + | Term a -> pr_pat a + | Subterm (None,a) -> str "context [" ++ pr_pat a ++ str "]" + | Subterm (Some id,a) -> + str "context " ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]" + +let pr_match_hyps pr_pat = function + | Hyp (nal,mp) -> pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp + +let pr_match_rule m pr pr_pat = function + | Pat ([],mp,t) when m -> + pr_match_pattern pr_pat mp ++ + spc () ++ str "=>" ++ brk (1,4) ++ pr t + | Pat (rl,mp,t) -> + prlist_with_sep (fun () -> str",") (pr_match_hyps pr_pat) rl ++ + spc () ++ str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t + | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t + +let pr_funvar = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + +let pr_let_clause k pr = function + | (id,None,t) -> + hov 0 (str k ++ pr_lident id ++ str " :=" ++ brk (1,1) ++ + pr (TacArg t)) + | (id,Some c,t) -> + hv 0 (str k ++ pr_lident id ++ str" :" ++ brk(1,2) ++ + pr c ++ + str " :=" ++ brk (1,1) ++ pr (TacArg t)) + +let pr_let_clauses pr = function + | hd::tl -> + hv 0 + (pr_let_clause "let " pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl) + | [] -> anomaly "LetIn must declare at least one binding" + +let pr_rec_clause pr (id,(l,t)) = + hov 0 + (pr_lident id ++ prlist pr_funvar l ++ str " :=") ++ spc () ++ pr t + +let pr_rec_clauses pr l = + prlist_with_sep (fun () -> fnl () ++ str "with ") (pr_rec_clause pr) l + +let pr_seq_body pr tl = + hv 0 (str "[ " ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + +let pr_hintbases = function + | None -> spc () ++ str "with *" + | Some [] -> mt () + | Some l -> + spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l) + +let pr_auto_using prc = function + | [] -> mt () + | l -> spc () ++ + hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc l) + +let pr_autoarg_adding = function + | [] -> mt () + | l -> + spc () ++ str "adding [" ++ + hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" + +let pr_autoarg_destructing = function + | true -> spc () ++ str "destructing" + | false -> mt () + +let pr_autoarg_usingTDB = function + | true -> spc () ++ str "using tdb" + | false -> mt () + +let rec pr_tacarg_using_rule pr_gen = function + | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al) + | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al) + | [], [] -> mt () + | _ -> failwith "Inconsistent arguments of extended tactic" + +let pr_then () = str ";" -let pr_bindings = pr_bindings pr_constr pr_constr in -let pr_bindings_no_with = pr_bindings_no_with pr_constr pr_constr in -let pr_with_bindings = pr_with_bindings pr_constr pr_constr in -let pr_eliminator cb = str "using" ++ pr_arg (pr_with_bindings) cb in -let pr_constrarg c = spc () ++ pr_constr c in +let ltop = (5,E) +let lseq = 5 +let ltactical = 3 +let lorelse = 2 +let llet = 1 +let lfun = 1 +let lcomplete = 1 +let labstract = 3 +let lmatch = 1 +let latom = 0 +let lcall = 1 +let leval = 1 +let ltatom = 1 + +let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq + +open Closure + +let make_pr_tac + (pr_tac_level,pr_constr,pr_lconstr,pr_pat, + pr_cst,pr_ind,pr_ref,pr_ident, + pr_extend,strip_prod_binders) = + +let pr_bindings env = + pr_bindings (pr_lconstr env) (pr_constr env) in +let pr_ex_bindings env = + pr_bindings_gen true (pr_lconstr env) (pr_constr env) in +let pr_with_bindings env = + pr_with_bindings (pr_lconstr env) (pr_constr env) in +let pr_eliminator env cb = + str "using" ++ pr_arg (pr_with_bindings env) cb in +let pr_extend env = + pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) in +let pr_red_expr env = + pr_red_expr (pr_constr env,pr_lconstr env,pr_cst env) in + +let pr_constrarg env c = spc () ++ pr_constr env c in +let pr_lconstrarg env c = spc () ++ pr_lconstr env c in let pr_intarg n = spc () ++ int n in +let pr_binder_fix env (nal,t) = +(* match t with + | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal + | _ ->*) + let s = + prlist_with_sep spc (pr_lname) nal ++ str ":" ++ + pr_lconstr env t in + spc() ++ hov 1 (str"(" ++ s ++ str")") in + +let pr_fix_tac env (id,n,c) = + let rec set_nth_name avoid n = function + (nal,ty)::bll -> + if n <= List.length nal then + match list_chop (n-1) nal with + _, (_,Name id) :: _ -> id, (nal,ty)::bll + | bef, (loc,Anonymous) :: aft -> + let id = next_ident_away_from (id_of_string"y") avoid in + id, ((bef@(loc,Name id)::aft, ty)::bll) + | _ -> assert false + else + let (id,bll') = set_nth_name avoid (n-List.length nal) bll in + (id,(nal,ty)::bll') + | [] -> assert false in + let (bll,ty) = strip_prod_binders n c in + let names = + List.fold_left + (fun ln (nal,_) -> List.fold_left + (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) + ln nal) + [] bll in + let idarg,bll = set_nth_name names n bll in + let annot = + if List.length names = 1 then mt() + else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in + hov 1 (str"(" ++ pr_id id ++ + prlist (pr_binder_fix env) bll ++ annot ++ str" :" ++ + pr_lconstrarg env ty ++ str")") in +(* spc() ++ + hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg + env c) +*) +let pr_cofix_tac env (id,c) = + hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg env c ++ str")") in + (* Printing tactics as arguments *) -let rec pr_atom0 = function - | TacIntroPattern [] -> str "Intros" - | TacIntroMove (None,None) -> str "Intro" - | TacAssumption -> str "Assumption" - | TacAnyConstructor None -> str "Constructor" - | TacTrivial (Some []) -> str "Trivial" - | TacAuto (None,Some []) -> str "Auto" - | TacAutoTDB None -> str "AutoTDB" - | TacDestructConcl -> str "DConcl" - | TacReflexivity -> str "Reflexivity" - | t -> str "(" ++ pr_atom1 t ++ str ")" +let rec pr_atom0 env = function + | TacIntroPattern [] -> str "intros" + | TacIntroMove (None,None) -> str "intro" + | TacAssumption -> str "assumption" + | TacAnyConstructor None -> str "constructor" + | TacTrivial ([],Some []) -> str "trivial" + | TacAuto (None,[],Some []) -> str "auto" + | TacReflexivity -> str "reflexivity" + | t -> str "(" ++ pr_atom1 env t ++ str ")" (* Main tactic printer *) -and pr_atom1 = function - | TacExtend (_,s,l) -> pr_extend pr_constr pr_constr pr_tac s l - | TacAlias (_,s,l,_) -> - pr_extend pr_constr pr_constr pr_tac s (List.map snd l) +and pr_atom1 env = function + | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl + | TacSuperAuto _ | TacExtend (_, + ("GTauto"|"GIntuition"|"TSimplif"| + "LinearIntuition"),_) -> + errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0") + | TacExtend (loc,s,l) -> + pr_with_comments loc (pr_extend env 1 s l) + | TacAlias (loc,s,l,_) -> + pr_with_comments loc (pr_extend env 1 s (List.map snd l)) (* Basic tactics *) - | TacIntroPattern [] as t -> pr_atom0 t + | TacIntroPattern [] as t -> pr_atom0 env t | TacIntroPattern (_::_ as p) -> - hov 1 (str "Intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) + hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) | TacIntrosUntil h -> - hv 1 (str "Intros until" ++ pr_arg pr_quantified_hypothesis h) - | TacIntroMove (None,None) as t -> pr_atom0 t - | TacIntroMove (Some id1,None) -> str "Intro " ++ pr_id id1 - | TacIntroMove (ido1,Some (_,id2)) -> + hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h) + | TacIntroMove (None,None) as t -> pr_atom0 env t + | TacIntroMove (Some id1,None) -> str "intro " ++ pr_id id1 + | TacIntroMove (ido1,Some id2) -> hov 1 - (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2) - | TacAssumption as t -> pr_atom0 t - | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c) - | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb) + (str "intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ + pr_lident id2) + | TacAssumption as t -> pr_atom0 env t + | TacExact c -> hov 1 (str "exact" ++ pr_constrarg env c) + | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg env c) + | TacApply cb -> hov 1 (str "apply" ++ spc () ++ pr_with_bindings env cb) | TacElim (cb,cbo) -> - hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ - pr_opt pr_eliminator cbo) - | TacElimType c -> hov 1 (str "ElimType" ++ pr_arg pr_constr c) - | TacCase cb -> hov 1 (str "Case" ++ spc () ++ pr_with_bindings cb) - | TacCaseType c -> hov 1 (str "CaseType" ++ pr_arg pr_constr c) - | TacFix (ido,n) -> hov 1 (str "Fix" ++ pr_opt pr_id ido ++ pr_intarg n) + hov 1 (str "elim" ++ pr_arg (pr_with_bindings env) cb ++ + pr_opt (pr_eliminator env) cbo) + | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg env c) + | TacCase cb -> hov 1 (str "case" ++ spc () ++ pr_with_bindings env cb) + | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg env c) + | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n) | TacMutualFix (id,n,l) -> - hov 1 (str "Fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc () ++ - hov 0 (str "with" ++ brk (1,1) ++ - prlist_with_sep spc - (fun (id,n,c) -> - spc () ++ pr_id id ++ pr_intarg n ++ pr_arg pr_constr c) - l)) - | TacCofix ido -> hov 1 (str "Cofix" ++ pr_opt pr_id ido) + hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++ + str"with " ++ prlist_with_sep spc (pr_fix_tac env) l) + | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido) | TacMutualCofix (id,l) -> - hov 1 (str "Cofix" ++ spc () ++ pr_id id ++ spc () ++ - hov 0 (str "with" ++ brk (1,1) ++ - prlist (fun (id,c) -> spc () ++ pr_id id ++ pr_arg pr_constr c) - l)) - | TacCut c -> hov 1 (str "Cut" ++ pr_arg pr_constr c) - | TacTrueCut (Anonymous,c) -> - hov 1 (str "Assert" ++ pr_arg pr_constr c) - | TacTrueCut (Name id,c) -> - hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c) - | TacForward (false,na,c) -> - hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) - | TacForward (true,na,c) -> - hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) + hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++ + str"with " ++ prlist_with_sep spc (pr_cofix_tac env) l) + | TacCut c -> hov 1 (str "cut" ++ pr_constrarg env c) + | TacAssert (Some tac,ipat,c) -> + hov 1 (str "assert" ++ + pr_assumption (pr_lconstr env) (pr_constr env) ipat c ++ + pr_by_tactic (pr_tac_level env ltop) tac) + | TacAssert (None,ipat,c) -> + hov 1 (str "pose proof" ++ + pr_assertion (pr_lconstr env) (pr_constr env) ipat c) | TacGeneralize l -> - hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l) + hov 1 (str "generalize" ++ spc () ++ + prlist_with_sep spc (pr_constr env) l) | TacGeneralizeDep c -> - hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++ - pr_constr c) + hov 1 (str "generalize" ++ spc () ++ str "dependent" ++ + pr_constrarg env c) + | TacLetTac (na,c,cl) when cl = nowhere -> + hov 1 (str "pose" ++ pr_pose (pr_lconstr env) (pr_constr env) na c) | TacLetTac (na,c,cl) -> - let pcl = match cl with - {onhyps=None;onconcl=true;concl_occs=[]} -> mt() - | _ -> pr_clauses pr_ident cl in - hov 1 (str "LetTac" ++ spc () ++ pr_name na ++ str ":=" ++ - pr_constr c ++ pcl) - | TacInstantiate (n,c,cls) -> - hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ++ - pr_clauses pr_ident cls) + hov 1 (str "set" ++ pr_pose (pr_lconstr env) (pr_constr env) na c ++ + pr_clauses pr_ident cl) +(* | TacInstantiate (n,c,ConclLocation ()) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg env c ++ str ")" )) + | TacInstantiate (n,c,HypLocation (id,hloc)) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg env c ++ str ")" ) + ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) +*) (* Derived basic tactics *) - | TacSimpleInduction (h,_) -> - hov 1 (str "Induction" ++ pr_arg pr_quantified_hypothesis h) - | TacNewInduction (h,e,(ids,_)) -> - hov 1 (str "NewInduction" ++ spc () ++ pr_induction_arg pr_constr h ++ - pr_opt pr_eliminator e ++ pr_with_names ids) + | TacSimpleInduction h -> + hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h) + | TacNewInduction (h,e,ids) -> + hov 1 (str "induction" ++ spc () ++ + prlist_with_sep spc (pr_induction_arg (pr_constr env)) h ++ + pr_opt (pr_eliminator env) e) | TacSimpleDestruct h -> - hov 1 (str "Destruct" ++ pr_arg pr_quantified_hypothesis h) - | TacNewDestruct (h,e,(ids,_)) -> - hov 1 (str "NewDestruct" ++ spc () ++ pr_induction_arg pr_constr h ++ - pr_opt pr_eliminator e ++ pr_with_names ids) + hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h) + | TacNewDestruct (h,e,ids) -> + hov 1 (str "destruct" ++ spc () ++ + prlist_with_sep spc (pr_induction_arg (pr_constr env)) h ++ + pr_with_names ids ++ + pr_opt (pr_eliminator env) e) | TacDoubleInduction (h1,h2) -> hov 1 - (str "Double Induction" ++ + (str "double induction" ++ pr_arg pr_quantified_hypothesis h1 ++ pr_arg pr_quantified_hypothesis h2) | TacDecomposeAnd c -> - hov 1 (str "Decompose Record" ++ pr_arg pr_constr c) + hov 1 (str "decompose record" ++ pr_constrarg env c) | TacDecomposeOr c -> - hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c) + hov 1 (str "decompose sum" ++ pr_constrarg env c) | TacDecompose (l,c) -> - hov 1 (str "Decompose" ++ spc () ++ - hov 0 (str "[" ++ prlist_with_sep spc pr_ind l - ++ str "]" ++ pr_arg pr_constr c)) + hov 1 (str "decompose" ++ spc () ++ + hov 0 (str "[" ++ prlist_with_sep spc (pr_ind env) l + ++ str "]" ++ pr_constrarg env c)) | TacSpecialize (n,c) -> - hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c) + hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ + pr_with_bindings env c) | TacLApply c -> - hov 1 (str "LApply" ++ pr_constr c) + hov 1 (str "lapply" ++ pr_constrarg env c) (* Automation tactics *) - | TacTrivial (Some []) as x -> pr_atom0 x - | TacTrivial db -> hov 0 (str "Trivial" ++ pr_hintbases db) - | TacAuto (None,Some []) as x -> pr_atom0 x - | TacAuto (n,db) -> - hov 0 (str "Auto" ++ pr_opt (pr_or_var int) n ++ pr_hintbases db) - | TacAutoTDB None as x -> pr_atom0 x - | TacAutoTDB (Some n) -> hov 0 (str "AutoTDB" ++ spc () ++ int n) - | TacDestructHyp (true,(_,id)) -> hov 0 (str "CDHyp" ++ spc () ++ pr_id id) - | TacDestructHyp (false,(_,id)) -> hov 0 (str "DHyp" ++ spc () ++ pr_id id) - | TacDestructConcl as x -> pr_atom0 x - | TacSuperAuto (n,l,b1,b2) -> - hov 1 (str "SuperAuto" ++ pr_opt int n ++ pr_autoarg_adding l ++ - pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2) + | TacTrivial ([],Some []) as x -> pr_atom0 env x + | TacTrivial (lems,db) -> + hov 0 (str "trivial" ++ + pr_auto_using (pr_constr env) lems ++ pr_hintbases db) + | TacAuto (None,[],Some []) as x -> pr_atom0 env x + | TacAuto (n,lems,db) -> + hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ + pr_auto_using (pr_constr env) lems ++ pr_hintbases db) | TacDAuto (n,p) -> - hov 1 (str "Auto" ++ pr_opt (pr_or_var int) n ++ str "Decomp" ++ - pr_opt int p) + hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ pr_opt int p) (* Context management *) - | TacClear l -> - hov 1 (str "Clear" ++ spc () ++ prlist_with_sep spc pr_ident l) + | TacClear (keep,l) -> + hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++ + prlist_with_sep spc pr_ident l) | TacClearBody l -> - hov 1 (str "ClearBody" ++ spc () ++ prlist_with_sep spc pr_ident l) + hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l) | TacMove (b,id1,id2) -> (* Rem: only b = true is available for users *) assert b; hov 1 - (str "Move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ + (str "move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ str "after" ++ brk (1,1) ++ pr_ident id2) | TacRename (id1,id2) -> hov 1 - (str "Rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ + (str "rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ str "into" ++ brk (1,1) ++ pr_ident id2) (* Constructors *) - | TacLeft l -> hov 1 (str "Left" ++ pr_bindings l) - | TacRight l -> hov 1 (str "Right" ++ pr_bindings l) - | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l) + | TacLeft l -> hov 1 (str "left" ++ pr_bindings env l) + | TacRight l -> hov 1 (str "right" ++ pr_bindings env l) + | TacSplit (false,l) -> hov 1 (str "split" ++ pr_bindings env l) + | TacSplit (true,l) -> hov 1 (str "exists" ++ pr_ex_bindings env l) | TacAnyConstructor (Some t) -> - hov 1 (str "Constructor" ++ pr_arg pr_tac0 t) - | TacAnyConstructor None as t -> pr_atom0 t + hov 1 (str "constructor" ++ pr_arg (pr_tac_level env (latom,E)) t) + | TacAnyConstructor None as t -> pr_atom0 env t | TacConstructor (n,l) -> - hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l) + hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings env l) (* Conversion *) | TacReduce (r,h) -> - hov 1 (pr_red_expr (pr_constr,pr_cst) r ++ pr_clauses pr_ident h) - | TacChange (occl,c,h) -> - hov 1 (str "Change" ++ pr_opt (pr_subterms pr_constr) occl ++ - brk (1,1) ++ pr_constr c ++ pr_clauses pr_ident h) + hov 1 (pr_red_expr env r ++ + pr_clauses pr_ident h) + | TacChange (occ,c,h) -> + hov 1 (str "change" ++ brk (1,1) ++ + (match occ with + None -> mt() + | Some([],c1) -> hov 1 (pr_constr env c1 ++ spc() ++ str "with ") + | Some(ocl,c1) -> + hov 1 (pr_constr env c1 ++ spc() ++ + str "at " ++ prlist_with_sep spc int ocl) ++ spc() ++ + str "with ") ++ + pr_constr env c ++ pr_clauses pr_ident h) (* Equivalence relations *) - | TacReflexivity as x -> pr_atom0 x - | TacSymmetry cls -> str "Symmetry " ++ pr_clauses pr_ident cls - | TacTransitivity c -> str "Transitivity" ++ pr_arg pr_constr c + | TacReflexivity as x -> pr_atom0 env x + | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls + | TacTransitivity c -> str "transitivity" ++ pr_constrarg env c (* Equality and inversion *) | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 (str "Dependent " ++ pr_induction_kind k ++ + hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ - pr_with_names ids ++ pr_with_constr pr_constr c) + pr_with_names ids ++ pr_with_constr (pr_constr env) c) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 (pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ pr_with_names ids ++ pr_simple_clause pr_ident cl) | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 (str "Inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ - str "using" ++ spc () ++ pr_constr c ++ + hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ + spc () ++ str "using" ++ spc () ++ pr_constr env c ++ pr_simple_clause pr_ident cl) -and pr_tactic_seq_body tl = - hv 0 (str "[ " ++ - prlist_with_sep (fun () -> spc () ++ str "| ") prtac tl ++ str " ]") - - (* Strictly closed atomic tactic expressions *) -and pr0 = function - | TacFirst tl -> str "First" ++ spc () ++ pr_tactic_seq_body tl - | TacSolve tl -> str "Solve" ++ spc () ++ pr_tactic_seq_body tl - | TacId "" -> str "Idtac" - | TacFail (ArgArg 0,"") -> str "Fail" - | TacAtom (_,t) -> pr_atom0 t - | TacArg c -> pr_tacarg c - | t -> str "(" ++ prtac t ++ str ")" - - (* Semi-closed atomic tactic expressions *) -and pr1 = function - | TacAtom (_,t) -> pr_atom1 t - | TacId s -> str "Idtac \"" ++ str s ++ str "\"" - | TacFail (ArgArg 0,s) -> str "Fail \"" ++ str s ++ str "\"" - | TacFail (n,"") -> str "Fail " ++ pr_or_var int n - | TacFail (n,s) -> str "Fail " ++ pr_or_var int n ++ str " \"" ++ str s ++ str "\"" - | t -> pr0 t - - (* Orelse tactic expressions (printed as if parsed associating on the right - though the semantics is purely associative) *) -and pr2 = function - | TacOrelse (t1,t2) -> - hov 1 (pr1 t1 ++ str " Orelse" ++ brk (1,1) ++ pr3 t2) - | t -> pr1 t - - (* Non closed prefix tactic expressions *) -and pr3 = function - | TacTry t -> hov 1 (str "Try" ++ spc () ++ pr3 t) - | TacDo (n,t) -> hov 1 (str "Do " ++ pr_or_var int n ++ spc () ++ pr3 t) - | TacRepeat t -> hov 1 (str "Repeat" ++ spc () ++ pr3 t) - | TacProgress t -> hov 1 (str "Progress" ++ spc () ++ pr3 t) - | TacInfo t -> hov 1 (str "Info" ++ spc () ++ pr3 t) - | t -> pr2 t - -and pr4 = function - | t -> pr3 t - - (* THEN and THENS tactic expressions (printed as if parsed - associating on the left though the semantics is purely associative) *) -and pr5 = function - | TacThens (t,tl) -> - hov 1 (pr5 t ++ str ";" ++ spc () ++ pr_tactic_seq_body tl) - | TacThen (t1,t2) -> - hov 1 (pr5 t1 ++ str ";" ++ spc () ++ pr4 t2) - | t -> pr4 t - - (* Ltac tactic expressions *) -and pr6 = function - |(TacAtom _ - | TacThen _ - | TacThens _ - | TacFirst _ - | TacSolve _ - | TacTry _ - | TacOrelse _ - | TacDo _ - | TacRepeat _ - | TacProgress _ - | TacId _ - | TacFail _ - | TacInfo _) as t -> pr5 t - - | TacAbstract (t,None) -> str "Abstract " ++ pr6 t +in + +let rec pr_tac env inherited tac = + let (strm,prec) = match tac with + | TacAbstract (t,None) -> + str "abstract " ++ pr_tac env (labstract,L) t, labstract | TacAbstract (t,Some s) -> hov 0 - (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s) + (str "abstract (" ++ pr_tac env (labstract,L) t ++ str")" ++ spc () ++ + str "using " ++ pr_id s), + labstract | TacLetRecIn (l,t) -> hv 0 - (str "Rec " ++ pr_rec_clauses prtac l ++ - spc () ++ str "In" ++ fnl () ++ prtac t) + (str "let rec " ++ pr_rec_clauses (pr_tac env ltop) l ++ str " in" ++ + fnl () ++ pr_tac env (llet,E) t), + llet | TacLetIn (llc,u) -> v 0 - (hv 0 (pr_let_clauses pr_tacarg0 llc ++ spc () ++ str "In") ++ fnl () ++ prtac u) - | TacMatch (t,lrul) -> - hov 0 (str "Match" ++ spc () ++ pr6 t ++ spc() - ++ str "With" + (hv 0 (pr_let_clauses (pr_tac env ltop) llc + ++ str " in") ++ + fnl () ++ pr_tac env (llet,E) u), + llet + | TacMatch (lz,t,lrul) -> + hov 0 (pr_lazy lz ++ str "match " ++ pr_tac env ltop t ++ str " with" ++ prlist - (fun r -> fnl () ++ str "|" ++ spc () ++ - pr_match_rule true pr_pat prtac r) - lrul) - | TacMatchContext (lr,lrul) -> - hov 0 ( - str (if lr then "Match Reverse Context With" else "Match Context With") + (fun r -> fnl () ++ str "| " ++ + pr_match_rule true (pr_tac env ltop) pr_pat r) + lrul + ++ fnl() ++ str "end"), + lmatch + | TacMatchContext (lz,lr,lrul) -> + hov 0 (pr_lazy lz ++ + str (if lr then "match reverse goal with" else "match goal with") ++ prlist - (fun r -> fnl () ++ str "|" ++ spc () ++ - pr_match_rule false pr_pat prtac r) - lrul) + (fun r -> fnl () ++ str "| " ++ + pr_match_rule false (pr_tac env ltop) pr_pat r) + lrul + ++ fnl() ++ str "end"), + lmatch | TacFun (lvar,body) -> - hov 0 (str "Fun" ++ - prlist pr_funvar lvar ++ spc () ++ str "->" ++ spc () ++ prtac body) - - | TacArg c -> pr_tacarg c - -and pr_tacarg0 = function - | TacDynamic (_,t) -> str ("<dynamic ["^(Dyn.tag t)^"]>") - | MetaIdArg (_,s) -> str ("$" ^ s) - | IntroPattern ipat -> pr_intro_pattern ipat +(* let env = List.fold_right (option_fold_right Idset.add) lvar env in*) + hov 2 (str "fun" ++ + prlist pr_funvar lvar ++ str " =>" ++ spc () ++ + pr_tac env (lfun,E) body), + lfun + | TacThens (t,tl) -> + hov 1 (pr_tac env (lseq,E) t ++ pr_then () ++ spc () ++ + pr_seq_body (pr_tac env ltop) tl), + lseq + | TacThen (t1,t2) -> + hov 1 (pr_tac env (lseq,E) t1 ++ pr_then () ++ spc () ++ + pr_tac env (lseq,L) t2), + lseq + | TacTry t -> + hov 1 (str "try" ++ spc () ++ pr_tac env (ltactical,E) t), + ltactical + | TacDo (n,t) -> + hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ + pr_tac env (ltactical,E) t), + ltactical + | TacRepeat t -> + hov 1 (str "repeat" ++ spc () ++ pr_tac env (ltactical,E) t), + ltactical + | TacProgress t -> + hov 1 (str "progress" ++ spc () ++ pr_tac env (ltactical,E) t), + ltactical + | TacInfo t -> + hov 1 (str "info" ++ spc () ++ pr_tac env (ltactical,E) t), + ltactical + | TacOrelse (t1,t2) -> + hov 1 (pr_tac env (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++ + pr_tac env (lorelse,E) t2), + lorelse + | TacFail (n,l) -> + str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ + prlist (pr_arg (pr_message_token pr_ident)) l, latom + | TacFirst tl -> + str "first" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet + | TacSolve tl -> + str "solve" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet + | TacComplete t -> + str "complete" ++ spc () ++ pr_tac env (lcomplete,E) t, lcomplete + | TacId l -> + str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom + | TacAtom (loc,TacAlias (_,s,l,_)) -> + pr_with_comments loc + (pr_extend env (level_of inherited) s (List.map snd l)), + latom + | TacAtom (loc,t) -> + pr_with_comments loc (hov 1 (pr_atom1 env t)), ltatom + | TacArg(Tacexp e) -> pr_tac_level env (latom,E) e, latom + | TacArg(ConstrMayEval (ConstrTerm c)) -> + str "constr:" ++ pr_constr env c, latom + | TacArg(ConstrMayEval c) -> + pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c, leval + | TacArg(TacFreshId sopt) -> str "fresh" ++ pr_opt qs sopt, latom + | TacArg(Integer n) -> int n, latom + | TacArg(TacCall(loc,f,l)) -> + pr_with_comments loc + (hov 1 (pr_ref f ++ spc () ++ + prlist_with_sep spc (pr_tacarg env) l)), + lcall + | TacArg a -> pr_tacarg env a, latom + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + +and pr_tacarg env = function + | TacDynamic (loc,t) -> + pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>")) + | MetaIdArg (loc,s) -> pr_with_comments loc (str ("$" ^ s)) + | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat | TacVoid -> str "()" | Reference r -> pr_ref r - | ConstrMayEval (ConstrTerm c) -> str "'" ++ pr_constr c - | ConstrMayEval c -> pr_may_eval pr_constr pr_cst c - | Integer n -> int n - | TacFreshId sopt -> str "FreshId" ++ pr_opt qstring sopt - | (TacCall _ | Tacexp _) as t -> str "(" ++ pr_tacarg1 t ++ str ")" - -and pr_tacarg1 = function - | TacCall (_,f,l) -> - hov 0 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg0 l) - | Tacexp t -> pr_tac t - | t -> pr_tacarg0 t - -and pr_tacarg x = pr_tacarg1 x - -and prtac x = pr6 x - -in (prtac,pr0,pr_match_rule false pr_pat pr_tac) - -let pr_raw_extend prc prlc prtac = - pr_extend_gen (pr_raw_generic prc prlc prtac Ppconstrnew.pr_reference) -let pr_glob_extend prc prlc prtac = - pr_extend_gen (pr_glob_generic prc prlc prtac) -let pr_extend prc prlc prtac = - pr_extend_gen (pr_generic prc prlc prtac) + | ConstrMayEval c -> + pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c + | TacFreshId sopt -> str "fresh" ++ pr_opt qs sopt + | TacExternal (_,com,req,la) -> + str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ + spc() ++ prlist_with_sep spc (pr_tacarg env) la + | (TacCall _|Tacexp _|Integer _) as a -> + str "ltac:" ++ pr_tac env (latom,E) (TacArg a) + +in (pr_tac, pr_match_rule) + +let strip_prod_binders_rawterm n (ty,_) = + let rec strip_ty acc n ty = + if n=0 then (List.rev acc, (ty,None)) else + match ty with + Rawterm.RProd(loc,na,a,b) -> + strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + +let strip_prod_binders_constr n ty = + let rec strip_ty acc n ty = + if n=0 then (List.rev acc, ty) else + match Term.kind_of_term ty with + Term.Prod(na,a,b) -> + strip_ty (([dummy_loc,na],a)::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + +let drop_env f _env = f + +let rec raw_printers = + (pr_raw_tactic_level, + drop_env pr_constr_expr, + drop_env pr_lconstr_expr, + pr_pattern_expr, + drop_env pr_reference, + drop_env pr_reference, + pr_reference, + pr_or_metaid pr_lident, + pr_raw_extend, + strip_prod_binders_expr) + +and pr_raw_tactic_level env n (t:raw_tactic_expr) = + fst (make_pr_tac raw_printers) env n t + +and pr_raw_match_rule env t = + snd (make_pr_tac raw_printers) env t let pr_and_constr_expr pr (c,_) = pr c let rec glob_printers = - (pr_glob_tactic, - pr_glob_tactic0, - pr_and_constr_expr Printer.pr_rawterm, - Printer.pr_pattern, - pr_or_var (pr_and_short_name pr_evaluable_reference), - pr_or_var pr_inductive, - pr_or_var (pr_located pr_ltac_constant), - pr_located pr_id, - pr_glob_extend) - -and pr_glob_tactic (t:glob_tactic_expr) = pi1 (make_pr_tac glob_printers) t - -and pr_glob_tactic0 t = pi2 (make_pr_tac glob_printers) t - -and pr_glob_match_context t = pi3 (make_pr_tac glob_printers) t - -let (pr_tactic,_,_) = + (pr_glob_tactic_level, + (fun env -> pr_and_constr_expr (pr_rawconstr_env env)), + (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)), + (fun c -> pr_constr_pattern_env (Global.env()) c), + (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))), + (fun env -> pr_or_var (pr_inductive env)), + pr_ltac_or_var (pr_located pr_ltac_constant), + pr_lident, + pr_glob_extend, + strip_prod_binders_rawterm) + +and pr_glob_tactic_level env n (t:glob_tactic_expr) = + fst (make_pr_tac glob_printers) env n t + +and pr_glob_match_rule env t = + snd (make_pr_tac glob_printers) env t + +let ((pr_tactic_level:Environ.env -> tolerability -> Proof_type.tactic_expr -> std_ppcmds),_) = make_pr_tac - (pr_glob_tactic, - pr_glob_tactic0, - Printer.prterm, - Printer.pr_pattern, - pr_evaluable_reference, + (pr_glob_tactic_level, + pr_constr_env, + pr_lconstr_env, + pr_constr_pattern, + pr_evaluable_reference_env, pr_inductive, pr_ltac_constant, pr_id, - pr_extend) + pr_extend, + strip_prod_binders_constr) + +let pr_raw_tactic env = pr_raw_tactic_level env ltop +let pr_glob_tactic env = pr_glob_tactic_level env ltop +let pr_tactic env = pr_tactic_level env ltop + +let _ = Tactic_debug.set_tactic_printer + (fun x -> pr_glob_tactic (Global.env()) x) + +let _ = Tactic_debug.set_match_pattern_printer + (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp) + +let _ = Tactic_debug.set_match_rule_printer + (fun rl -> + pr_match_rule false (pr_glob_tactic (Global.env())) pr_constr_pattern rl) diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index 5c3035ba..ccdf3776 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pptactic.mli,v 1.9.2.3 2005/12/23 22:16:46 herbelin Exp $ i*) +(*i $Id: pptactic.mli 7937 2006-01-28 19:58:11Z herbelin $ i*) open Pp open Genarg @@ -15,27 +15,33 @@ open Pretyping open Proof_type open Topconstr open Rawterm +open Ppextend +open Environ val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds -val pr_located : ('a -> std_ppcmds) -> 'a Util.located -> std_ppcmds type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds type 'a glob_extra_genarg_printer = - (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (rawconstr_and_expr -> std_ppcmds) -> + (rawconstr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds (* if the boolean is false then the extension applies only to old syntax *) val declare_extra_genarg_pprule : - bool -> ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> ('b closed_abstract_argument_type * 'b extra_genarg_printer) -> unit @@ -43,44 +49,42 @@ val declare_extra_genarg_pprule : type grammar_terminals = string option list (* if the boolean is false then the extension applies only to old syntax *) -val declare_extra_tactic_pprule : bool -> string -> - argument_type list * (string * grammar_terminals) -> unit +val declare_extra_tactic_pprule : + string * argument_type list * (int * grammar_terminals) -> unit val exists_extra_tactic_pprule : string -> argument_type list -> bool -val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds - -val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('a,'b) match_rule -> std_ppcmds - -val pr_glob_tactic : glob_tactic_expr -> std_ppcmds - -val pr_tactic : Proof_type.tactic_expr -> std_ppcmds - -val pr_glob_generic: - (rawconstr_and_expr -> std_ppcmds) -> - (rawconstr_and_expr -> std_ppcmds) -> - (glob_tactic_expr -> std_ppcmds) -> - glob_generic_argument -> std_ppcmds - val pr_raw_generic : (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> - (raw_tactic_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> (Libnames.reference -> std_ppcmds) -> (constr_expr, raw_tactic_expr) generic_argument -> std_ppcmds val pr_raw_extend: (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> - (raw_tactic_expr -> std_ppcmds) -> string -> - raw_generic_argument list -> std_ppcmds + (tolerability -> raw_tactic_expr -> std_ppcmds) -> int -> + string -> raw_generic_argument list -> std_ppcmds val pr_glob_extend: (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) -> - (glob_tactic_expr -> std_ppcmds) -> string -> - glob_generic_argument list -> std_ppcmds + (tolerability -> glob_tactic_expr -> std_ppcmds) -> int -> + string -> glob_generic_argument list -> std_ppcmds val pr_extend : (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (glob_tactic_expr -> std_ppcmds) -> string -> closed_generic_argument list -> std_ppcmds + (tolerability -> glob_tactic_expr -> std_ppcmds) -> int -> + string -> closed_generic_argument list -> std_ppcmds + +val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds + +val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds + +val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + +val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds + +val pr_hintbases : string list option -> std_ppcmds + +val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml new file mode 100644 index 00000000..0b6e5771 --- /dev/null +++ b/parsing/ppvernac.ml @@ -0,0 +1,841 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ppvernac.ml 8624 2006-03-13 17:38:17Z msozeau $ *) + +open Pp +open Names +open Nameops +open Nametab +open Util +open Extend +open Vernacexpr +open Ppconstr +open Pptactic +open Rawterm +open Genarg +open Pcoq +open Libnames +open Ppextend +open Topconstr +open Decl_kinds +open Tacinterp + +let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr + +let pr_lident (b,_ as loc,id) = + if loc <> dummy_loc then + let (b,_) = unloc loc in + pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) + else pr_id id + +let string_of_fqid fqid = + String.concat "." (List.map string_of_id fqid) + +let pr_fqid fqid = str (string_of_fqid fqid) + +let pr_lfqid (_,_ as loc,fqid) = + if loc <> dummy_loc then + let (b,_) = unloc loc in + pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid) + else + pr_fqid fqid + +let pr_lname = function + (loc,Name id) -> pr_lident (loc,id) + | lna -> pr_located pr_name lna + +let pr_ltac_id = Nameops.pr_id + +let pr_module = Libnames.pr_reference + +let pr_import_module = Libnames.pr_reference + +let sep_end () = str"." + +(* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *) + +let pr_raw_tactic_env l env t = + pr_glob_tactic env (Tacinterp.glob_tactic_env l env t) + +let pr_gen env t = + pr_raw_generic + pr_constr_expr + pr_lconstr_expr + (pr_raw_tactic_level env) pr_reference t + +let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac + +let rec extract_signature = function + | [] -> [] + | Egrammar.TacNonTerm (_,(_,t),_) :: l -> t :: extract_signature l + | _::l -> extract_signature l + +let rec match_vernac_rule tys = function + [] -> raise Not_found + | pargs::rls -> + if extract_signature pargs = tys then pargs + else match_vernac_rule tys rls + +let sep = fun _ -> spc() +let sep_p = fun _ -> str"." +let sep_v = fun _ -> str"," +let sep_v2 = fun _ -> str"," ++ spc() +let sep_pp = fun _ -> str":" + +let pr_ne_sep sep pr = function + [] -> mt() + | l -> sep() ++ pr l + +let pr_entry_prec = function + | Some Gramext.LeftA -> str"LEFTA " + | Some Gramext.RightA -> str"RIGHTA " + | Some Gramext.NonA -> str"NONA " + | None -> mt() + +let pr_prec = function + | Some Gramext.LeftA -> str", left associativity" + | Some Gramext.RightA -> str", right associativity" + | Some Gramext.NonA -> str", no associativity" + | None -> mt() + +let pr_set_entry_type = function + | ETIdent -> str"ident" + | ETReference -> str"global" + | ETPattern -> str"pattern" + | ETConstr _ -> str"constr" + | ETOther (_,e) -> str e + | ETBigint -> str "bigint" + | ETConstrList _ -> failwith "Internal entry type" + +let strip_meta id = + let s = string_of_id id in + if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) + else id + +let pr_production_item = function + | VNonTerm (loc,nt,Some p) -> str nt ++ str"(" ++ pr_id (strip_meta p) ++ str")" + | VNonTerm (loc,nt,None) -> str nt + | VTerm s -> qs s + +let pr_comment pr_c = function + | CommentConstr c -> pr_c c + | CommentString s -> qs s + | CommentInt n -> int n + +let pr_in_out_modules = function + | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l + | SearchOutside [] -> mt() + | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l + +let pr_search_about = function + | SearchRef r -> pr_reference r + | SearchString s -> qs s + +let pr_search a b pr_p = match a with + | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b + | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b + | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b + | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b + +let pr_locality local = if local then str "Local " else str "" + +let pr_explanation imps = function + | ExplByPos n -> pr_id (Impargs.name_of_implicit (List.nth imps (n-1))) + | ExplByName id -> pr_id id + +let pr_class_rawexpr = function + | FunClass -> str"Funclass" + | SortClass -> str"Sortclass" + | RefClass qid -> pr_reference qid + +let pr_option_ref_value = function + | QualidRefValue id -> pr_reference id + | StringRefValue s -> qs s + +let pr_printoption a b = match a with + | Goptions.PrimaryTable table -> str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b + | Goptions.SecondaryTable (table,field) -> str table ++ spc() ++ str field ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b + +let pr_set_option a b = + let pr_opt_value = function + | IntValue n -> spc() ++ int n + | StringValue s -> spc() ++ str s + | BoolValue b -> mt() + in pr_printoption a None ++ pr_opt_value b + +let pr_topcmd _ = str"(* <Warning> : No printer for toplevel commands *)" + +let pr_destruct_location = function + | Tacexpr.ConclLocation () -> str"Conclusion" + | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis" + +let pr_opt_hintbases l = match l with + | [] -> mt() + | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z + +let pr_hints local db h pr_c pr_pat = + let opth = pr_opt_hintbases db in + let pph = + match h with + | HintsResolve l -> + str "Resolve " ++ prlist_with_sep sep pr_c l + | HintsImmediate l -> + str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l + | HintsUnfold l -> + str "Unfold " ++ prlist_with_sep sep pr_reference l + | HintsConstructors c -> + str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c + | HintsExtern (n,c,tac) -> + str "Extern" ++ spc() ++ int n ++ spc() ++ pr_pat c ++ str" =>" ++ + spc() ++ pr_raw_tactic tac + | HintsDestruct(name,i,loc,c,tac) -> + str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++ + hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++ + pr_c c ++ str " =>") ++ spc() ++ + pr_raw_tactic tac in + hov 2 (str"Hint "++pr_locality local ++ pph ++ opth) + +let pr_with_declaration pr_c = function + | CWith_Definition (id,c) -> + let p = pr_c c in + str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p + | CWith_Module (id,qid) -> + str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ + pr_located pr_qualid qid + +let rec pr_module_type pr_c = function + | CMTEident qid -> spc () ++ pr_located pr_qualid qid + | CMTEwith (mty,decl) -> + let m = pr_module_type pr_c mty in + let p = pr_with_declaration pr_c decl in + m ++ spc() ++ str"with" ++ spc() ++ p + +let pr_of_module_type prc (mty,b) = + str (if b then ":" else "<:") ++ + pr_module_type prc mty + +let pr_require_token = function + | Some true -> str "Export " + | Some false -> str "Import " + | None -> mt() + +let pr_module_vardecls pr_c (export,idl,mty) = + let m = pr_module_type pr_c mty in + (* Update the Nametab for interpreting the body of module/modtype *) + let lib_dir = Lib.library_dp() in + List.iter (fun (_,id) -> + Declaremods.process_module_bindings [id] + [make_mbid lib_dir (string_of_id id), + Modintern.interp_modtype (Global.env()) mty]) idl; + (* Builds the stream *) + spc() ++ + hov 1 (str"(" ++ pr_require_token export ++ + prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") + +let pr_module_binders l pr_c = + (* Effet de bord complexe pour garantir la declaration des noms des + modules parametres dans la Nametab des l'appel de pr_module_binders + malgre l'aspect paresseux des streams *) + let ml = List.map (pr_module_vardecls pr_c) l in + prlist (fun id -> id) ml + +let pr_module_binders_list l pr_c = pr_module_binders l pr_c + +let rec pr_module_expr = function + | CMEident qid -> pr_located pr_qualid qid + | CMEapply (me1,(CMEident _ as me2)) -> + pr_module_expr me1 ++ spc() ++ pr_module_expr me2 + | CMEapply (me1,me2) -> + pr_module_expr me1 ++ spc() ++ + hov 1 (str"(" ++ pr_module_expr me2 ++ str")") + +let pr_type_option pr_c = function + | CHole loc -> mt() + | _ as c -> brk(0,2) ++ str":" ++ pr_c c + +let pr_decl_notation prc = + pr_opt (fun (ntn,c,scopt) -> fnl () ++ + str "where " ++ qs ntn ++ str " := " ++ prc c ++ + pr_opt (fun sc -> str ": " ++ str sc) scopt) + +let pr_vbinders l = + hv 0 (pr_binders l) + +let pr_binders_arg = + pr_ne_sep spc pr_binders + +let pr_and_type_binders_arg bl = + pr_binders_arg bl + +let pr_onescheme (id,dep,ind,s) = + hov 0 (pr_lident id ++ str" :=") ++ spc() ++ + hov 0 ((if dep then str"Induction for" else str"Minimality for") + ++ spc() ++ pr_reference ind) ++ spc() ++ + hov 0 (str"Sort" ++ spc() ++ pr_sort s) + +let begin_of_inductive = function + [] -> 0 + | (_,((loc,_),_))::_ -> fst (unloc loc) + +let pr_class_rawexpr = function + | FunClass -> str"Funclass" + | SortClass -> str"Sortclass" + | RefClass qid -> pr_reference qid + +let pr_assumption_token many = function + | (Local,Logical) -> + str (if many then "Hypotheses" else "Hypothesis") + | (Local,Definitional) -> + str (if many then "Variables" else "Variable") + | (Global,Logical) -> + str (if many then "Axioms" else "Axiom") + | (Global,Definitional) -> + str (if many then "Parameters" else "Parameter") + | (Global,Conjectural) -> str"Conjecture" + | (Local,Conjectural) -> + anomaly "Don't know how to translate a local conjecture" + +let pr_params pr_c (xl,(c,t)) = + hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ + (if c then str":>" else str":" ++ + spc() ++ pr_c t)) + +let rec factorize = function + | [] -> [] + | (c,(idl,t))::l -> + match factorize l with + | (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l' + | l' -> (idl,(c,t))::l' + +let pr_ne_params_list pr_c l = + match factorize l with + | [p] -> pr_params pr_c p + | l -> + prlist_with_sep spc + (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l +(* + prlist_with_sep pr_semicolon (pr_params pr_c) +*) + +let pr_thm_token k = str (string_of_theorem_kind k) + +let pr_syntax_modifier = function + | SetItemLevel (l,NextLevel) -> + prlist_with_sep sep_v2 str l ++ + spc() ++ str"at next level" + | SetItemLevel (l,NumLevel n) -> + prlist_with_sep sep_v2 str l ++ + spc() ++ str"at level" ++ spc() ++ int n + | SetLevel n -> str"at level" ++ spc() ++ int n + | SetAssoc Gramext.LeftA -> str"left associativity" + | SetAssoc Gramext.RightA -> str"right associativity" + | SetAssoc Gramext.NonA -> str"no associativity" + | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ + | SetOnlyParsing -> str"only parsing" + | SetFormat s -> str"format " ++ pr_located qs s + +let pr_syntax_modifiers = function + | [] -> mt() + | l -> spc() ++ + hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") + +let print_level n = + if n <> 0 then str " (at level " ++ int n ++ str ")" else mt () + +let pr_grammar_tactic_rule n (_,pil,t) = + hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ + hov 0 (prlist_with_sep sep pr_production_item pil ++ + spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) + +let pr_box b = let pr_boxkind = function + | PpHB n -> str"h" ++ spc() ++ int n + | PpVB n -> str"v" ++ spc() ++ int n + | PpHVB n -> str"hv" ++ spc() ++ int n + | PpHOVB n -> str"hov" ++ spc() ++ int n + | PpTB -> str"t" +in str"<" ++ pr_boxkind b ++ str">" + +let pr_paren_reln_or_extern = function + | None,L -> str"L" + | None,E -> str"E" + | Some pprim,Any -> qs pprim + | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p + | _ -> mt() + +(**************************************) +(* Pretty printer for vernac commands *) +(**************************************) +let make_pr_vernac pr_constr pr_lconstr = + +let pr_constrarg c = spc () ++ pr_constr c in +let pr_lconstrarg c = spc () ++ pr_lconstr c in +let pr_intarg n = spc () ++ int n in + +let rec pr_vernac = function + + (* Proof management *) + | VernacAbortAll -> str "Abort All" + | VernacRestart -> str"Restart" + | VernacSuspend -> str"Suspend" + | VernacUnfocus -> str"Unfocus" + | VernacGoal c -> str"Goal" ++ pr_lconstrarg c + | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id + | VernacResume id -> str"Resume" ++ pr_opt pr_lident id + | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i + | VernacBacktrack (i,j,k) -> + str "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k] + | VernacFocus i -> str"Focus" ++ pr_opt int i + | VernacGo g -> + let pr_goable = function + | GoTo i -> int i + | GoTop -> str"top" + | GoNext -> str"next" + | GoPrev -> str"prev" + in str"Go" ++ spc() ++ pr_goable g + | VernacShow s -> + let pr_showable = function + | ShowGoal n -> str"Show" ++ pr_opt int n + | ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n + | ShowProof -> str"Show Proof" + | ShowNode -> str"Show Node" + | ShowScript -> str"Show Script" + | ShowExistentials -> str"Show Existentials" + | ShowTree -> str"Show Tree" + | ShowProofNames -> str"Show Conjectures" + | ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro") + | ShowMatch id -> str"Show Match " ++ pr_lident id + | ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l + | ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l + in pr_showable s + | VernacCheckGuard -> str"Guarded" + | VernacDebug b -> pr_topcmd b + + (* Resetting *) + | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id + | VernacResetInitial -> str"Reset Initial" + | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i + | VernacBackTo i -> str"BackTo" ++ pr_intarg i + + (* State management *) + | VernacWriteState s -> str"Write State" ++ spc () ++ qs s + | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s + + (* Control *) + | VernacList l -> + hov 2 (str"[" ++ spc() ++ + prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l + ++ spc() ++ str"]") + | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose" + ++ spc()) else spc() ++ qs s + | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v + | VernacVar id -> pr_lident id + + (* Syntax *) + | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e) + | VernacOpenCloseScope (local,opening,sc) -> + str (if opening then "Open " else "Close ") ++ pr_locality local ++ + str "Scope" ++ spc() ++ str sc + | VernacDelimiters (sc,key) -> + str"Delimit Scope" ++ spc () ++ str sc ++ + spc() ++ str "with " ++ str key + | VernacBindScope (sc,cll) -> + str"Bind Scope" ++ spc () ++ str sc ++ + spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll + | VernacArgumentsScope (q,scl) -> let pr_opt_scope = function + | None -> str"_" + | Some sc -> str sc in + str"Arguments Scope" ++ spc() ++ pr_reference q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" + | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *) + hov 0 (hov 0 (str"Infix " ++ pr_locality local + ++ qs s ++ str " :=" ++ spc() ++ pr_reference q) ++ + pr_syntax_modifiers mv ++ + (match sn with + | None -> mt() + | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) + | VernacNotation (local,c,(s,l),opt) -> + let ps = + let n = String.length s in + if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' + then + let s' = String.sub s 1 (n-2) in + if String.contains s' '\'' then qs s else str s' + else qs s in + hov 2( str"Notation" ++ spc() ++ pr_locality local ++ ps ++ + str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++ + (match opt with + | None -> mt() + | Some sc -> str" :" ++ spc() ++ str sc)) + | VernacSyntaxExtension (local,(s,l)) -> + str"Reserved Notation" ++ spc() ++ pr_locality local ++ qs s ++ + pr_syntax_modifiers l + + (* Gallina *) + | VernacDefinition (d,id,b,f) -> (* A verifier... *) + let pr_def_token dk = str (string_of_definition_kind dk) in + let pr_reduce = function + | None -> mt() + | Some r -> + str"Eval" ++ spc() ++ + pr_red_expr (pr_constr, pr_lconstr, pr_reference) r ++ + str" in" ++ spc() in + let pr_def_body = function + | DefineBody (bl,red,body,d) -> + let ty = match d with + | None -> mt() + | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty + in + (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) + | ProveBody (bl,t) -> + (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in + let (binds,typ,c) = pr_def_body b in + hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++ + (match c with + | None -> mt() + | Some cc -> str" :=" ++ spc() ++ cc)) + + | VernacStartTheoremProof (ki,id,(bl,c),b,d) -> + hov 1 (pr_thm_token ki ++ spc() ++ pr_lident id ++ spc() ++ + (match bl with + | [] -> mt() + | _ -> pr_binders bl ++ spc()) + ++ str":" ++ pr_spc_lconstr c) + | VernacEndProof Admitted -> str"Admitted" + | VernacEndProof (Proved (opac,o)) -> (match o with + | None -> if opac then str"Qed" else str"Defined" + | Some (id,th) -> (match th with + | None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id + | Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) + | VernacExactProof c -> + hov 2 (str"Proof" ++ pr_lconstrarg c) + | VernacAssumption (stre,l) -> + let n = List.length (List.flatten (List.map fst (List.map snd l))) in + hov 2 + (pr_assumption_token (n > 1) stre ++ spc() ++ + pr_ne_params_list pr_lconstr_expr l) + | VernacInductive (f,l) -> + + let pr_constructor (coe,(id,c)) = + hov 2 (pr_lident id ++ str" " ++ + (if coe then str":>" else str":") ++ + pr_spc_lconstr c) in + let pr_constructor_list l = match l with + | [] -> mt() + | _ -> + pr_com_at (begin_of_inductive l) ++ + fnl() ++ + str (if List.length l = 1 then " " else " | ") ++ + prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l in + let pr_oneind key (id,ntn,indpar,s,lc) = + hov 0 ( + str key ++ spc() ++ + pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr s ++ + str" :=") ++ pr_constructor_list lc ++ + pr_decl_notation pr_constr ntn in + + hov 1 (pr_oneind (if f then "Inductive" else "CoInductive") (List.hd l)) + ++ + (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) + + + | VernacFixpoint (recs,b) -> + let name_of_binder = function + | LocalRawAssum (nal,_) -> nal + | LocalRawDef (_,_) -> [] in + let pr_onerec = function + | (id,(n,ro),bl,type_,def),ntn -> + let (bl',def,type_) = + if Options.do_translate() then extract_def_binders def type_ + else ([],def,type_) in + let bl = bl @ bl' in + let ids = List.flatten (List.map name_of_binder bl) in + let name = + try snd (List.nth ids n) + with Failure _ -> + warn (str "non-printable fixpoint \""++pr_id id++str"\""); + Anonymous in + let annot = + match (ro : Topconstr.recursion_order_expr) with + CStructRec -> + if List.length ids > 1 then + spc() ++ str "{struct " ++ pr_name name ++ str"}" + else mt() + | CWfRec c -> spc() ++ str "{wf " ++ pr_name name ++ spc() ++ pr_lconstr_expr c ++ str"}" + in + pr_id id ++ pr_binders_arg bl ++ annot ++ spc() + ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ + ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ + pr_decl_notation pr_constr ntn + in + let start = if b then "Boxed Fixpoint" else "Fixpoint" in + hov 1 (str start ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs) + + | VernacCoFixpoint (corecs,b) -> + let pr_onecorec (id,bl,c,def) = + let (bl',def,c) = + if Options.do_translate() then extract_def_binders def c + else ([],def,c) in + let bl = bl @ bl' in + pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr c ++ + str" :=" ++ brk(1,1) ++ pr_lconstr def in + let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in + hov 1 (str start ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) + | VernacScheme l -> + hov 2 (str"Scheme" ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l) + + (* Gallina extensions *) + | VernacRecord (b,(oc,name),ps,s,c,fs) -> + let pr_record_field = function + | (oc,AssumExpr (id,t)) -> + hov 1 (pr_lname id ++ + (if oc then str" :>" else str" :") ++ spc() ++ + pr_lconstr_expr t) + | (oc,DefExpr(id,b,opt)) -> (match opt with + | Some t -> + hov 1 (pr_lname id ++ + (if oc then str" :>" else str" :") ++ spc() ++ + pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) + | None -> + hov 1 (pr_lname id ++ str" :=" ++ spc() ++ + pr_lconstr b)) in + hov 2 + (str (if b then "Record" else "Structure") ++ + (if oc then str" > " else str" ") ++ pr_lident name ++ + pr_and_type_binders_arg ps ++ str" :" ++ spc() ++ + pr_lconstr_expr s ++ str" := " ++ + (match c with + | None -> mt() + | Some sc -> pr_lident sc) ++ + spc() ++ str"{" ++ + hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")) + | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id) + | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id) + | VernacRequire (exp,spe,l) -> hov 2 + (str "Require" ++ spc() ++ pr_require_token exp ++ + (match spe with + | None -> mt() + | Some flag -> + (if flag then str"Specification" else str"Implementation") ++ + spc ()) ++ + prlist_with_sep sep pr_module l) + | VernacImport (f,l) -> + (if f then str"Export" else str"Import") ++ spc() ++ + prlist_with_sep sep pr_import_module l + | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_reference q + | VernacCoercion (s,id,c1,c2) -> + hov 1 ( + str"Coercion" ++ (match s with | Local -> spc() ++ + str"Local" ++ spc() | Global -> spc()) ++ + pr_reference id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ + spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) + | VernacIdentityCoercion (s,id,c1,c2) -> + hov 1 ( + str"Identity Coercion" ++ (match s with | Local -> spc() ++ + str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ + spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ + spc() ++ pr_class_rawexpr c2) + + (* Modules and Module Types *) + | VernacDefineModule (export,m,bl,ty,bd) -> + let b = pr_module_binders_list bl pr_lconstr in + hov 2 (str"Module" ++ spc() ++ pr_require_token export ++ + pr_lident m ++ b ++ + pr_opt (pr_of_module_type pr_lconstr) ty ++ + pr_opt (fun me -> str ":= " ++ pr_module_expr me) bd) + | VernacDeclareModule (export,id,bl,m1) -> + let b = pr_module_binders_list bl pr_lconstr in + hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++ + pr_lident id ++ b ++ + pr_of_module_type pr_lconstr m1) + | VernacDeclareModuleType (id,bl,m) -> + let b = pr_module_binders_list bl pr_lconstr in + hov 2 (str"Module Type " ++ pr_lident id ++ b ++ + pr_opt (fun mt -> str ":= " ++ pr_module_type pr_lconstr mt) m) + + (* Solving *) + | VernacSolve (i,tac,deftac) -> + (if i = 1 then mt() else int i ++ str ": ") ++ + pr_raw_tactic tac + ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt () + with UserError _|Stdpp.Exc_located _ -> mt()) + + | VernacSolveExistential (i,c) -> + str"Existential " ++ int i ++ pr_lconstrarg c + + (* Auxiliary file and library management *) + | VernacRequireFrom (exp,spe,f) -> hov 2 + (str"Require" ++ spc() ++ pr_require_token exp ++ + (match spe with + | None -> mt() + | Some false -> str"Implementation" ++ spc() + | Some true -> str"Specification" ++ spc ()) ++ + qs f) + | VernacAddLoadPath (fl,s,d) -> hov 2 + (str"Add" ++ + (if fl then str" Rec " else spc()) ++ + str"LoadPath" ++ spc() ++ qs s ++ + (match d with + | None -> mt() + | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) + | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s + | VernacAddMLPath (fl,s) -> + str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s + | VernacDeclareMLModule l -> + hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l) + | VernacChdir s -> str"Cd" ++ pr_opt qs s + + (* Commands *) + | VernacDeclareTacticDefinition (rc,l) -> + let pr_tac_body (id, body) = + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + pr_located pr_ltac_id id ++ + prlist (function None -> str " _" + | Some id -> spc () ++ pr_id id) idl + ++ str" :=" ++ brk(1,1) ++ + let idl = List.map out_some (List.filter (fun x -> not (x=None)) idl)in + pr_raw_tactic_env + (idl @ List.map snd (List.map fst l)) + (Global.env()) + body in + hov 1 + (((*if !Options.p1 then + (if rc then str "Recursive " else mt()) ++ + str "Tactic Definition " else*) + (* Rec by default *) str "Ltac ") ++ + prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) + | VernacHints (local,dbnames,h) -> + pr_hints local dbnames h pr_constr pr_pattern_expr + | VernacSyntacticDefinition (id,c,local,onlyparsing) -> + hov 2 + (str"Notation " ++ pr_locality local ++ pr_id id ++ str" :=" ++ + pr_constrarg c ++ + pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else [])) + | VernacDeclareImplicits (q,None) -> + hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q) + | VernacDeclareImplicits (q,Some l) -> + let r = Nametab.global q in + Impargs.declare_manual_implicits r l; + let imps = Impargs.implicits_of_global r in + hov 1 (str"Implicit Arguments" ++ spc() ++ pr_reference q ++ spc() ++ + str"[" ++ prlist_with_sep sep (pr_explanation imps) l ++ str"]") + | VernacReserve (idl,c) -> + hov 1 (str"Implicit Type" ++ + str (if List.length idl > 1 then "s " else " ") ++ + prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++ + pr_lconstr c) + | VernacSetOpacity (fl,l) -> + hov 1 ((if fl then str"Opaque" else str"Transparent") ++ + spc() ++ prlist_with_sep sep pr_reference l) + | VernacUnsetOption na -> + hov 1 (str"Unset" ++ spc() ++ pr_printoption na None) + | VernacSetOption (na,v) -> hov 2 (str"Set" ++ spc() ++ pr_set_option na v) + | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l)) + | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l)) + | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l)) + | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None) + | VernacCheckMayEval (r,io,c) -> + let pr_mayeval r c = match r with + | Some r0 -> + hov 2 (str"Eval" ++ spc() ++ + pr_red_expr (pr_constr,pr_lconstr,pr_reference) r0 ++ + spc() ++ str"in" ++ spc () ++ pr_constr c) + | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) + in + (if io = None then mt() else int (out_some io) ++ str ": ") ++ + pr_mayeval r c + | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c) + | VernacPrint p -> + let pr_printable = function + | PrintFullContext -> str"Print All" + | PrintSectionContext s -> + str"Print Section" ++ spc() ++ Libnames.pr_reference s + | PrintGrammar (uni,ent) -> + msgerrnl (str "warning: no direct translation of Print Grammar entry"); + str"Print Grammar" ++ spc() ++ str ent + | PrintLoadPath -> str"Print LoadPath" + | PrintModules -> str"Print Modules" + | PrintMLLoadPath -> str"Print ML Path" + | PrintMLModules -> str"Print ML Modules" + | PrintGraph -> str"Print Graph" + | PrintClasses -> str"Print Classes" + | PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_reference qid + | PrintCoercions -> str"Print Coercions" + | PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t + | PrintCanonicalConversions -> str"Print Canonical Structures" + | PrintTables -> str"Print Tables" + | PrintOpaqueName qid -> str"Print Term" ++ spc() ++ pr_reference qid + | PrintHintGoal -> str"Print Hint" + | PrintHint qid -> str"Print Hint" ++ spc() ++ pr_reference qid + | PrintHintDb -> str"Print Hint *" + | PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s + | PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s + | PrintUniverses fopt -> str"Dump Universes" ++ pr_opt str fopt + | PrintName qid -> str"Print" ++ spc() ++ pr_reference qid + | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid + | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid + | PrintInspect n -> str"Inspect" ++ spc() ++ int n + | PrintSetoids -> str"Print Setoids" + | PrintScopes -> str"Print Scopes" + | PrintScope s -> str"Print Scope" ++ spc() ++ str s + | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s + | PrintAbout qid -> str"About" ++ spc() ++ pr_reference qid + | PrintImplicit qid -> str"Print Implicit" ++ spc() ++ pr_reference qid + in pr_printable p + | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern_expr + | VernacLocate loc -> + let pr_locate =function + | LocateTerm qid -> pr_reference qid + | LocateFile f -> str"File" ++ spc() ++ qs f + | LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid + | LocateModule qid -> str"Module" ++ spc () ++ pr_module qid + | LocateNotation s -> qs s + in str"Locate" ++ spc() ++ pr_locate loc + | VernacComments l -> + hov 2 + (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) + | VernacNop -> mt() + + (* Toplevel control *) + | VernacToplevelControl exn -> pr_topcmd exn + + (* For extension *) + | VernacExtend (s,c) -> pr_extend s c + | VernacProof Tacexpr.TacId _ -> str "Proof" + | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te + +and pr_extend s cl = + let pr_arg a = + try pr_gen (Global.env()) a + with Failure _ -> str ("<error in "^s^">") in + try + let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in + let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in + let (pp,_) = + List.fold_left + (fun (strm,args) pi -> + match pi with + Egrammar.TacNonTerm _ -> + (strm ++ pr_gen (Global.env()) (List.hd args), + List.tl args) + | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args)) + (mt(),cl) rl in + hov 1 pp + with Not_found -> + hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")") + +in pr_vernac + +let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end () diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli new file mode 100644 index 00000000..21d983f5 --- /dev/null +++ b/parsing/ppvernac.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: ppvernac.mli 7744 2005-12-27 09:16:06Z herbelin $ i*) + +open Pp +open Genarg +open Vernacexpr +open Names +open Nameops +open Nametab +open Util +open Ppconstr +open Pptactic +open Rawterm +open Pcoq +open Libnames +open Ppextend +open Topconstr + +val sep_end : unit -> std_ppcmds + +val pr_vernac : vernac_expr -> std_ppcmds diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 1505745c..a22f5796 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: prettyp.ml,v 1.50.2.2 2005/11/21 09:16:28 herbelin Exp $ *) +(* $Id: prettyp.ml 7938 2006-01-28 22:03:33Z herbelin $ *) open Pp open Util @@ -20,7 +20,6 @@ open Inductiveops open Sign open Reduction open Environ -open Instantiate open Declare open Impargs open Libobject @@ -28,6 +27,7 @@ open Printer open Printmod open Libnames open Nametab +open Recordops (*********************) (** Basic printing *) @@ -58,8 +58,7 @@ let print_impl_args_by_name = function str" are implicit" ++ fnl() let print_impl_args l = - if !Options.v7 then print_impl_args_by_pos (positions_of_implicits l) - else print_impl_args_by_name (List.filter is_status_implicit l) + print_impl_args_by_name (List.filter is_status_implicit l) (*********************) (** Printing Scopes *) @@ -71,7 +70,7 @@ let print_ref reduce ref = let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ in it_mkProd_or_LetIn ccl ctx else typ in - hov 0 (pr_global ref ++ str " :" ++ spc () ++ prtype typ) ++ fnl () + hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) ++ fnl () let print_argument_scopes = function | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl() @@ -89,9 +88,32 @@ let need_expansion impl ref = impl <> [] & let _,lastimpl = list_chop nprods impl in List.filter is_status_implicit lastimpl <> [] +type opacity = + | FullyOpaque + | TransparentMaybeOpacified of bool + +let opacity env = function + | VarRef v when pi2 (Environ.lookup_named v env) <> None -> + Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_var v)) + | ConstRef cst -> + let cb = Environ.lookup_constant cst env in + if cb.const_body = None then None + else if cb.const_opaque then Some FullyOpaque + else Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_cst cst)) + | _ -> None + +let print_opacity ref = + match opacity (Global.env()) ref with + | None -> mt () + | Some s -> pr_global ref ++ str " is " ++ + str (match s with + | FullyOpaque -> "opaque" + | TransparentMaybeOpacified true -> "basically transparent but considered opaque for reduction" + | TransparentMaybeOpacified false -> "transparent") ++ fnl() + let print_name_infos ref = let impl = implicits_of_global ref in - let scopes = Symbols.find_arguments_scope ref in + let scopes = Notation.find_arguments_scope ref in let type_for_implicit = if need_expansion impl ref then (* Need to reduce since implicits are computed with products flattened *) @@ -127,7 +149,7 @@ let print_inductive_implicit_args = let print_inductive_argument_scopes = print_args_data_of_inductive_ids - Symbols.find_arguments_scope ((<>) None) print_argument_scopes + Notation.find_arguments_scope ((<>) None) print_argument_scopes (*********************) (* "Locate" commands *) @@ -160,8 +182,7 @@ let pr_located_qualid = function | VarRef _ -> "Variable" in str ref_str ++ spc () ++ pr_sp (Nametab.sp_of_global ref) | Syntactic kn -> - str (if !Options.v7 then "Syntactic Definition" else "Notation") ++ - spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn) + str "Notation" ++ spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn) | Dir dir -> let s,dir = match dir with | DirOpenModule (dir,_) -> "Open Module", dir @@ -180,9 +201,9 @@ let print_located_qualid ref = let (loc,qid) = qualid_of_reference ref in let module N = Nametab in let expand = function - | TrueGlobal ref -> + | TrueGlobal ref -> Term ref, N.shortest_qualid_of_global Idset.empty ref - | SyntacticDef kn -> + | SyntacticDef kn -> Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in match List.map expand (N.extended_locate_all qid) with | [] -> @@ -196,7 +217,7 @@ let print_located_qualid ref = (fun (o,oqid) -> hov 2 (pr_located_qualid o ++ (if oqid <> qid then - spc() ++ str "(visible as " ++ pr_qualid oqid ++ str")" + spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")" else mt ()))) l @@ -204,8 +225,8 @@ let print_located_qualid ref = (**** Printing declarations and judgments *) let print_typed_value_in_env env (trm,typ) = - (prterm_env env trm ++ fnl () ++ - str " : " ++ prtype_env env typ ++ fnl ()) + (pr_lconstr_env env trm ++ fnl () ++ + str " : " ++ pr_ltype_env env typ ++ fnl ()) let print_typed_value x = print_typed_value_in_env (Global.env ()) x @@ -218,20 +239,20 @@ let print_safe_judgment env j = print_typed_value_in_env env (trm, typ) (* To be improved; the type should be used to provide the types in the - abstractions. This should be done recursively inside prterm, so that + abstractions. This should be done recursively inside pr_lconstr, so that the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u) synthesizes the type nat of the abstraction on u *) let print_named_def name body typ = - let pbody = prterm body in - let ptyp = prtype typ in + let pbody = pr_lconstr body in + let ptyp = pr_ltype typ in (str "*** [" ++ str name ++ str " " ++ hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ str ":" ++ brk (1,2) ++ ptyp) ++ str "]" ++ fnl ()) let print_named_assum name typ = - (str "*** [" ++ str name ++ str " : " ++ prtype typ ++ str "]" ++ fnl ()) + (str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" ++ fnl ()) let print_named_decl (id,c,typ) = let s = string_of_id id in @@ -246,25 +267,19 @@ let assumptions_for_print lna = (* *) let print_params env params = - if List.length params = 0 then - (mt ()) - else - if !Options.v7 then - (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2)) - else - (pr_rel_context env params ++ brk(1,2)) + if params = [] then mt () else pr_rel_context env params ++ brk(1,2) let print_constructors envpar names types = let pc = prlist_with_sep (fun () -> brk(1,0) ++ str "| ") - (fun (id,c) -> pr_id id ++ str " : " ++ prterm_env envpar c) + (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c) (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) in hv 0 (str " " ++ pc) let build_inductive sp tyi = let (mib,mip) = Global.lookup_inductive (sp,tyi) in - let params = mip.mind_params_ctxt in + let params = mib.mind_params_ctxt in let args = extended_rel_list 0 params in let env = Global.env() in let arity = hnf_prod_applist env mip.mind_user_arity args in @@ -280,7 +295,7 @@ let print_one_inductive (sp,tyi) = let envpar = push_rel_context params env in hov 0 ( pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++ - str ": " ++ prterm_env envpar arity ++ str " :=") ++ + str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++ brk(0,2) ++ print_constructors envpar cstrnames cstrtypes let pr_mutual_inductive finite indl = @@ -304,11 +319,11 @@ let print_section_variable sp = print_name_infos (VarRef sp) let print_body = function - | Some lc -> prterm (Declarations.force lc) + | Some lc -> pr_lconstr (Declarations.force lc) | None -> (str"<no body>") let print_typed_body (val_0,typ) = - (print_body val_0 ++ fnl () ++ str " : " ++ prtype typ ++ fnl ()) + (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ ++ fnl ()) let print_constant with_values sep sp = let cb = Global.lookup_constant sp in @@ -318,11 +333,11 @@ let print_constant with_values sep sp = match val_0 with | None -> str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ + print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ fnl () | _ -> print_basename sp ++ str sep ++ cut () ++ - (if with_values then print_typed_body (val_0,typ) else prtype typ) ++ + (if with_values then print_typed_body (val_0,typ) else pr_ltype typ) ++ fnl ()) let print_constant_with_infos sp = @@ -333,17 +348,18 @@ let print_inductive sp = (print_mutual sp) let print_syntactic_def sep kn = let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn in let c = Syntax_def.search_syntactic_definition dummy_loc kn in - (str (if !Options.v7 then "Syntactic Definition " else "Notation ") - ++ pr_qualid qid ++ str sep ++ - Constrextern.without_symbols pr_rawterm c ++ fnl ()) + str "Notation " ++ pr_qualid qid ++ str sep ++ + Constrextern.without_symbols pr_lrawconstr c ++ fnl () let print_leaf_entry with_values sep ((sp,kn as oname),lobj) = let tag = object_tag lobj in match (oname,tag) with | (_,"VARIABLE") -> - Some (print_section_variable (basename sp)) + (* Outside sections, VARIABLES still exist but only with universes + constraints *) + (try Some(print_section_variable (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> - Some (print_constant with_values sep kn) + Some (print_constant with_values sep (constant_of_kn kn)) | (_,"INDUCTIVE") -> Some (print_inductive kn) | (_,"MODULE") -> @@ -369,7 +385,7 @@ let rec print_library_entry with_values ent = print_leaf_entry with_values sep (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (oname,Lib.ClosedSection _) -> + | (oname,Lib.ClosedSection) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary (dir,_)) -> Some (str " >>>>>>> Library " ++ pr_dirpath dir) @@ -419,9 +435,9 @@ let read_sec_context r = with Not_found -> user_err_loc (loc,"read_sec_context", str "Unknown section") in let rec get_cxt in_cxt = function - | ((_,Lib.OpenedSection ((dir',_),_)) as hd)::rest -> + | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest - | ((_,Lib.ClosedSection (_,_,ctxt)) as hd)::rest -> + | (_,Lib.ClosedSection)::rest -> error "Cannot print the contents of a closed section" | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest @@ -474,9 +490,7 @@ let print_name ref = "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object") let print_opaque_name qid = - let sigma = Evd.empty in let env = Global.env () in - let sign = Global.named_context () in match global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in @@ -487,19 +501,21 @@ let print_opaque_name qid = | IndRef (sp,_) -> print_mutual sp | ConstructRef cstr -> - let ty = Inductive.type_of_constructor env cstr in + let ty = Inductiveops.type_of_constructor env cstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> let (_,c,ty) = lookup_named id env in print_named_decl (id,c,ty) let print_about ref = - let sigma = Evd.empty in let k = locate_any_name ref in begin match k with - | Term ref -> print_ref false ref ++ print_name_infos ref - | Syntactic kn -> print_syntactic_def " := " kn - | Dir _ | ModuleType _ | Undefined _ -> mt () end + | Term ref -> + print_ref false ref ++ print_name_infos ref ++ print_opacity ref + | Syntactic kn -> + print_syntactic_def " := " kn + | Dir _ | ModuleType _ | Undefined _ -> + mt () end ++ hov 0 (str "Expands to: " ++ pr_located_qualid k) @@ -512,38 +528,6 @@ let print_impargs ref = (if has_impl then print_impl_args impl else (str "No implicit arguments" ++ fnl ())) -let print_local_context () = - let env = Lib.contents_after None in - let rec print_var_rec = function - | [] -> (mt ()) - | (oname,Lib.Leaf lobj)::rest -> - if "VARIABLE" = object_tag lobj then - let d = get_variable (basename (fst oname)) in - (print_var_rec rest ++ - print_named_decl d) - else - print_var_rec rest - | _::rest -> print_var_rec rest - - and print_last_const = function - | (oname,Lib.Leaf lobj)::rest -> - (match object_tag lobj with - | "CONSTANT" -> - let kn = snd oname in - let {const_body=val_0;const_type=typ} = - Global.lookup_constant kn in - (print_last_const rest ++ - print_basename kn ++str" = " ++ - print_typed_body (val_0,typ)) - | "INDUCTIVE" -> - let kn = snd oname in - (print_last_const rest ++print_mutual kn ++ fnl ()) - | "VARIABLE" -> (mt ()) - | _ -> print_last_const rest) - | _ -> (mt ()) - in - (print_var_rec env ++ print_last_const env) - let unfold_head_fconst = let rec unfrec k = match kind_of_term k with | Const cst -> constant_value (Global.env ()) cst @@ -563,17 +547,17 @@ let inspect depth = open Classops -let print_coercion_value v = prterm (get_coercion_value v) +let print_coercion_value v = pr_lconstr (get_coercion_value v) let print_class i = let cl,_ = class_info_from_index i in pr_class cl let print_path ((i,j),p) = - (str"[" ++ - prlist_with_sep pr_semicolon print_coercion_value p ++ - str"] : " ++ print_class i ++ str" >-> " ++ - print_class j) + hov 2 ( + str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ + str"] : ") ++ + print_class i ++ str" >-> " ++ print_class j let _ = Classops.install_path_printer print_path @@ -604,4 +588,9 @@ let print_path_between cls clt = in print_path ((i,j),p) +let print_canonical_projections () = + prlist_with_sep pr_fnl (fun ((r1,r2),o) -> + pr_global r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") + (canonical_projections ()) + (*************************************************************************) diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index c8471330..13c11db7 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: prettyp.mli,v 1.12.2.1 2004/07/16 19:30:40 herbelin Exp $ i*) +(*i $Id: prettyp.mli 7740 2005-12-26 20:07:21Z herbelin $ i*) (*i*) open Pp @@ -42,7 +42,6 @@ val build_inductive : mutual_inductive -> int -> val print_mutual : mutual_inductive -> std_ppcmds val print_name : reference -> std_ppcmds val print_opaque_name : reference -> std_ppcmds -val print_local_context : unit -> std_ppcmds val print_about : reference -> std_ppcmds val print_impargs : reference -> std_ppcmds @@ -57,6 +56,7 @@ val print_graph : unit -> std_ppcmds val print_classes : unit -> std_ppcmds val print_coercions : unit -> std_ppcmds val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds +val print_canonical_projections : unit -> std_ppcmds val inspect : int -> std_ppcmds diff --git a/parsing/printer.ml b/parsing/printer.ml index dfacc764..82676b79 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: printer.ml,v 1.58.2.1 2004/07/16 19:30:40 herbelin Exp $ *) +(* $Id: printer.ml 7855 2006-01-12 08:21:57Z herbelin $ *) open Pp open Util @@ -18,139 +18,100 @@ open Sign open Environ open Global open Declare -open Coqast -open Ast -open Termast open Libnames -open Extend open Nametab open Ppconstr +open Evd +open Proof_type +open Refiner +open Pfedit +open Ppconstr +open Constrextern let emacs_str s = if !Options.print_emacs then s else "" (**********************************************************************) -(* Old Ast printing *) - -let constr_syntax_universe = "constr" -(* This is starting precedence for printing constructions or tactics *) -(* Level 9 means no parentheses except for applicative terms (at level 10) *) -let constr_initial_prec_v7 = Some (9,Ppextend.L) -let constr_initial_prec = Some (200,Ppextend.E) - -let dfltpr ast = (str"#GENTERM " ++ print_ast ast);; - -let global_const_name kn = - try pr_global Idset.empty (ConstRef kn) - with Not_found -> (* May happen in debug *) - (str ("CONST("^(string_of_kn kn)^")")) - -let global_var_name id = - try pr_global Idset.empty (VarRef id) - with Not_found -> (* May happen in debug *) - (str ("SECVAR("^(string_of_id id)^")")) - -let global_ind_name (kn,tyi) = - try pr_global Idset.empty (IndRef (kn,tyi)) - with Not_found -> (* May happen in debug *) - (str ("IND("^(string_of_kn kn)^","^(string_of_int tyi)^")")) - -let global_constr_name ((kn,tyi),i) = - try pr_global Idset.empty (ConstructRef ((kn,tyi),i)) - with Not_found -> (* May happen in debug *) - (str ("CONSTRUCT("^(string_of_kn kn)^","^(string_of_int tyi) - ^","^(string_of_int i)^")")) - -let globpr gt = match gt with - | Nvar(_,s) -> (pr_id s) - | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev))) - | Node(_,"CONST",[Path(_,sl)]) -> - global_const_name (section_path sl) - | Node(_,"SECVAR",[Nvar(_,s)]) -> - global_var_name s - | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> - global_ind_name (section_path sl, tyi) - | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> - global_constr_name ((section_path sl, tyi), i) - | Dynamic(_,d) -> - if (Dyn.tag d) = "constr" then (str"<dynamic [constr]>") - else dfltpr gt - | gt -> dfltpr gt - - -let wrap_exception = function - Anomaly (s1,s2) -> - warning ("Anomaly ("^s1^")"); pp s2; - str"<PP error: non-printable term>" - | Failure _ | UserError _ | Not_found -> - str"<PP error: non-printable term>" - | s -> raise s - -let gentermpr_fail gt = - let prec = - if !Options.v7 then constr_initial_prec_v7 else constr_initial_prec in - Esyntax.genprint globpr constr_syntax_universe prec gt - -let gentermpr gt = - try gentermpr_fail gt - with s -> wrap_exception s +(** Terms *) -(**********************************************************************) -(* Generic printing: choose old or new printers *) + (* [at_top] means ids of env must be avoided in bound variables *) +let pr_constr_core at_top env t = + pr_constr_expr (extern_constr at_top env t) +let pr_lconstr_core at_top env t = + pr_lconstr_expr (extern_constr at_top env t) + +let pr_lconstr_env_at_top env = pr_lconstr_core true env +let pr_lconstr_env env = pr_lconstr_core false env +let pr_constr_env env = pr_constr_core false env + + (* NB do not remove the eta-redexes! Global.env() has side-effects... *) +let pr_lconstr t = pr_lconstr_env (Global.env()) t +let pr_constr t = pr_constr_env (Global.env()) t + +let pr_type_core at_top env t = + pr_constr_expr (extern_type at_top env t) +let pr_ltype_core at_top env t = + pr_lconstr_expr (extern_type at_top env t) + +let pr_ltype_env_at_top env = pr_ltype_core true env +let pr_ltype_env env = pr_ltype_core false env +let pr_type_env env = pr_type_core false env + +let pr_ltype t = pr_ltype_env (Global.env()) t +let pr_type t = pr_type_env (Global.env()) t + +let pr_ljudge_env env j = + (pr_lconstr_env env j.uj_val, pr_lconstr_env env j.uj_type) + +let pr_ljudge j = pr_ljudge_env (Global.env()) j + +let pr_lrawconstr_env env c = + pr_lconstr_expr (extern_rawconstr (vars_of_env env) c) +let pr_rawconstr_env env c = + pr_constr_expr (extern_rawconstr (vars_of_env env) c) + +let pr_lrawconstr c = + pr_lconstr_expr (extern_rawconstr Idset.empty c) +let pr_rawconstr c = + pr_constr_expr (extern_rawconstr Idset.empty c) -(* [at_top] means ids of env must be avoided in bound variables *) -let gentermpr_core at_top env t = - if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t) - else Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t) let pr_cases_pattern t = - if !Options.v7 then gentermpr (Termast.ast_of_cases_pattern t) - else Ppconstrnew.pr_cases_pattern - (Constrextern.extern_cases_pattern Idset.empty t) -let pr_pattern_env tenv env t = - if !Options.v7 then gentermpr (Termast.ast_of_pattern tenv env t) - else Ppconstrnew.pr_constr - (Constrextern.extern_pattern tenv env t) + pr_cases_pattern_expr (extern_cases_pattern Idset.empty t) + +let pr_constr_pattern_env env c = + pr_constr_expr (extern_constr_pattern (names_of_rel_context env) c) +let pr_constr_pattern t = + pr_constr_expr (extern_constr_pattern empty_names_context t) + +let _ = Termops.set_print_constr pr_lconstr_env (**********************************************************************) -(* Derived printers *) - -let prterm_env_at_top env = gentermpr_core true env -let prterm_env env = gentermpr_core false env -let prtype_env env typ = prterm_env env typ -let prjudge_env env j = - (prterm_env env j.uj_val, prterm_env env j.uj_type) - -(* NB do not remove the eta-redexes! Global.env() has side-effects... *) -let prterm t = prterm_env (Global.env()) t -let prtype t = prtype_env (Global.env()) t -let prjudge j = prjudge_env (Global.env()) j - -let pr_constant env cst = prterm_env env (mkConst cst) -let pr_existential env ev = prterm_env env (mkEvar ev) -let pr_inductive env ind = prterm_env env (mkInd ind) -let pr_constructor env cstr = prterm_env env (mkConstruct cstr) -let pr_global = pr_global Idset.empty - -let pr_rawterm t = - if !Options.v7 then gentermpr (Termast.ast_of_rawconstr t) - else Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t) - -open Pattern -let pr_ref_label = function (* On triche sur le contexte *) - | ConstNode sp -> pr_constant (Global.env()) sp - | IndNode sp -> pr_inductive (Global.env()) sp - | CstrNode sp -> pr_constructor (Global.env()) sp - | VarNode id -> pr_id id - -let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t +(* Global references *) + +let pr_global_env = pr_global_env +let pr_global = pr_global_env Idset.empty + +let pr_constant env cst = pr_global_env (vars_of_env env) (ConstRef cst) +let pr_existential env ev = pr_lconstr_env env (mkEvar ev) +let pr_inductive env ind = pr_lconstr_env env (mkInd ind) +let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) + +let pr_evaluable_reference ref = + let ref' = match ref with + | EvalConstRef const -> ConstRef const + | EvalVarRef sp -> VarRef sp in + pr_global ref' + +(**********************************************************************) +(* Contexts and declarations *) let pr_var_decl env (id,c,typ) = let pbody = match c with | None -> (mt ()) | Some c -> (* Force evaluation *) - let pb = prterm_env env c in + let pb = pr_lconstr_env env c in (str" := " ++ pb ++ cut () ) in - let pt = prtype_env env typ in + let pt = pr_ltype_env env typ in let ptyp = (str" : " ++ pt) in (pr_id id ++ hov 0 (pbody ++ ptyp)) @@ -159,9 +120,9 @@ let pr_rel_decl env (na,c,typ) = | None -> mt () | Some c -> (* Force evaluation *) - let pb = prterm_env env c in + let pb = pr_lconstr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = prtype_env env typ in + let ptyp = pr_ltype_env env typ in match na with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -177,22 +138,25 @@ let pr_named_context_of env = (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) env ~init:(mt ())) +let pr_named_context env ne_context = + hv 0 (Sign.fold_named_context + (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d) + ne_context ~init:(mt ())) + let pr_rel_context env rel_context = let rec prec env = function | [] -> (mt ()) - | [b] -> - if !Options.v7 then pr_rel_decl env b - else str "(" ++ pr_rel_decl env b ++ str")" + | [b] -> str "(" ++ pr_rel_decl env b ++ str")" | b::rest -> let pb = pr_rel_decl env b in let penvtl = prec (push_rel b env) rest in - if !Options.v7 then - (pb ++ str";" ++ spc () ++ penvtl) - else - (str "(" ++ pb ++ str")" ++ spc () ++ penvtl) + str "(" ++ pb ++ str")" ++ spc () ++ penvtl in hov 0 (prec env (List.rev rel_context)) +let pr_rel_context_of env = + pr_rel_context env (rel_context env) + (* Prints an env (variables and de Bruijn). Separator: newline *) let pr_context_unlimited env = let sign_env = @@ -247,3 +211,168 @@ let pr_context_limit n env = let pr_context_of env = match Options.print_hyps_limit () with | None -> hv 0 (pr_context_unlimited env) | Some n -> hv 0 (pr_context_limit n env) + + +(* display complete goal *) +let pr_goal g = + let env = evar_env g in + let penv = pr_context_of env in + let pc = pr_ltype_env_at_top env g.evar_concl in + str" " ++ hv 0 (penv ++ fnl () ++ + str (emacs_str (String.make 1 (Char.chr 253))) ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + +(* display the conclusion of a goal *) +let pr_concl n g = + let env = evar_env g in + let pc = pr_ltype_env_at_top env g.evar_concl in + str (emacs_str (String.make 1 (Char.chr 253))) ++ + str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" " ++ pc + +(* display evar type: a context and a type *) +let pr_evgl_sign gl = + let ps = pr_named_context_of (evar_env gl) in + let pc = pr_lconstr gl.evar_concl in + hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]") + +(* Print an enumerated list of existential variables *) +let rec pr_evars_int i = function + | [] -> (mt ()) + | (ev,evd)::rest -> + let pegl = pr_evgl_sign evd in + let pei = pr_evars_int (i+1) rest in + (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++ + str (string_of_existential ev) ++ str " : " ++ pegl)) ++ + fnl () ++ pei + +let pr_subgoal n = + let rec prrec p = function + | [] -> error "No such goal" + | g::rest -> + if p = 1 then + let pg = pr_goal g in + v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg) + else + prrec (p-1) rest + in + prrec n + +(* Print open subgoals. Checks for uninstantiated existential variables *) +let pr_subgoals sigma = function + | [] -> + let exl = Evarutil.non_instantiated sigma in + if exl = [] then + (str"Proof completed." ++ fnl ()) + else + let pei = pr_evars_int 1 exl in + (str "No more subgoals but non-instantiated existential " ++ + str "variables :" ++fnl () ++ (hov 0 pei)) + | [g] -> + let pg = pr_goal g in + v 0 (str ("1 "^"subgoal") ++cut () ++ pg) + | g1::rest -> + let rec pr_rec n = function + | [] -> (mt ()) + | g::rest -> + let pc = pr_concl n g in + let prest = pr_rec (n+1) rest in + (cut () ++ pc ++ prest) + in + let pg1 = pr_goal g1 in + let prest = pr_rec 2 rest in + v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () + ++ pg1 ++ prest ++ fnl ()) + + +let pr_subgoals_of_pfts pfts = + let gls = fst (Refiner.frontier (proof_of_pftreestate pfts)) in + let sigma = (top_goal_of_pftreestate pfts).sigma in + pr_subgoals sigma gls + +let pr_open_subgoals () = + let pfts = get_pftreestate () in + match focus() with + | 0 -> + pr_subgoals_of_pfts pfts + | n -> + let pf = proof_of_pftreestate pfts in + let gls = fst (frontier pf) in + assert (n > List.length gls); + if List.length gls < 2 then + pr_subgoal n gls + else + v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++ + pr_subgoal n gls) + +let pr_nth_open_subgoal n = + let pf = proof_of_pftreestate (get_pftreestate ()) in + pr_subgoal n (fst (frontier pf)) + +(* Elementary tactics *) + +let pr_prim_rule = function + | Intro id -> + str"intro " ++ pr_id id + + | Intro_replacing id -> + (str"intro replacing " ++ pr_id id) + + | Cut (b,id,t) -> + if b then + (str"assert " ++ pr_constr t) + else + (str"cut " ++ pr_constr t ++ str ";[intro " ++ pr_id id ++ str "|idtac]") + + | FixRule (f,n,[]) -> + (str"fix " ++ pr_id f ++ str"/" ++ int n) + + | FixRule (f,n,others) -> + let rec print_mut = function + | (f,n,ar)::oth -> + pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth + | [] -> mt () in + (str"fix " ++ pr_id f ++ str"/" ++ int n ++ + str" with " ++ print_mut others) + + | Cofix (f,[]) -> + (str"cofix " ++ pr_id f) + + | Cofix (f,others) -> + let rec print_mut = function + | (f,ar)::oth -> + (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth) + | [] -> mt () in + (str"cofix " ++ pr_id f ++ str" with " ++ print_mut others) + + | Refine c -> + str(if occur_meta c then "refine " else "exact ") ++ + Constrextern.with_meta_as_hole pr_constr c + + | Convert_concl (c,_) -> + (str"change " ++ pr_constr c) + + | Convert_hyp (id,None,t) -> + (str"change " ++ pr_constr t ++ spc () ++ str"in " ++ pr_id id) + + | Convert_hyp (id,Some c,t) -> + (str"change " ++ pr_constr c ++ spc () ++ str"in " + ++ pr_id id ++ str" (type of " ++ pr_id id ++ str ")") + + | Thin ids -> + (str"clear " ++ prlist_with_sep pr_spc pr_id ids) + + | ThinBody ids -> + (str"clearbody " ++ prlist_with_sep pr_spc pr_id ids) + + | Move (withdep,id1,id2) -> + (str (if withdep then "dependent " else "") ++ + str"move " ++ pr_id id1 ++ str " after " ++ pr_id id2) + + | Rename (id1,id2) -> + (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) + +(* Backwards compatibility *) + +let prterm = pr_lconstr + diff --git a/parsing/printer.mli b/parsing/printer.mli index c44be124..66471d41 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: printer.mli,v 1.26.2.2 2005/01/21 16:42:37 herbelin Exp $ i*) +(*i $Id: printer.mli 7855 2006-01-12 08:21:57Z herbelin $ i*) (*i*) open Pp @@ -19,42 +19,82 @@ open Rawterm open Pattern open Nametab open Termops +open Evd +open Proof_type +open Rawterm (*i*) (* These are the entry points for printing terms, context, tac, ... *) -(*i -val gentacpr : Tacexpr.raw_tactic_expr -> std_ppcmds -i*) - -val prterm_env : env -> constr -> std_ppcmds -val prterm_env_at_top : env -> constr -> std_ppcmds -val prterm : constr -> std_ppcmds -val prtype_env : env -> types -> std_ppcmds -val prtype : types -> std_ppcmds -val prjudge_env : - env -> Environ.unsafe_judgment -> std_ppcmds * std_ppcmds -val prjudge : Environ.unsafe_judgment -> std_ppcmds * std_ppcmds - -val pr_rawterm : Rawterm.rawconstr -> std_ppcmds -val pr_cases_pattern : Rawterm.cases_pattern -> std_ppcmds - -val pr_constant : env -> constant -> std_ppcmds -val pr_existential : env -> existential -> std_ppcmds -val pr_constructor : env -> constructor -> std_ppcmds -val pr_inductive : env -> inductive -> std_ppcmds -val pr_global : global_reference -> std_ppcmds -val pr_ref_label : constr_label -> std_ppcmds -val pr_pattern : constr_pattern -> std_ppcmds -val pr_pattern_env : env -> names_context -> constr_pattern -> std_ppcmds - -val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds - -val pr_var_decl : env -> named_declaration -> std_ppcmds -val pr_rel_decl : env -> rel_declaration -> std_ppcmds - -val pr_named_context_of : env -> std_ppcmds -val pr_rel_context : env -> rel_context -> std_ppcmds -val pr_context_of : env -> std_ppcmds - -val emacs_str : string -> string +(* Terms *) + +val pr_lconstr_env : env -> constr -> std_ppcmds +val pr_lconstr_env_at_top : env -> constr -> std_ppcmds +val pr_lconstr : constr -> std_ppcmds + +val pr_constr_env : env -> constr -> std_ppcmds +val pr_constr : constr -> std_ppcmds + +val pr_ltype_env : env -> types -> std_ppcmds +val pr_ltype : types -> std_ppcmds + +val pr_type_env : env -> types -> std_ppcmds +val pr_type : types -> std_ppcmds + +val pr_ljudge_env : env -> unsafe_judgment -> std_ppcmds * std_ppcmds +val pr_ljudge : unsafe_judgment -> std_ppcmds * std_ppcmds + +val pr_lrawconstr_env : env -> rawconstr -> std_ppcmds +val pr_lrawconstr : rawconstr -> std_ppcmds + +val pr_rawconstr_env : env -> rawconstr -> std_ppcmds +val pr_rawconstr : rawconstr -> std_ppcmds + +val pr_constr_pattern_env : env -> constr_pattern -> std_ppcmds +val pr_constr_pattern : constr_pattern -> std_ppcmds + +val pr_cases_pattern : cases_pattern -> std_ppcmds + +(* Printing global references using names as short as possible *) + +val pr_global_env : Idset.t -> global_reference -> std_ppcmds +val pr_global : global_reference -> std_ppcmds + +val pr_constant : env -> constant -> std_ppcmds +val pr_existential : env -> existential -> std_ppcmds +val pr_constructor : env -> constructor -> std_ppcmds +val pr_inductive : env -> inductive -> std_ppcmds +val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds + +(* Contexts *) + +val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds + +val pr_var_decl : env -> named_declaration -> std_ppcmds +val pr_rel_decl : env -> rel_declaration -> std_ppcmds + +val pr_named_context : env -> named_context -> std_ppcmds +val pr_named_context_of : env -> std_ppcmds +val pr_rel_context : env -> rel_context -> std_ppcmds +val pr_rel_context_of : env -> std_ppcmds +val pr_context_of : env -> std_ppcmds + +(* Proofs *) + +val pr_goal : goal -> std_ppcmds +val pr_subgoals : evar_map -> goal list -> std_ppcmds +val pr_subgoal : int -> goal list -> std_ppcmds + +val pr_open_subgoals : unit -> std_ppcmds +val pr_nth_open_subgoal : int -> std_ppcmds +val pr_evars_int : int -> (evar * evar_info) list -> std_ppcmds + +val pr_prim_rule : prim_rule -> std_ppcmds + +(* Emacs/proof general support *) + +val emacs_str : string -> string + +(* Backwards compatibility *) + +val prterm : constr -> std_ppcmds (* = pr_lconstr *) diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 new file mode 100644 index 00000000..768bc45c --- /dev/null +++ b/parsing/q_constr.ml4 @@ -0,0 +1,124 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: g_constr.ml4,v 1.58 2005/12/30 10:55:32 herbelin Exp $ *) + +open Rawterm +open Term +open Names +open Pattern +open Q_util +open Util +open Pcaml + +let loc = dummy_loc +let dloc = <:expr< Util.dummy_loc >> + +let apply_ref f l = + <:expr< + Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) + >> + +EXTEND + GLOBAL: expr; + expr: + [ [ "PATTERN"; "["; c = constr; "]" -> + <:expr< snd (Pattern.pattern_of_rawconstr $c$) >> ] ] + ; + sort: + [ [ "Set" -> RProp Pos + | "Prop" -> RProp Null + | "Type" -> RType None ] ] + ; + ident: + [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ] + ; + name: + [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] + ; + string: + [ [ UIDENT | LIDENT ] ] + ; + constr: + [ "200" RIGHTA + [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr -> + <:expr< Rawterm.RProd ($dloc$,Name $id$,$c1$,$c2$) >> + | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr -> + <:expr< Rawterm.RLambda ($dloc$,Name $id$,$c1$,$c2$) >> + | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr -> + <:expr< Rawterm.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> + (* fix todo *) + ] + | "100" RIGHTA + [ c1 = constr; ":"; c2 = SELF -> + <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] + | "90" RIGHTA + [ c1 = constr; "->"; c2 = SELF -> + <:expr< Rawterm.RProd ($dloc$,Anonymous,$c1$,$c2$) >> ] + | "75" RIGHTA + [ "~"; c = constr -> + apply_ref <:expr< coq_not_ref >> [c] ] + | "70" RIGHTA + [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT -> + apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ] + | "10" LEFTA + [ f = constr; args = LIST1 NEXT -> + let args = mlexpr_of_list (fun x -> x) args in + <:expr< Rawterm.RApp ($dloc$,$f$,$args$) >> ] + | "0" + [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >> + | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >> + | "_" -> <:expr< Rawterm.RHole ($dloc$,QuestionMark) >> + | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >> + | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> + apply_ref <:expr< coq_sumbool_ref >> [c1;c2] + | "%"; e = string -> <:expr< Rawterm.RRef ($dloc$,Lazy.force $lid:e$) >> + | c = match_constr -> c + | "("; c = constr LEVEL "200"; ")" -> c ] ] + ; + match_constr: + [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; + "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> + let br = mlexpr_of_list (fun x -> x) br in + <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> + ] ] + ; + match_type: + [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; + "return"; ty = constr LEVEL "100" -> + let nal = mlexpr_of_list (fun x -> x) nal in + <:expr< Some $ty$ >>, + <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> + | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ] + ; + eqn: + [ [ (lid,pl) = pattern; "=>"; rhs = constr -> + let lid = mlexpr_of_list (fun x -> x) lid in + <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> + ] ] + ; + pattern: + [ [ "%"; e = string; lip = LIST0 patvar -> + let lp = mlexpr_of_list (fun (_,x) -> x) lip in + let lid = List.flatten (List.map fst lip) in + lid, <:expr< Rawterm.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> + | p = patvar -> p + | "("; p = pattern; ")" -> p ] ] + ; + patvar: + [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> + | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> + ] ] + ; + END;; + +(* Example +open Coqlib +let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ] +*) + diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index e8e1830a..35801f73 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: q_coqast.ml4,v 1.47.2.6 2005/05/15 12:47:05 herbelin Exp $ *) +(* $Id: q_coqast.ml4 8651 2006-03-21 21:54:43Z jforest $ *) open Util open Names @@ -21,7 +21,7 @@ let purge_str s = let anti loc x = let e = - let loc = + let loc = ifdef OCAML_308 then loc else @@ -30,87 +30,6 @@ let anti loc x = in <:expr< $anti:e$ >> -(* [mlexpr_of_ast] contributes to translate g_*.ml4 files into g_*.ppo *) -(* This is where $id's (and macros) in ast are translated in ML variables *) -(* which will bind their actual ast value *) - -let rec mlexpr_of_ast = function - | Coqast.Nmeta (loc, id) -> anti loc id - | Coqast.Id (loc, id) when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >> - | Coqast.Node (_, "$VAR", [Coqast.Nmeta (loc, x)]) -> - <:expr< let s = $anti loc x$ in - if String.length s > 0 && String.sub s 0 1 = "$" then - failwith "Wrong ast: $VAR should not be bound to a meta variable" - else - Coqast.Nvar loc (Names.id_of_string s) >> - | Coqast.Node (_, "$PATH", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Path loc $anti loc x$ >> - | Coqast.Node (_, "$ID", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Id loc $anti loc x$ >> - | Coqast.Node (_, "$STR", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Str loc $anti loc x$ >> -(* Obsolète - | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] -> - <:expr< - List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $mlexpr_of_ast y$ >> -*) - | Coqast.Node (loc, "$ABSTRACT", [Coqast.Str (_, s); x; y]) -> - let x = mlexpr_of_ast x in - let y = mlexpr_of_ast y in - <:expr< Ast.abstract_binders_ast loc $str:s$ $x$ $y$ >> - | Coqast.Node (loc, nn, al) -> - let e = expr_list_of_ast_list al in - <:expr< Coqast.Node loc $str:nn$ $e$ >> - | Coqast.Nvar (loc, id) -> - <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >> - | Coqast.Slam (loc, None, a) -> - <:expr< Coqast.Slam loc None $mlexpr_of_ast a$ >> - | Coqast.Smetalam (loc, s, a) -> - <:expr< - match $anti loc s$ with - [ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $mlexpr_of_ast a$ - | Coqast.Nmeta _ s -> Coqast.Smetalam loc s $mlexpr_of_ast a$ - | _ -> failwith "Slam expects a var or a metavar" ] >> - | Coqast.Slam (loc, Some s, a) -> - let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in - <:expr< Coqast.Slam loc (Some $se$) $mlexpr_of_ast a$ >> - | Coqast.Num (loc, i) -> <:expr< Coqast.Num loc $int:string_of_int i$ >> - | Coqast.Id (loc, id) -> <:expr< Coqast.Id loc $str:id$ >> - | Coqast.Str (loc, str) -> <:expr< Coqast.Str loc $str:str$ >> - | Coqast.Path (loc, kn) -> - let l,a = Libnames.decode_kn kn in - let mlexpr_of_modid id = - <:expr< Names.id_of_string $str:string_of_id id$ >> in - let e = List.map mlexpr_of_modid (repr_dirpath l) in - let e = expr_list_of_var_list e in - <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$) - (Names.id_of_string $str:Names.string_of_id a$)) >> - | Coqast.Dynamic (_, _) -> - failwith "Q_Coqast: dynamic: not implemented" - -and expr_list_of_ast_list al = - List.fold_right - (fun a e2 -> match a with - | (Coqast.Node (_, "$LIST", [Coqast.Nmeta (locv, pv)])) -> - let e1 = anti locv pv in - let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in - if e2 = (let loc = dummy_loc in <:expr< [] >>) - then <:expr< $e1$ >> - else <:expr< ( $lid:"@"$ $e1$ $e2$) >> - | _ -> - let e1 = mlexpr_of_ast a in - let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in - <:expr< [$e1$ :: $e2$] >> ) - al (let loc = dummy_loc in <:expr< [] >>) - -and expr_list_of_var_list sl = - let loc = dummy_loc in - List.fold_right - (fun e1 e2 -> - let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in - <:expr< [$e1$ :: $e2$] >>) - sl <:expr< [] >> - (* We don't give location for tactic quotation! *) let loc = dummy_loc @@ -139,6 +58,7 @@ let mlexpr_of_reference = function let mlexpr_of_intro_pattern = function | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO" | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> + | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >> | Genarg.IntroIdentifier id -> <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> @@ -165,12 +85,12 @@ let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident) let mlexpr_of_occs = mlexpr_of_list mlexpr_of_int let mlexpr_of_hyp_location = function - | id, occs, (Tacexpr.InHyp,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHyp, ref None)) >> - | id, occs, (Tacexpr.InHypTypeOnly,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypTypeOnly, ref None)) >> - | id, occs, (Tacexpr.InHypValueOnly,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypValueOnly,ref None)) >> + | id, occs, Tacexpr.InHyp -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHyp) >> + | id, occs, Tacexpr.InHypTypeOnly -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypTypeOnly) >> + | id, occs, Tacexpr.InHypValueOnly -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypValueOnly) >> let mlexpr_of_clause cl = <:expr< {Tacexpr.onhyps= @@ -179,13 +99,6 @@ let mlexpr_of_clause cl = Tacexpr.onconcl= $mlexpr_of_bool cl.Tacexpr.onconcl$; Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> -(* -let mlexpr_of_red_mode = function - | Closure.UNIFORM -> <:expr< Closure.UNIFORM >> - | Closure.SIMPL -> <:expr< Closure.SIMPL >> - | Closure.WITHBACK -> <:expr< Closure.WITHBACK >> -*) - let mlexpr_of_red_flags { Rawterm.rBeta = bb; Rawterm.rIota = bi; @@ -218,7 +131,6 @@ let rec mlexpr_of_constr = function | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> | Topconstr.CCases (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >> | Topconstr.CNotation(_,ntn,l) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ @@ -248,6 +160,7 @@ let mlexpr_of_red_expr = function | Rawterm.Pattern l -> let f = mlexpr_of_list mlexpr_of_occ_constr in <:expr< Rawterm.Pattern $f l$ >> + | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >> | Rawterm.ExtraRedExpr s -> <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ >> @@ -259,15 +172,14 @@ let rec mlexpr_of_argtype loc = function | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> - | Genarg.HypArgType -> <:expr< Genarg.HypArgType >> + | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> - | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> - | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >> + | Genarg.OpenConstrArgType b -> <:expr< Genarg.OpenConstrArgType $mlexpr_of_bool b$ >> | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> - | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >> + | Genarg.TacticArgType n -> <:expr< Genarg.TacticArgType $mlexpr_of_int n$ >> | Genarg.SortArgType -> <:expr< Genarg.SortArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> @@ -335,6 +247,11 @@ let mlexpr_of_match_rule f = function | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >> +let mlexpr_of_message_token = function + | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >> + | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> + | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> + let rec mlexpr_of_atomic_tactic = function (* Basic tactics *) | Tacexpr.TacIntroPattern pl -> @@ -350,6 +267,8 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacAssumption >> | Tacexpr.TacExact c -> <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> + | Tacexpr.TacExactNoCheck c -> + <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacApply cb -> <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >> | Tacexpr.TacElim (cb,cbo) -> @@ -384,11 +303,10 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacCut c -> <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> - | Tacexpr.TacTrueCut (na,c) -> - let na = mlexpr_of_name na in - <:expr< Tacexpr.TacTrueCut $na$ $mlexpr_of_constr c$ >> - | Tacexpr.TacForward (b,na,c) -> - <:expr< Tacexpr.TacForward $mlexpr_of_bool b$ $mlexpr_of_name na$ $mlexpr_of_constr c$ >> + | Tacexpr.TacAssert (t,ipat,c) -> + let ipat = mlexpr_of_intro_pattern ipat in + <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ + $mlexpr_of_constr c$ >> | Tacexpr.TacGeneralize cl -> <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >> | Tacexpr.TacGeneralizeDep c -> @@ -399,23 +317,25 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ >> (* Derived basic tactics *) - | Tacexpr.TacSimpleInduction (h,_) -> - <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$,ref []) >> - | Tacexpr.TacNewInduction (c,cbo,ids) -> + | Tacexpr.TacSimpleInduction h -> + <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$) >> + | Tacexpr.TacNewInduction (cl,cbo,ids) -> let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in - <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref [])>> + let ids = mlexpr_of_intro_pattern ids in +(* let ids = mlexpr_of_option mlexpr_of_intro_pattern ids in *) +(* <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ $ids$>> *) + <:expr< Tacexpr.TacNewInduction $mlexpr_of_list mlexpr_of_induction_arg cl$ $cbo$ $ids$>> | Tacexpr.TacSimpleDestruct h -> <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacNewDestruct (c,cbo,ids) -> let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in - <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref []) >> + let ids = mlexpr_of_intro_pattern ids in + <:expr< Tacexpr.TacNewDestruct $mlexpr_of_list mlexpr_of_induction_arg c$ $cbo$ $ids$ >> (* Context management *) - | Tacexpr.TacClear l -> + | Tacexpr.TacClear (b,l) -> let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClear $l$ >> + <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >> | Tacexpr.TacClearBody l -> let l = mlexpr_of_list (mlexpr_of_hyp) l in <:expr< Tacexpr.TacClearBody $l$ >> @@ -453,15 +373,15 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >> (* Automation tactics *) - | Tacexpr.TacAuto (n,l) -> + | Tacexpr.TacAuto (n,lems,l) -> let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in + let lems = mlexpr_of_list mlexpr_of_constr lems in let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $n$ $l$ >> -(* - | Tacexpr.TacTrivial l -> + <:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >> + | Tacexpr.TacTrivial (lems,l) -> let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacTrivial $l$ >> -*) + let lems = mlexpr_of_list mlexpr_of_constr lems in + <:expr< Tacexpr.TacTrivial $lems$ $l$ >> (* | Tacexpr.TacExtend (s,l) -> @@ -492,8 +412,10 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> | Tacexpr.TacProgress t -> <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacId s -> <:expr< Tacexpr.TacId $str:s$ >> - | Tacexpr.TacFail (n,s) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $str:s$ >> + | Tacexpr.TacId l -> + <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> + | Tacexpr.TacFail (n,l) -> + <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> (* | Tacexpr.TacInfo t -> TacInfo (loc,f t) @@ -507,12 +429,14 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function (mlexpr_of_option mlexpr_of_tactic) mlexpr_of_tactic_arg in <:expr< Tacexpr.TacLetIn $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacMatch (t,l) -> + | Tacexpr.TacMatch (lz,t,l) -> <:expr< Tacexpr.TacMatch + $mlexpr_of_bool lz$ $mlexpr_of_tactic t$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - | Tacexpr.TacMatchContext (lr,l) -> + | Tacexpr.TacMatchContext (lz,lr,l) -> <:expr< Tacexpr.TacMatchContext + $mlexpr_of_bool lz$ $mlexpr_of_bool lr$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> (* @@ -539,14 +463,6 @@ and mlexpr_of_tactic_arg = function <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> | _ -> failwith "mlexpr_of_tactic_arg: TODO" -let f e = - let ee s = - mlexpr_of_ast (Pcoq.Gram.Entry.parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - let fconstr e = let ee s = mlexpr_of_constr (Pcoq.Gram.Entry.parse e @@ -566,6 +482,4 @@ let ftac e = let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); -(* Quotation.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*) -(* Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*) Quotation.default := "constr" diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index b3f5393c..07b23972 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: q_util.ml4,v 1.2.2.2 2004/07/16 19:30:41 herbelin Exp $ *) +(* $Id: q_util.ml4 7732 2005-12-26 13:51:24Z herbelin $ *) (* This file defines standard combinators to build ml expressions *) @@ -66,3 +66,39 @@ let mlexpr_of_string s = <:expr< $str:s$ >> let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> + +open Vernacexpr +open Pcoq +open Genarg + +let rec interp_entry_name loc s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in + List1ArgType t, <:expr< Gramext.Slist1 $g$ >> + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in + List0ArgType t, <:expr< Gramext.Slist0 $g$ >> + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in + OptArgType t, <:expr< Gramext.Sopt $g$ >> + else + let s = if s = "hyp" then "var" else s in + let t, se = + match Pcoq.entry_type (Pcoq.get_univ "prim") s with + | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "constr") s with + | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "tactic") s with + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> + | None -> None, <:expr< $lid:s$ >> in + let t = + match t with + | Some t -> t + | None -> +(* Pp.warning_with Pp_control.err_ft + ("Unknown primitive grammar entry: "^s);*) + ExtraArgType s + in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> diff --git a/parsing/q_util.mli b/parsing/q_util.mli index a2c22bc3..d31b217c 100644 --- a/parsing/q_util.mli +++ b/parsing/q_util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: q_util.mli,v 1.2.2.1 2004/07/16 19:30:41 herbelin Exp $ i*) +(*i $Id: q_util.mli 7732 2005-12-26 13:51:24Z herbelin $ i*) val patt_of_expr : MLast.expr -> MLast.patt @@ -28,3 +28,4 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val interp_entry_name : Util.loc -> string -> Pcoq.entry_type * MLast.expr diff --git a/parsing/search.ml b/parsing/search.ml index a3d6e000..995aa953 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: search.ml,v 1.30.2.1 2004/07/16 19:30:41 herbelin Exp $ *) +(* $Id: search.ml 7837 2006-01-11 09:47:32Z herbelin $ *) open Pp open Util @@ -17,7 +17,6 @@ open Rawterm open Declarations open Libobject open Declare -open Coqast open Environ open Pattern open Matching @@ -34,27 +33,26 @@ open Nametab let print_constructors indsp fn env nconstr = for i = 1 to nconstr do - fn (ConstructRef (indsp,i)) env (Inductive.type_of_constructor env (indsp,i)) + fn (ConstructRef (indsp,i)) env (Inductiveops.type_of_constructor env (indsp,i)) done let rec head_const c = match kind_of_term c with | Prod (_,_,d) -> head_const d | LetIn (_,_,_,d) -> head_const d | App (f,_) -> head_const f - | Cast (d,_) -> head_const d + | Cast (d,_,_) -> head_const d | _ -> c (* General search, restricted to head constant if [only_head] *) let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = let env = Global.env () in - let imported = Library.opened_libraries() in let crible_rec (sp,_) lobj = match object_tag lobj with | "VARIABLE" -> (try let (idc,_,typ) = get_variable (basename sp) in if refopt = None - || head_const typ = constr_of_reference (out_some refopt) + || head_const typ = constr_of_global (out_some refopt) then fn (VarRef idc) env typ with Not_found -> (* we are in a section *) ()) @@ -62,7 +60,7 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = let kn = locate_constant (qualid_of_sp sp) in let {const_type=typ} = Global.lookup_constant kn in if refopt = None - || head_const typ = constr_of_reference (out_some refopt) + || head_const typ = constr_of_global (out_some refopt) then fn (ConstRef kn) env typ | "INDUCTIVE" -> @@ -80,7 +78,7 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = | _ -> () in try - Declaremods.iter_all_segments false crible_rec + Declaremods.iter_all_segments crible_rec with Not_found -> () @@ -104,7 +102,7 @@ let constr_to_section_path c = match kind_of_term c with let xor a b = (a or b) & (not (a & b)) let plain_display ref a c = - let pc = prterm_env a c in + let pc = pr_lconstr_env a c in let pr = pr_global ref in msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) @@ -210,7 +208,7 @@ type glob_search_about_item = | GlobSearchString of string let search_about_item (itemref,typ) = function - | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ + | GlobSearchRef ref -> Termops.occur_term (constr_of_global ref) typ | GlobSearchString s -> string_string_contains (name_of_reference itemref) s let raw_search_about filter_modules display_function l = diff --git a/parsing/search.mli b/parsing/search.mli index 62ba865d..8ee708bc 100644 --- a/parsing/search.mli +++ b/parsing/search.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: search.mli,v 1.16.2.1 2004/07/16 19:30:41 herbelin Exp $ i*) +(*i $Id: search.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) open Pp open Names diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index bbacd013..48a124a7 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacextend.ml4,v 1.10.2.2 2004/07/16 19:30:41 herbelin Exp $ *) +(* $Id: tacextend.ml4 7732 2005-12-26 13:51:24Z herbelin $ *) open Genarg open Q_util @@ -36,6 +36,8 @@ let rec make_when loc = function <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >> | _::l -> make_when loc l +let is_tactic_arg = function TacticArgType _ -> true | _ -> false + let rec make_let e = function | [] -> e | TacNonTerm(loc,t,_,Some p)::l -> @@ -45,13 +47,13 @@ let rec make_let e = function let v = (* Special case for tactics which must be stored in algebraic form to avoid marshalling closures and to be reprinted *) - if t = TacticArgType then + if is_tactic_arg t then <:expr< ($v$, Tacinterp.eval_tactic $v$) >> else v in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let e l -let add_clause s (_,pt,e) l = +let add_clause s (pt,e) l = let p = make_patt pt in let w = Some (make_when (MLast.loc_of_expr e) pt) in (p, w, make_let e pt)::l @@ -62,7 +64,7 @@ let rec extract_signature = function | _::l -> extract_signature l let check_unicity s l = - let l' = List.map (fun (_,l,_) -> extract_signature l) l in + let l' = List.map (fun (l,_) -> extract_signature l) l in if not (Util.list_distinct l') then Pp.warning_with Pp_control.err_ft ("Two distinct rules of tactic entry "^s^" have the same\n"^ @@ -82,7 +84,7 @@ let rec make_args = function let rec make_eval_tactic e = function | [] -> e - | TacNonTerm(loc,TacticArgType,_,Some p)::l -> + | TacNonTerm(loc,TacticArgType _,_,Some p)::l -> let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_eval_tactic e l in (* Special case for tactics which must be stored in algebraic @@ -106,11 +108,8 @@ let mlexpr_terminals_of_grammar_production = function | TacTerm s -> <:expr< Some $mlexpr_of_string s$ >> | TacNonTerm (loc,nt,g,sopt) -> <:expr< None >> -let mlexpr_of_semi_clause = - mlexpr_of_pair mlexpr_of_string (mlexpr_of_list mlexpr_of_grammar_production) - let mlexpr_of_clause = - mlexpr_of_list (fun (a,b,c) -> mlexpr_of_semi_clause (a,b)) + mlexpr_of_list (fun (a,b) -> mlexpr_of_list mlexpr_of_grammar_production a) let rec make_tags loc = function | [] -> <:expr< [] >> @@ -121,44 +120,13 @@ let rec make_tags loc = function <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l -let make_one_printing_rule (s,pt,e) = +let make_one_printing_rule se (pt,e) = + let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in let prods = mlexpr_of_list mlexpr_terminals_of_grammar_production pt in - <:expr< ($make_tags loc pt$, ($str:s$, $prods$)) >> + <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >> -let make_printing_rule = mlexpr_of_list make_one_printing_rule - -let new_tac_ext (s,cl) = - (String.lowercase s, List.map - (fun (s,l,e) -> - (String.lowercase s, List.map - (function TacTerm s -> TacTerm (String.lowercase s) - | t -> t) l, - e)) - cl) - -let declare_tactic_v7 loc s cl = - let pp = make_printing_rule cl in - let gl = mlexpr_of_clause cl in - let hide_tac (_,p,e) = - (* reste a definir les fonctions cachees avec des noms frais *) - let stac = let s = "h_"^s in s.[2] <- Char.lowercase s.[2]; s in - let e = - make_fun - <:expr< - Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ - >> - p in - <:str_item< value $lid:stac$ = $e$ >> - in - let se = mlexpr_of_string s in - <:str_item< - declare - open Pcoq; - Egrammar.extend_tactic_grammar $se$ $gl$; - List.iter (Pptactic.declare_extra_tactic_pprule False $se$) $pp$; - end - >> +let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se) let rec contains_epsilon = function | List0ArgType _ -> true @@ -167,89 +135,50 @@ let rec contains_epsilon = function | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2 | ExtraArgType("hintbases") -> true | _ -> false -let is_atomic = - List.for_all - (function - TacTerm _ -> false - | TacNonTerm(_,t,_,_) -> contains_epsilon t) +let is_atomic = function + | TacTerm s :: l when + List.for_all (function + TacTerm _ -> false + | TacNonTerm(_,t,_,_) -> contains_epsilon t) l + -> [s] + | _ -> [] let declare_tactic loc s cl = - let (s',cl') = new_tac_ext (s,cl) in - let pp' = make_printing_rule cl' in - let gl' = mlexpr_of_clause cl' in - let se' = mlexpr_of_string s' in - let pp = make_printing_rule cl in + let se = mlexpr_of_string s in + let pp = make_printing_rule se cl in let gl = mlexpr_of_clause cl in - let hide_tac (_,p,e) = + let hide_tac (p,e) = (* reste a definir les fonctions cachees avec des noms frais *) - let stac = "h_"^s' in + let stac = "h_"^s in let e = make_fun <:expr< - Refiner.abstract_extended_tactic $mlexpr_of_string s'$ $make_args p$ $make_eval_tactic e p$ + Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ >> p in <:str_item< value $lid:stac$ = $e$ >> in - let hidden = if List.length cl = 1 then List.map hide_tac cl' else [] in - let se = mlexpr_of_string s in + let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in let atomic_tactics = - mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s) - (List.filter (fun (_,al,_) -> is_atomic al) cl') in + mlexpr_of_list mlexpr_of_string + (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in <:str_item< declare open Pcoq; declare $list:hidden$ end; try - let _=Refiner.add_tactic $se'$ (fun [ $list:make_clauses s' cl'$ ]) in + let _=Refiner.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in List.iter (fun s -> Tacinterp.add_primitive_tactic s (Tacexpr.TacAtom($default_loc$, Tacexpr.TacExtend($default_loc$,s,[])))) $atomic_tactics$ with e -> Pp.pp (Cerrors.explain_exn e); - if Options.v7.val then Egrammar.extend_tactic_grammar $se'$ $gl$ - else Egrammar.extend_tactic_grammar $se'$ $gl'$; - List.iter (Pptactic.declare_extra_tactic_pprule True $se'$) $pp'$; - List.iter (Pptactic.declare_extra_tactic_pprule False $se'$) $pp$; + Egrammar.extend_tactic_grammar $se$ $gl$; + List.iter Pptactic.declare_extra_tactic_pprule $pp$; end >> -open Vernacexpr -open Pcoq - -let rec interp_entry_name loc s = - let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in - List1ArgType t, <:expr< Gramext.Slist1 $g$ >> - else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in - List0ArgType t, <:expr< Gramext.Slist0 $g$ >> - else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in - OptArgType t, <:expr< Gramext.Sopt $g$ >> - else - - let t, se = - match Pcoq.entry_type (Pcoq.get_univ "prim") s with - | Some _ as x -> x, <:expr< Prim. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "constr") s with - | Some _ as x -> x, <:expr< Constr. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "tactic") s with - | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> - | None -> None, <:expr< $lid:s$ >> in - let t = - match t with - | Some t -> t - | None -> -(* Pp.warning_with Pp_control.err_ft - ("Unknown primitive grammar entry: "^s);*) - ExtraArgType s - in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> - open Pcaml EXTEND @@ -258,24 +187,23 @@ EXTEND [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> - declare_tactic loc s l - | "V7"; "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; - OPT "|"; l = LIST1 tacrule SEP "|"; - "END" -> - declare_tactic_v7 loc s l ] ] + declare_tactic loc s l ] ] ; tacrule: - [ [ "["; s = STRING; l = LIST0 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" - -> - if s = "" then Util.user_err_loc (loc,"",Pp.str "Tactic name is empty"); - (s,l,e) + [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" + -> + if match List.hd l with TacNonTerm _ -> true | _ -> false then + (* En attendant la syntaxe de tacticielles *) + failwith "Tactic syntax must start with an identifier"; + (l,e) ] ] ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name loc e in + let t, g = Q_util.interp_entry_name loc e in TacNonTerm (loc, t, g, Some s) | s = STRING -> + if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal"); TacTerm s ] ] ; diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml new file mode 100644 index 00000000..3584e375 --- /dev/null +++ b/parsing/tactic_printer.ml @@ -0,0 +1,141 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: tactic_printer.ml 7837 2006-01-11 09:47:32Z herbelin $ *) + +open Pp +open Util +open Sign +open Evd +open Tacexpr +open Proof_type +open Proof_trees +open Logic +open Printer + +let pr_tactic = function + | TacArg (Tacexp t) -> + (*top tactic from tacinterp*) + Pptactic.pr_glob_tactic (Global.env()) t + | t -> + Pptactic.pr_tactic (Global.env()) t + +let pr_rule = function + | Prim r -> hov 0 (pr_prim_rule r) + | Tactic (texp,_) -> hov 0 (pr_tactic texp) + | Change_evars -> + (* This is internal tactic and cannot be replayed at user-level. + Function pr_rule_dot below is used when we want to hide + Change_evars *) + str "Evar change" + +(* Does not print change of evars *) +let pr_rule_dot = function + | Change_evars -> mt () + | r -> pr_rule r ++ str"." + +exception Different + +(* We remove from the var context of env what is already in osign *) +let thin_sign osign sign = + Sign.fold_named_context + (fun (id,c,ty as d) sign -> + try + if Sign.lookup_named id osign = (id,c,ty) then sign + else raise Different + with Not_found | Different -> Environ.push_named_context_val d sign) + sign ~init:Environ.empty_named_context_val + +let rec print_proof sigma osign pf = + let {evar_hyps=hyps; evar_concl=cl; + evar_body=body} = pf.goal in + let hyps = Environ.named_context_of_val hyps in + let hyps' = thin_sign osign hyps in + match pf.ref with + | None -> + hov 0 (pr_goal {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) + | Some(r,spfl) -> + hov 0 + (hov 0 (pr_goal {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) ++ + spc () ++ str" BY " ++ + hov 0 (pr_rule r) ++ fnl () ++ + str" " ++ + hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl) +) + +let pr_change gl = + str"Change " ++ + pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"." + +let rec print_script nochange sigma osign pf = + let {evar_hyps=sign; evar_concl=cl} = pf.goal in + let sign = Environ.named_context_of_val sign in + match pf.ref with + | None -> + (if nochange then + (str"<Your Tactic Text here>") + else + pr_change pf.goal) + ++ fnl () + | Some(r,spfl) -> + ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++ + pr_rule_dot r ++ fnl () ++ + prlist_with_sep pr_fnl + (print_script nochange sigma sign) spfl) + +(* printed by Show Script command *) +let print_treescript nochange sigma _osign pf = + let rec aux top pf = + match pf.ref with + | None -> + if nochange then + (str"<Your Tactic Text here>") + else + (pr_change pf.goal) + | Some(r,spfl) -> + (if nochange then mt () else (pr_change pf.goal ++ fnl ())) ++ + pr_rule_dot r ++ + match spfl with + | [] -> mt () + | [spf] -> fnl () ++ (if top then mt () else str " ") ++ aux top spf + | _ -> fnl () ++ str " " ++ + hov 0 (prlist_with_sep fnl (aux false) spfl) + in hov 0 (aux true pf) + +let rec print_info_script sigma osign pf = + let {evar_hyps=sign; evar_concl=cl} = pf.goal in + match pf.ref with + | None -> (mt ()) + | Some(Change_evars,[spf]) -> + print_info_script sigma osign spf + | Some(r,spfl) -> + (pr_rule r ++ + match spfl with + | [pf1] -> + if pf1.ref = None then + (str "." ++ fnl ()) + else + (str";" ++ brk(1,3) ++ + print_info_script sigma + (Environ.named_context_of_val sign) pf1) + | _ -> (str"." ++ fnl () ++ + prlist_with_sep pr_fnl + (print_info_script sigma + (Environ.named_context_of_val sign)) spfl)) + +let format_print_info_script sigma osign pf = + hov 0 (print_info_script sigma osign pf) + +let print_subscript sigma sign pf = + if is_tactic_proof pf then + format_print_info_script sigma sign (subproof_of_proof pf) + else + format_print_info_script sigma sign pf + +let _ = Refiner.set_info_printer print_subscript + diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli new file mode 100644 index 00000000..db5dd794 --- /dev/null +++ b/parsing/tactic_printer.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: tactic_printer.mli 6113 2004-09-17 20:28:19Z barras $ i*) + +(*i*) +open Pp +open Sign +open Evd +open Tacexpr +open Proof_type +(*i*) + +(* These are the entry points for tactics, proof trees, ... *) + +val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds +val pr_rule : rule -> std_ppcmds +val pr_tactic : tactic_expr -> std_ppcmds +val print_script : + bool -> evar_map -> named_context -> proof_tree -> std_ppcmds +val print_treescript : + bool -> evar_map -> named_context -> proof_tree -> std_ppcmds diff --git a/parsing/termast.ml b/parsing/termast.ml deleted file mode 100644 index 47e45d42..00000000 --- a/parsing/termast.ml +++ /dev/null @@ -1,503 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: termast.ml,v 1.78.2.1 2004/07/16 19:30:42 herbelin Exp $ *) - -open Pp -open Util -open Univ -open Names -open Nameops -open Term -open Termops -open Inductive -open Sign -open Environ -open Libnames -open Declare -open Impargs -open Coqast -open Ast -open Rawterm -open Pattern -open Nametab - -(* In this file, we translate rawconstr to ast, in order to print constr *) - -(**********************************************************************) -(* Parametrization *) -open Constrextern -(* -(* This governs printing of local context of references *) -let print_arguments = ref false - -(* If true, prints local context of evars, whatever print_arguments *) -let print_evar_arguments = ref false -*) - -(* This forces printing of cast nodes *) -let print_casts = ref true - -(* -(* This governs printing of implicit arguments. When - [print_implicits] is on then [print_implicits_explicit_args] tells - how implicit args are printed. If on, implicit args are printed - prefixed by "!" otherwise the function and not the arguments is - prefixed by "!" *) -let print_implicits = ref false -*) -let print_implicits_explicit_args = ref false - -(* -(* This forces printing of coercions *) -let print_coercions = ref false - -(* This forces printing universe names of Type{.} *) -let print_universes = ref false - - -let with_option o f x = - let old = !o in o:=true; - try let r = f x in o := old; r - with e -> o := old; raise e - -let with_arguments f = with_option print_arguments f -let with_casts f = with_option print_casts f -let with_implicits f = with_option print_implicits f -let with_coercions f = with_option print_coercions f -let with_universes f = with_option print_universes f -*) -(**********************************************************************) -(* conversion of references *) - -let ids_of_ctxt ctxt = - Array.to_list - (Array.map - (function c -> match kind_of_term c with - | Var id -> id - | _ -> - error - "Termast: arbitrary substitution of references not yet implemented") - ctxt) - -let ast_of_ident id = nvar id - -let ast_of_name = function - | Name id -> nvar id - | Anonymous -> nvar wildcard - -let idopt_of_name = function - | Name id -> Some id - | Anonymous -> None - -let ast_of_binders bl = - List.map (fun (nal,isdef,ty) -> - if isdef then ope("LETBINDER",ty::List.map ast_of_name nal) - else ope("BINDER",ty::List.map ast_of_name nal)) bl - -let ast_type_of_binder bl t = - List.fold_right (fun (nal,isdef,ty) ast -> - if isdef then - ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) - else - ope("PROD",[ty;List.fold_right - (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) - bl t - -let ast_body_of_binder bl t = - List.fold_right (fun (nal,isdef,ty) ast -> - if isdef then - ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) - else - ope("LAMBDA",[ty;List.fold_right - (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) - bl t - -let ast_of_constant_ref sp = - ope("CONST", [path_section dummy_loc sp]) - -let ast_of_existential_ref ev = -(* - let ev = - try int_of_string (string_of_id ev) - with _ -> warning "cannot find existential variable number"; 0 in -*) - ope("EVAR", [num ev]) - -let ast_of_constructor_ref ((sp,tyi),n) = - ope("MUTCONSTRUCT",[path_section dummy_loc sp; num tyi; num n]) - -let ast_of_inductive_ref (sp,tyi) = - ope("MUTIND", [path_section dummy_loc sp; num tyi]) - -let ast_of_section_variable_ref s = - ope("SECVAR", [nvar s]) - -let ast_of_qualid p = - let dir, s = repr_qualid p in - let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in - ope ("QUALID", args) - -let ast_of_ref = function - | ConstRef sp -> ast_of_constant_ref sp - | IndRef sp -> ast_of_inductive_ref sp - | ConstructRef sp -> ast_of_constructor_ref sp - | VarRef id -> ast_of_section_variable_ref id - -(**********************************************************************) -(* conversion of patterns *) - -let rec ast_of_cases_pattern = function (* loc is thrown away for printing *) - | PatVar (loc,Name id) -> nvar id - | PatVar (loc,Anonymous) -> nvar wildcard - | PatCstr(loc,cstrsp,args,Name id) -> - let args = List.map ast_of_cases_pattern args in - ope("PATTAS", - [nvar id; - ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)]) - | PatCstr(loc,cstrsp,args,Anonymous) -> - ope("PATTCONSTRUCT", - (ast_of_constructor_ref cstrsp) - :: List.map ast_of_cases_pattern args) - -let ast_dependent na aty = - match na with - | Name id -> occur_var_ast id aty - | Anonymous -> false - -let decompose_binder = function - | RProd(_,na,ty,c) -> Some (BProd,na,ty,c) - | RLambda(_,na,ty,c) -> Some (BLambda,na,ty,c) - | RLetIn(_,na,b,c) -> Some (BLetIn,na,b,c) - | _ -> None - -(* Implicit args indexes are in ascending order *) -let explicitize impl args = - let n = List.length args in - let rec exprec q = function - | a::args, imp::impl when is_status_implicit imp -> - let tail = exprec (q+1) (args,impl) in - let visible = - (!print_implicits & !print_implicits_explicit_args) - or not (is_inferable_implicit false n imp) in - if visible then ope("EXPL", [num q; a]) :: tail else tail - | a::args, _::impl -> a :: exprec (q+1) (args,impl) - | args, [] -> args (* In case of polymorphism *) - | [], _ -> [] - in exprec 1 (args,impl) - -let rec skip_coercion dest_ref (f,args as app) = - if !print_coercions then app - else - try - match dest_ref f with - | Some r -> - (match Classops.hide_coercion r with - | Some n -> - if n >= List.length args then app - else (* We skip a coercion *) - let fargs = list_skipn n args in - skip_coercion dest_ref (List.hd fargs,List.tl fargs) - | None -> app) - | None -> app - with Not_found -> app - -let ast_of_app impl f args = - if !print_implicits & not !print_implicits_explicit_args then - ope("APPLISTEXPL", f::args) - else - let args = explicitize impl args in - if args = [] then f else ope("APPLIST", f::args) - -let rec ast_of_raw = function - | RRef (_,ref) -> ast_of_ref ref - | RVar (_,id) -> ast_of_ident id - | REvar (_,n,_) -> (* we drop args *) ast_of_existential_ref n - | RPatVar (_,(_,n)) -> ope("META",[ast_of_ident n]) - | RApp (_,f,args) -> - let (f,args) = - skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in - let astf = ast_of_raw f in - let astargs = List.map ast_of_raw args in - (match f with - | RRef (_,ref) -> ast_of_app (implicits_of_global ref) astf astargs - | _ -> ast_of_app [] astf astargs) - - | RProd (_,Anonymous,t,c) -> - (* Anonymous product are never factorized *) - ope("ARROW",[ast_of_raw t; slam(None,ast_of_raw c)]) - - | RLetIn (_,na,t,c) -> - ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)]) - - | RProd (_,na,t,c) -> - let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in - (* PROD et PRODLIST doivent être distingués à cause du cas *) - (* non dépendant, pour isoler l'implication; peut-être un *) - (* constructeur ARROW serait-il plus justifié ? *) - let tag = if n=1 then "PROD" else "PRODLIST" in - ope(tag,[ast_of_raw t;a]) - - | RLambda (_,na,t,c) -> - let (n,a) = factorize_binder 1 BLambda na (ast_of_raw t) c in - (* LAMBDA et LAMBDALIST se comportent pareil ... Non ! *) - (* Pour compatibilité des theories, il faut LAMBDALIST partout *) - ope("LAMBDALIST",[ast_of_raw t;a]) - - | RCases (_,(typopt,_),tml,eqns) -> - let pred = ast_of_rawopt typopt in - let tag = "CASES" in - let asttomatch = - ope("TOMATCH", List.map (fun (tm,_) -> ast_of_raw tm) tml) in - let asteqns = List.map ast_of_eqn eqns in - ope(tag,pred::asttomatch::asteqns) - - | ROrderedCase (_,LetStyle,typopt,tm,[|bv|],_) -> - let nvar' = function Anonymous -> nvar wildcard | Name id -> nvar id in - let rec f l = function - | RLambda (_,na,RHole _,c) -> f (nvar' na :: l) c - | RLetIn (_,na,RHole _,c) -> f (nvar' na :: l) c - | c -> List.rev l, ast_of_raw c in - let l,c = f [] bv in - let eqn = ope ("EQN", [c;ope ("PATTCONSTRUCT",(nvar wildcard)::l)]) in - ope ("FORCELET",[(ast_of_rawopt typopt);(ast_of_raw tm);eqn]) - - | ROrderedCase (_,st,typopt,tm,bv,_) -> - let tag = match st with - | IfStyle -> "FORCEIF" - | RegularStyle -> "CASE" - | MatchStyle | LetStyle -> "MATCH" - in - - (* warning "Old Case syntax"; *) - ope(tag,(ast_of_rawopt typopt) - ::(ast_of_raw tm) - ::(Array.to_list (Array.map ast_of_raw bv))) - - | RLetTuple _ | RIf _ -> - error "Let tuple not supported in v7" - - | RRec (_,fk,idv,blv,tyv,bv) -> - let alfi = Array.map ast_of_ident idv in - (match fk with - | RFix (nv,n) -> - let rec split_lambda binds = function - | (0, t) -> (List.rev binds,ast_of_raw t) - | (n, RLetIn (_,na,b,c)) -> - let bind = ope("LETBINDER",[ast_of_raw b;ast_of_name na]) in - split_lambda (bind::binds) (n,c) - | (n, RLambda (_,na,t,b)) -> - let bind = ope("BINDER",[ast_of_raw t;ast_of_name na]) in - split_lambda (bind::binds) (n-1,b) - | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint body" in - let rec split_product = function - | (0, t) -> ast_of_raw t - | (n, RLetIn (_,na,_,c)) -> split_product (n,c) - | (n, RProd (_,na,t,b)) -> split_product (n-1,b) - | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint type" in - let listdecl = - Array.mapi - (fun i fi -> - if List.length blv.(i) >= nv.(i)+1 then - let (oldfixp,factb) = list_chop (nv.(i)+1) blv.(i) in - let bl = factorize_local_binder oldfixp in - let factb = factorize_local_binder factb in - let asttyp = ast_type_of_binder factb - (ast_of_raw tyv.(i)) in - let astdef = ast_body_of_binder factb - (ast_of_raw bv.(i)) in - ope("FDECL",[fi;ope("BINDERS",ast_of_binders bl); - asttyp; astdef]) - else - let n = nv.(i)+1 - List.length blv.(i) in - let (lparams,astdef) = - split_lambda [] (n,bv.(i)) in - let bl = factorize_local_binder blv.(i) in - let lparams = ast_of_binders bl @ lparams in - let asttyp = split_product (n,tyv.(i)) in - ope("FDECL", - [fi; ope ("BINDERS",lparams); - asttyp; astdef])) - alfi - in - ope("FIX", alfi.(n)::(Array.to_list listdecl)) - | RCoFix n -> - let listdecl = - Array.mapi - (fun i fi -> - let bl = factorize_local_binder blv.(i) in - let asttyp = ast_type_of_binder bl (ast_of_raw tyv.(i)) in - let astdef = ast_body_of_binder bl (ast_of_raw bv.(i)) in - ope("CFDECL",[fi; asttyp; astdef])) - alfi - in - ope("COFIX", alfi.(n)::(Array.to_list listdecl))) - - | RSort (_,s) -> - (match s with - | RProp Null -> ope("PROP",[]) - | RProp Pos -> ope("SET",[]) - | RType (Some u) when !print_universes -> ope("TYPE",[ide(Univ.string_of_univ u)]) - | RType _ -> ope("TYPE",[])) - | RHole _ -> ope("ISEVAR",[]) - | RCast (_,c,t) -> ope("CAST",[ast_of_raw c;ast_of_raw t]) - | RDynamic (loc,d) -> Dynamic (loc,d) - -and ast_of_eqn (_,ids,pl,c) = - ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl)) - -and ast_of_rawopt = function - | None -> (string "SYNTH") - | Some p -> ast_of_raw p - -and factorize_binder n oper na aty c = - let (p,body) = match decompose_binder c with - | Some (oper',na',ty',c') - when (oper = oper') & (aty = ast_of_raw ty') - & not (ast_dependent na aty) (* To avoid na in ty' escapes scope *) - & not (na' = Anonymous & oper = BProd) - -> factorize_binder (n+1) oper na' aty c' - | _ -> (n,ast_of_raw c) - in - (p,slam(idopt_of_name na, body)) - -and factorize_local_binder = function - [] -> [] - | (na,Some bd,ty)::l -> - ([na],true,ast_of_raw bd) :: factorize_local_binder l - | (na,None,ty)::l -> - let ty = ast_of_raw ty in - (match factorize_local_binder l with - (lna,false,ty') :: l when ty=ty' -> - (na::lna,false,ty') :: l - | l -> ([na],false,ty) :: l) - - -let ast_of_rawconstr = ast_of_raw - -(******************************************************************) -(* Main translation function from constr -> ast *) - -let ast_of_constr at_top env t = - let t' = - if !print_casts then t - else Reductionops.local_strong strip_outer_cast t in - let avoid = if at_top then ids_of_context env else [] in - ast_of_raw - (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t') - -let ast_of_constant env sp = - let a = ast_of_constant_ref sp in - a - -let ast_of_existential env (ev,ids) = - let a = ast_of_existential_ref ev in - if !print_arguments or !print_evar_arguments then - ope("INSTANCE",a::(array_map_to_list (ast_of_constr false env) ids)) - else a - -let ast_of_constructor env cstr_sp = - let a = ast_of_constructor_ref cstr_sp in - a - -let ast_of_inductive env ind_sp = - let a = ast_of_inductive_ref ind_sp in - a - -let decompose_binder_pattern = function - | PProd(na,ty,c) -> Some (BProd,na,ty,c) - | PLambda(na,ty,c) -> Some (BLambda,na,ty,c) - | PLetIn(na,b,c) -> Some (BLetIn,na,b,c) - | _ -> None - -let rec ast_of_pattern tenv env = function - | PRef ref -> ast_of_ref ref - - | PVar id -> ast_of_ident id - - | PEvar (n,_) -> ast_of_existential_ref n - - | PRel n -> - (try match lookup_name_of_rel n env with - | Name id -> ast_of_ident id - | Anonymous -> - anomaly "ast_of_pattern: index to an anonymous variable" - with Not_found -> - nvar (id_of_string ("[REL "^(string_of_int n)^"]"))) - - | PApp (f,args) -> - let (f,args) = - skip_coercion (function PRef r -> Some r | _ -> None) - (f,Array.to_list args) in - let astf = ast_of_pattern tenv env f in - let astargs = List.map (ast_of_pattern tenv env) args in - (match f with - | PRef ref -> ast_of_app (implicits_of_global ref) astf astargs - | _ -> ast_of_app [] astf astargs) - - | PSoApp (n,args) -> - ope("SOAPP",(ope ("META",[ast_of_ident n])):: - (List.map (ast_of_pattern tenv env) args)) - - | PLetIn (na,b,c) -> - let c' = ast_of_pattern tenv (add_name na env) c in - ope("LETIN",[ast_of_pattern tenv env b;slam(idopt_of_name na,c')]) - - | PProd (Anonymous,t,c) -> - ope("PROD",[ast_of_pattern tenv env t; - slam(None,ast_of_pattern tenv env c)]) - | PProd (na,t,c) -> - let env' = add_name na env in - let (n,a) = - factorize_binder_pattern tenv env' 1 BProd na - (ast_of_pattern tenv env t) c in - (* PROD et PRODLIST doivent être distingués à cause du cas *) - (* non dépendant, pour isoler l'implication; peut-être un *) - (* constructeur ARROW serait-il plus justifié ? *) - let tag = if n=1 then "PROD" else "PRODLIST" in - ope(tag,[ast_of_pattern tenv env t;a]) - | PLambda (na,t,c) -> - let env' = add_name na env in - let (n,a) = - factorize_binder_pattern tenv env' 1 BLambda na - (ast_of_pattern tenv env t) c in - (* LAMBDA et LAMBDALIST se comportent pareil *) - let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in - ope(tag,[ast_of_pattern tenv env t;a]) - - | PCase (st,typopt,tm,bv) -> - warning "Old Case syntax"; - ope("MUTCASE",(ast_of_patopt tenv env typopt) - ::(ast_of_pattern tenv env tm) - ::(Array.to_list (Array.map (ast_of_pattern tenv env) bv))) - - | PSort s -> - (match s with - | RProp Null -> ope("PROP",[]) - | RProp Pos -> ope("SET",[]) - | RType _ -> ope("TYPE",[])) - - | PMeta (Some n) -> ope("META",[ast_of_ident n]) - | PMeta None -> ope("ISEVAR",[]) - | PFix f -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkFix f)) - | PCoFix c -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkCoFix c)) - -and ast_of_patopt tenv env = function - | None -> (string "SYNTH") - | Some p -> ast_of_pattern tenv env p - -and factorize_binder_pattern tenv env n oper na aty c = - let (p,body) = match decompose_binder_pattern c with - | Some (oper',na',ty',c') - when (oper = oper') & (aty = ast_of_pattern tenv env ty') - & not (na' = Anonymous & oper = BProd) - -> - factorize_binder_pattern tenv (add_name na' env) (n+1) oper na' aty c' - | _ -> (n,ast_of_pattern tenv env c) - in - (p,slam(idopt_of_name na, body)) diff --git a/parsing/termast.mli b/parsing/termast.mli deleted file mode 100644 index c66e8f0f..00000000 --- a/parsing/termast.mli +++ /dev/null @@ -1,55 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: termast.mli,v 1.24.2.1 2004/07/16 19:30:42 herbelin Exp $ i*) - -(*i*) -open Names -open Term -open Termops -open Sign -open Environ -open Libnames -open Nametab -open Rawterm -open Pattern -(*i*) - -(* Translation of pattern, cases pattern, rawterm and term into syntax - trees for printing *) - -val ast_of_cases_pattern : cases_pattern -> Coqast.t -val ast_of_rawconstr : rawconstr -> Coqast.t -val ast_of_pattern : env -> names_context -> constr_pattern -> Coqast.t - -(* If [b=true] in [ast_of_constr b env c] then the variables in the first - level of quantification clashing with the variables in [env] are renamed *) - -val ast_of_constr : bool -> env -> constr -> Coqast.t - -val ast_of_constant : env -> constant -> Coqast.t -val ast_of_existential : env -> existential -> Coqast.t -val ast_of_constructor : env -> constructor -> Coqast.t -val ast_of_inductive : env -> inductive -> Coqast.t -val ast_of_ref : global_reference -> Coqast.t -val ast_of_qualid : qualid -> Coqast.t - -(*i Now in constrextern.mli -val print_implicits : bool ref -val print_casts : bool ref -val print_arguments : bool ref -val print_evar_arguments : bool ref -val print_coercions : bool ref -val print_universes : bool ref - -val with_casts : ('a -> 'b) -> 'a -> 'b -val with_implicits : ('a -> 'b) -> 'a -> 'b -val with_arguments : ('a -> 'b) -> 'a -> 'b -val with_coercions : ('a -> 'b) -> 'a -> 'b -val with_universes : ('a -> 'b) -> 'a -> 'b -i*) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index bdc1ea66..af0d6781 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -6,12 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: vernacextend.ml4,v 1.5.2.2 2004/07/16 19:30:42 herbelin Exp $ *) +(* $Id: vernacextend.ml4 7732 2005-12-26 13:51:24Z herbelin $ *) open Genarg open Q_util open Q_coqast -open Ast open Argextend let join_loc (deb1,_) (_,fin2) = (deb1,fin2) @@ -81,11 +80,8 @@ let mlexpr_of_grammar_production = function let mlexpr_of_clause = mlexpr_of_list - (fun (a,b,c) -> - (mlexpr_of_pair - mlexpr_of_string - (mlexpr_of_list mlexpr_of_grammar_production) - (a,b))) + (fun (a,b,c) -> + mlexpr_of_list mlexpr_of_grammar_production (VernacTerm a::b)) let declare_command loc s cl = let gl = mlexpr_of_clause cl in @@ -99,40 +95,6 @@ let declare_command loc s cl = end >> -open Vernacexpr -open Pcoq - -let rec interp_entry_name loc s = - let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in - List1ArgType t, <:expr< Gramext.Slist1 $g$ >> - else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in - List0ArgType t, <:expr< Gramext.Slist0 $g$ >> - else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in - OptArgType t, <:expr< Gramext.Sopt $g$ >> - else - let t, se = - match Pcoq.entry_type (Pcoq.get_univ "prim") s with - | Some _ as x -> x, <:expr< Prim. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "constr") s with - | Some _ as x -> x, <:expr< Constr. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "tactic") s with - | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> - | None -> None, <:expr< $lid:s$ >> in - let t = - match t with - | Some t -> t - | None -> -(* Pp.warning_with Pp_control.err_ft - ("Unknown primitive grammar entry: "^s);*) - ExtraArgType s - in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> - open Pcaml EXTEND @@ -152,7 +114,7 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name loc e in + let t, g = Q_util.interp_entry_name loc e in VernacNonTerm (loc, t, g, Some s) | s = STRING -> VernacTerm s |