summaryrefslogtreecommitdiff
path: root/parsing
diff options
context:
space:
mode:
Diffstat (limited to 'parsing')
-rw-r--r--parsing/argextend.ml4115
-rwxr-xr-xparsing/ast.ml600
-rwxr-xr-xparsing/ast.mli123
-rw-r--r--parsing/coqast.ml123
-rw-r--r--parsing/coqast.mli51
-rw-r--r--parsing/egrammar.ml420
-rw-r--r--parsing/egrammar.mli50
-rw-r--r--parsing/esyntax.ml276
-rw-r--r--parsing/esyntax.mli61
-rw-r--r--parsing/extend.ml343
-rw-r--r--parsing/extend.mli128
-rw-r--r--parsing/g_ascii_syntax.ml81
-rw-r--r--parsing/g_basevernac.ml4524
-rw-r--r--parsing/g_cases.ml473
-rw-r--r--parsing/g_constr.ml4546
-rw-r--r--parsing/g_constrnew.ml4338
-rw-r--r--parsing/g_ltac.ml4255
-rw-r--r--parsing/g_ltacnew.ml4195
-rw-r--r--parsing/g_minicoq.ml42
-rw-r--r--parsing/g_minicoq.mli2
-rw-r--r--parsing/g_module.ml447
-rw-r--r--parsing/g_natsyntax.ml180
-rw-r--r--parsing/g_natsyntax.mli2
-rw-r--r--parsing/g_natsyntaxnew.mli2
-rw-r--r--parsing/g_prim.ml4144
-rw-r--r--parsing/g_primnew.ml484
-rw-r--r--parsing/g_proofs.ml495
-rw-r--r--parsing/g_proofsnew.ml4126
-rw-r--r--parsing/g_rsyntax.ml257
-rw-r--r--parsing/g_string_syntax.ml67
-rw-r--r--parsing/g_tactic.ml4502
-rw-r--r--parsing/g_tacticnew.ml4405
-rw-r--r--parsing/g_vernac.ml4941
-rw-r--r--parsing/g_vernacnew.ml4728
-rw-r--r--parsing/g_xml.ml4247
-rw-r--r--parsing/g_zsyntax.ml339
-rw-r--r--parsing/g_zsyntax.mli2
-rw-r--r--parsing/g_zsyntaxnew.mli2
-rw-r--r--parsing/lexer.ml4254
-rw-r--r--parsing/lexer.mli4
-rw-r--r--parsing/pcoq.ml4308
-rw-r--r--parsing/pcoq.mli58
-rw-r--r--parsing/ppconstr.ml807
-rw-r--r--parsing/ppconstr.mli58
-rw-r--r--parsing/pptactic.ml1171
-rw-r--r--parsing/pptactic.mli68
-rw-r--r--parsing/ppvernac.ml841
-rw-r--r--parsing/ppvernac.mli28
-rw-r--r--parsing/prettyp.ml157
-rw-r--r--parsing/prettyp.mli4
-rw-r--r--parsing/printer.ml377
-rw-r--r--parsing/printer.mli112
-rw-r--r--parsing/q_constr.ml4124
-rw-r--r--parsing/q_coqast.ml4184
-rw-r--r--parsing/q_util.ml438
-rw-r--r--parsing/q_util.mli3
-rw-r--r--parsing/search.ml18
-rw-r--r--parsing/search.mli2
-rw-r--r--parsing/tacextend.ml4150
-rw-r--r--parsing/tactic_printer.ml141
-rw-r--r--parsing/tactic_printer.mli27
-rw-r--r--parsing/termast.ml503
-rw-r--r--parsing/termast.mli55
-rw-r--r--parsing/vernacextend.ml446
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