diff options
35 files changed, 175 insertions, 962 deletions
diff --git a/.gitignore b/.gitignore index 58e1d346c..acb1100bc 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ *.log *.aux *.dvi +*.pdf *.blg *.bbl *.idx @@ -33,7 +34,6 @@ *.tacidx *.tacind *.v.tex -*.v.pdf *.v.ps *.v.html *.stamp @@ -71,7 +71,6 @@ test-suite/coq-makefile/*/theories2 test-suite/coq-makefile/*/html test-suite/coq-makefile/*/mlihtml test-suite/coq-makefile/*/subdir/done -test-suite/coq-makefile/latex1/all.pdf test-suite/coq-makefile/merlin1/.merlin test-suite/coq-makefile/plugin-reach-outside-API-and-fail/_CoqProject test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/_CoqProject @@ -82,12 +81,10 @@ doc/common/version.tex doc/faq/html/ doc/faq/axioms.eps doc/faq/axioms.eps_t -doc/faq/axioms.pdf doc/faq/axioms.pdf_t doc/faq/axioms.png doc/refman/.csdp.cache doc/refman/trace -doc/refman/Reference-Manual.pdf doc/refman/Reference-Manual.ps doc/refman/Reference-Manual.html doc/refman/Reference-Manual.out @@ -102,19 +99,15 @@ doc/refman/heapsort.ml doc/refman/heapsort.mli doc/refman/html/ doc/stdlib/Library.out -doc/stdlib/Library.pdf doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex -doc/stdlib/FullLibrary.pdf doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/html/ doc/stdlib/index-body.html doc/stdlib/index-list.html doc/RecTutorial/RecTutorial.html -doc/RecTutorial/RecTutorial.pdf doc/RecTutorial/RecTutorial.ps -dev/doc/naming-conventions.pdf dev/ocamldoc/*.html dev/ocamldoc/*.css diff --git a/API/API.mli b/API/API.mli index 1e078bb77..9f13f51fc 100644 --- a/API/API.mli +++ b/API/API.mli @@ -2407,7 +2407,7 @@ sig | VernacNotationAddFormat of string * string * string | VernacDefinition of (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * plident * definition_expr - | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list * bool + | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of Constrexpr.constr_expr | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * diff --git a/Makefile.common b/Makefile.common index ec5e6ac85..100698321 100644 --- a/Makefile.common +++ b/Makefile.common @@ -134,7 +134,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ ascii_syntax_plugin.cmo \ string_syntax_plugin.cmo ) DERIVECMO:=plugins/derive/derive_plugin.cmo -LTACCMO:=plugins/ltac/ltac_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ff575e432..1be72759c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -215,6 +215,7 @@ let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx let ppcumulativity_info c = pp (Univ.pr_cumulativity_info Univ.Level.pr c) +let ppabstract_cumulativity_info c = pp (Univ.pr_abstract_cumulativity_info Univ.Level.pr c) let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e)) diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml deleted file mode 100644 index 8409c7521..000000000 --- a/ide/texmacspp.ml +++ /dev/null @@ -1,769 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Xml_datatype -open Vernacexpr -open Constrexpr -open Names -open Misctypes -open Bigint -open Decl_kinds -open Extend -open Libnames -open Constrexpr_ops - -let unlock ?loc = - let start, stop = Option.cata Loc.unloc (0,0) loc in - (string_of_int start, string_of_int stop) - -let xmlWithLoc ?loc ename attr xml = - let start, stop = unlock ?loc in - Element(ename, [ "begin", start; "end", stop ] @ attr, xml) - -let get_fst_attr_in_xml_list attr xml_list = - let attrs_list = - List.map (function - | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs) - | _ -> []) - xml_list in - match List.flatten attrs_list with - | [] -> (attr, "") - | l -> (List.hd l) - -let backstep_loc xmllist = - let start_att = get_fst_attr_in_xml_list "begin" xmllist in - let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in - [start_att ; stop_att] - -let compare_begin_att xml1 xml2 = - let att1 = get_fst_attr_in_xml_list "begin" [xml1] in - let att2 = get_fst_attr_in_xml_list "begin" [xml2] in - match att1, att2 with - | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0 - | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1 - | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1 - | _ -> 0 - -let xmlBeginSection ?loc name = xmlWithLoc ?loc "beginsection" ["name", name] [] - -let xmlEndSegment ?loc name = xmlWithLoc ?loc "endsegment" ["name", name] [] - -let xmlThm ?loc typ name xml = - xmlWithLoc ?loc "theorem" ["type", typ; "name", name] xml - -let xmlDef ?loc typ name xml = - xmlWithLoc ?loc "definition" ["type", typ; "name", name] xml - -let xmlNotation ?loc attr name xml = - xmlWithLoc ?loc "notation" (("name", name) :: attr) xml - -let xmlReservedNotation ?loc attr name = - xmlWithLoc ?loc "reservednotation" (("name", name) :: attr) [] - -let xmlCst ?loc ?(attr=[]) name = - xmlWithLoc ?loc "constant" (("name", name) :: attr) [] - -let xmlOperator ?loc ?(attr=[]) ?(pprules=[]) name = - xmlWithLoc ?loc "operator" - (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) [] - -let xmlApply ?loc ?(attr=[]) xml = xmlWithLoc ?loc "apply" attr xml - -let xmlToken ?loc ?(attr=[]) xml = xmlWithLoc ?loc "token" attr xml - -let xmlTyped xml = Element("typed", (backstep_loc xml), xml) - -let xmlReturn ?(attr=[]) xml = Element("return", attr, xml) - -let xmlCase xml = Element("case", [], xml) - -let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml) - -let xmlWith xml = Element("with", [], xml) - -let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml]) - -let xmlInductive ?loc kind xml = xmlWithLoc ?loc "inductive" ["kind",kind] xml - -let xmlCoFixpoint xml = Element("cofixpoint", [], xml) - -let xmlFixpoint xml = Element("fixpoint", [], xml) - -let xmlCheck ?loc xml = xmlWithLoc ?loc "check" [] xml - -let xmlAssumption ?loc kind xml = xmlWithLoc ?loc "assumption" ["kind",kind] xml - -let xmlComment ?loc xml = xmlWithLoc ?loc "comment" [] xml - -let xmlCanonicalStructure ?loc attr = xmlWithLoc ?loc "canonicalstructure" attr [] - -let xmlQed ?loc ?(attr=[]) = xmlWithLoc ?loc "qed" attr [] - -let xmlPatvar ?loc id = xmlWithLoc ?loc "patvar" ["id", id] [] - -let xmlReference ref = - let name = Libnames.string_of_reference ref in - let i, j = Option.cata Loc.unloc (0,0) (Libnames.loc_of_reference ref) in - let b, e = string_of_int i, string_of_int j in - Element("reference",["name", name; "begin", b; "end", e] ,[]) - -let xmlRequire ?loc ?(attr=[]) xml = xmlWithLoc ?loc "require" attr xml -let xmlImport ?loc ?(attr=[]) xml = xmlWithLoc ?loc "import" attr xml - -let xmlAddLoadPath ?loc ?(attr=[]) xml = xmlWithLoc ?loc "addloadpath" attr xml -let xmlRemoveLoadPath ?loc ?(attr=[]) = xmlWithLoc ?loc "removeloadpath" attr -let xmlAddMLPath ?loc ?(attr=[]) = xmlWithLoc ?loc "addmlpath" attr - -let xmlExtend ?loc xml = xmlWithLoc ?loc "extend" [] xml - -let xmlScope ?loc ?(attr=[]) action name xml = - xmlWithLoc ?loc "scope" (["name",name;"action",action] @ attr) xml - -let xmlProofMode ?loc name = xmlWithLoc ?loc "proofmode" ["name",name] [] - -let xmlProof ?loc xml = xmlWithLoc ?loc "proof" [] xml - -let xmlSectionSubsetDescr name ssd = - Element("sectionsubsetdescr",["name",name], - [PCData (Proof_using.to_string ssd)]) - -let xmlDeclareMLModule ?loc s = - xmlWithLoc ?loc "declarexmlmodule" [] - (List.map (fun x -> Element("path",["value",x],[])) s) - -(* tactics *) -let xmlLtac ?loc xml = xmlWithLoc ?loc "ltac" [] xml - -(* toplevel commands *) -let xmlGallina ?loc xml = xmlWithLoc ?loc "gallina" [] xml - -let xmlTODO ?loc x = - xmlWithLoc ?loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - -let string_of_name n = - match n with - | Anonymous -> "_" - | Name id -> Id.to_string id - -let string_of_glob_sort s = - match s with - | GProp -> "Prop" - | GSet -> "Set" - | GType _ -> "Type" - -let string_of_cast_sort c = - match c with - | CastConv _ -> "CastConv" - | CastVM _ -> "CastVM" - | CastNative _ -> "CastNative" - | CastCoerce -> "CastCoerce" - -let string_of_case_style s = - match s with - | LetStyle -> "Let" - | IfStyle -> "If" - | LetPatternStyle -> "LetPattern" - | MatchStyle -> "Match" - | RegularStyle -> "Regular" - -let attribute_of_syntax_modifier sm = -match sm with - | SetItemLevel (sl, NumLevel n) -> - List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n] - | SetItemLevel (sl, NextLevel) -> - List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"] - | SetLevel i -> ["level", string_of_int i] - | SetAssoc a -> - begin match a with - | NonA -> ["",""] - | RightA -> ["associativity", "right"] - | LeftA -> ["associativity", "left"] - end - | SetEntryType (s, _) -> ["entrytype", s] - | SetOnlyPrinting -> ["onlyprinting", ""] - | SetOnlyParsing -> ["onlyparsing", ""] - | SetCompatVersion v -> ["compat", Flags.pr_version v] - | SetFormat (system, (loc, s)) -> - let start, stop = unlock ?loc in - ["format-"^system, s; "begin", start; "end", stop] - -let string_of_assumption_kind l a many = - match l, a, many with - | (Discharge, Logical, true) -> "Hypotheses" - | (Discharge, Logical, false) -> "Hypothesis" - | (Discharge, Definitional, true) -> "Variables" - | (Discharge, Definitional, false) -> "Variable" - | (Global, Logical, true) -> "Axioms" - | (Global, Logical, false) -> "Axiom" - | (Global, Definitional, true) -> "Parameters" - | (Global, Definitional, false) -> "Parameter" - | (Local, Logical, true) -> "Local Axioms" - | (Local, Logical, false) -> "Local Axiom" - | (Local, Definitional, true) -> "Local Parameters" - | (Local, Definitional, false) -> "Local Parameter" - | (Global, Conjectural, _) -> "Conjecture" - | ((Discharge | Local), Conjectural, _) -> assert false - -let rec pp_bindlist bl = - let tlist = - List.flatten - (List.map - (fun (loc_names, _, e) -> - let names = - (List.map - (fun (loc, name) -> - xmlCst ?loc (string_of_name name)) loc_names) in - match e.CAst.v with - | CHole _ -> names - | _ -> names @ [pp_expr e]) - bl) in - match tlist with - | [e] -> e - | l -> xmlTyped l -and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *) - Element ("decl_notation", ["name", s], [pp_expr ce]) -and pp_local_binder lb = (* don't know what it is for now *) - match lb with - | CLocalDef ((loc, nam), ce, ty) -> - let attrs = ["name", string_of_name nam] in - let value = match ty with - Some t -> CAst.make ?loc:(Loc.merge_opt (constr_loc ce) (constr_loc t)) @@ CCast (ce, CastConv t) - | None -> ce in - pp_expr ~attr:attrs value - | CLocalAssum (namll, _, ce) -> - let ppl = - List.map (fun (loc, nam) -> (xmlCst ?loc (string_of_name nam))) namll in - xmlTyped (ppl @ [pp_expr ce]) - | CLocalPattern _ -> - assert false -and pp_local_decl_expr lde = (* don't know what it is for now *) - match lde with - | AssumExpr (_, ce) -> pp_expr ce - | DefExpr (_, ce, _) -> pp_expr ce -and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = - (* inductive_expr *) - let b,e = Option.cata Loc.unloc (0,0) l in - let location = ["begin", string_of_int b; "end", string_of_int e] in - [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *) - begin match cl_or_rdexpr with - | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel - | RecordDecl (_, ldewwwl) -> - List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl - end @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end @ - (List.map pp_local_binder lbl) -and pp_recursion_order_expr optid roe = (* don't know what it is for now *) - let attrs = - match optid with - | None -> [] - | Some (loc, id) -> - let start, stop = unlock ?loc in - ["begin", start; "end", stop ; "name", Id.to_string id] in - let kind, expr = - match roe with - | CStructRec -> "struct", [] - | CWfRec e -> "rec", [pp_expr e] - | CMeasureRec (e, None) -> "mesrec", [pp_expr e] - | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in - Element ("recursion_order", ["kind", kind] @ attrs, expr) -and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = - (* fixpoint_expr *) - let start, stop = unlock ?loc in - let id = Id.to_string id in - [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ - (* fixpoint name *) - [pp_recursion_order_expr optid roe] @ - (List.map pp_local_binder lbl) @ - [pp_expr ce] @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end -and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) - (* Nota: it is like fixpoint_expr without (optid, roe) - * so could be merged if there is no more differences *) - let start, stop = unlock ?loc in - let id = Id.to_string id in - [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ - (* cofixpoint name *) - (List.map pp_local_binder lbl) @ - [pp_expr ce] @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end -and pp_lident (loc, id) = xmlCst ?loc (Id.to_string id) -and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce] -and pp_cases_pattern_expr {loc ; CAst.v = cpe} = - match cpe with - | CPatAlias (cpe, id) -> - xmlApply ?loc - (xmlOperator ?loc ~attr:["name", string_of_id id] "alias" :: - [pp_cases_pattern_expr cpe]) - | CPatCstr (ref, None, cpel2) -> - xmlApply ?loc - (xmlOperator ?loc "reference" - ~attr:["name", Libnames.string_of_reference ref] :: - [Element ("impargs", [], []); - Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) - | CPatCstr (ref, Some cpel1, cpel2) -> - xmlApply ?loc - (xmlOperator ?loc "reference" - ~attr:["name", Libnames.string_of_reference ref] :: - [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1)); - Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) - | CPatAtom optr -> - let attrs = match optr with - | None -> [] - | Some r -> ["name", Libnames.string_of_reference r] in - xmlApply ?loc (xmlOperator ?loc "atom" ~attr:attrs :: []) - | CPatOr cpel -> - xmlApply ?loc (xmlOperator ?loc "or" :: List.map pp_cases_pattern_expr cpel) - | CPatNotation (n, (subst_constr, subst_rec), cpel) -> - xmlApply ?loc - (xmlOperator ?loc "notation" :: - [xmlOperator ?loc n; - Element ("subst", [], - [Element ("subterms", [], - List.map pp_cases_pattern_expr subst_constr); - Element ("recsubterms", [], - List.map - (fun (cpel) -> - Element ("recsubterm", [], - List.map pp_cases_pattern_expr cpel)) - subst_rec)]); - Element ("args", [], (List.map pp_cases_pattern_expr cpel))]) - | CPatPrim tok -> pp_token ?loc tok - | CPatRecord rcl -> - xmlApply ?loc - (xmlOperator ?loc "record" :: - List.map (fun (r, cpe) -> - Element ("field", - ["reference", Libnames.string_of_reference r], - [pp_cases_pattern_expr cpe])) - rcl) - | CPatDelimiters (delim, cpe) -> - xmlApply ?loc - (xmlOperator ?loc "delimiter" ~attr:["name", delim] :: - [pp_cases_pattern_expr cpe]) - | CPatCast _ -> assert false -and pp_case_expr (e, name, pat) = - match name, pat with - | None, None -> xmlScrutinee [pp_expr e] - | Some (loc, name), None -> - let start, stop= unlock ?loc in - xmlScrutinee ~attr:["name", string_of_name name; - "begin", start; "end", stop] [pp_expr e] - | Some (loc, name), Some p -> - let start, stop= unlock ?loc in - xmlScrutinee ~attr:["name", string_of_name name; - "begin", start; "end", stop] - [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] - | None, Some p -> - xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] -and pp_branch_expr_list bel = - xmlWith - (List.map - (fun (_, (cpel, e)) -> - let ppcepl = - List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in - let ppe = [pp_expr e] in - xmlCase (ppcepl @ ppe)) - bel) -and pp_token ?loc tok = - let tokstr = - match tok with - | String s -> PCData s - | Numeral n -> PCData (to_string n) in - xmlToken ?loc [tokstr] -and pp_local_binder_list lbl = - let l = (List.map pp_local_binder lbl) in - Element ("recurse", (backstep_loc l), l) -and pp_const_expr_list cel = - let l = List.map pp_expr cel in - Element ("recurse", (backstep_loc l), l) -and pp_expr ?(attr=[]) { loc; CAst.v = e } = - match e with - | CRef (r, _) -> - xmlCst ?loc:(Libnames.loc_of_reference r) ~attr (Libnames.string_of_reference r) - | CProdN (bl, e) -> - xmlApply ?loc - (xmlOperator ?loc "forall" :: [pp_bindlist bl] @ [pp_expr e]) - | CApp ((_, hd), args) -> - xmlApply ?loc ~attr (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args) - | CAppExpl ((_, r, _), args) -> - xmlApply ?loc ~attr - (xmlCst ?loc:(Libnames.loc_of_reference r) (Libnames.string_of_reference r) - :: List.map pp_expr args) - | CNotation (notation, ([],[],[])) -> - xmlOperator ?loc notation - | CNotation (notation, (args, cell, lbll)) -> - let fmts = Notation.find_notation_extra_printing_rules notation in - let oper = xmlOperator ?loc notation ~pprules:fmts in - let cels = List.map pp_const_expr_list cell in - let lbls = List.map pp_local_binder_list lbll in - let args = List.map pp_expr args in - xmlApply ?loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls))) - | CSort(s) -> - xmlOperator ?loc (string_of_glob_sort s) - | CDelimiters (scope, ce) -> - xmlApply ?loc (xmlOperator ?loc "delimiter" ~attr:["name", scope] :: - [pp_expr ce]) - | CPrim tok -> pp_token ?loc tok - | CGeneralization (kind, _, e) -> - let kind= match kind with - | Explicit -> "explicit" - | Implicit -> "implicit" in - xmlApply ?loc - (xmlOperator ?loc ~attr:["kind", kind] "generalization" :: [pp_expr e]) - | CCast (e, tc) -> - begin match tc with - | CastConv t | CastVM t |CastNative t -> - xmlApply ?loc - (xmlOperator ?loc ":" ~attr:["kind", (string_of_cast_sort tc)] :: - [pp_expr e; pp_expr t]) - | CastCoerce -> - xmlApply ?loc - (xmlOperator ?loc ":" ~attr:["kind", "CastCoerce"] :: - [pp_expr e]) - end - | CEvar (ek, cel) -> - let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in - xmlApply ?loc - (xmlOperator ?loc "evar" ~attr:["id", string_of_id ek] :: - ppcel) - | CPatVar id -> xmlPatvar ?loc (string_of_id id) - | CHole (_, _, _) -> xmlCst ?loc ~attr "_" - | CIf (test, (_, ret), th, el) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc "if" :: - return @ [pp_expr th] @ [pp_expr el]) - | CLetTuple (names, (_, ret), value, body) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc "lettuple" :: - return @ - (List.map (fun (loc, var) -> xmlCst ?loc (string_of_name var)) names) @ - [pp_expr value; pp_expr body]) - | CCases (sty, ret, cel, bel) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc ~attr:["style", (string_of_case_style sty)] "match" :: - (return @ - [Element ("scrutinees", [], List.map pp_case_expr cel)] @ - [pp_branch_expr_list bel])) - | CRecord _ -> assert false - | CLetIn ((varloc, var), value, typ, body) -> - let value = match typ with - | Some t -> - CAst.make ?loc:(Loc.merge_opt (constr_loc value) (constr_loc t)) (CCast (value, CastConv t)) - | None -> value in - xmlApply ?loc - (xmlOperator ?loc "let" :: - [xmlCst ?loc:varloc (string_of_name var) ; pp_expr value; pp_expr body]) - | CLambdaN (bl, e) -> - xmlApply ?loc - (xmlOperator ?loc "lambda" :: [pp_bindlist bl] @ [pp_expr e]) - | CCoFix (_, _) -> assert false - | CFix (lid, fel) -> - xmlApply ?loc - (xmlOperator ?loc "fix" :: - List.flatten (List.map - (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) - fel)) - -let pp_comment c = - match c with - | CommentConstr e -> [pp_expr e] - | CommentString s -> [Element ("string", [], [PCData s])] - | CommentInt i -> [PCData (string_of_int i)] - -let rec tmpp ?loc v = - match v with - (* Control *) - | VernacLoad (verbose,f) -> - xmlWithLoc ?loc "load" ["verbose",string_of_bool verbose;"file",f] [] - | VernacTime (loc,e) -> - xmlApply ?loc (Element("time",[],[]) :: - [tmpp ?loc e]) - | VernacRedirect (s, (loc,e)) -> - xmlApply ?loc (Element("redirect",["path", s],[]) :: - [tmpp ?loc e]) - | VernacTimeout (s,e) -> - xmlApply ?loc (Element("timeout",["val",string_of_int s],[]) :: - [tmpp ?loc e]) - | VernacFail e -> xmlApply ?loc (Element("fail",[],[]) :: [tmpp ?loc e]) - - (* Syntax *) - | VernacSyntaxExtension (_, ((_, name), sml)) -> - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - xmlReservedNotation ?loc attrs name - - | VernacOpenCloseScope (_,(true,name)) -> xmlScope ?loc "open" name [] - | VernacOpenCloseScope (_,(false,name)) -> xmlScope ?loc "close" name [] - | VernacDelimiters (name,Some tag) -> - xmlScope ?loc "delimit" name ~attr:["delimiter",tag] [] - | VernacDelimiters (name,None) -> - xmlScope ?loc "undelimit" name ~attr:[] [] - | VernacInfix (_,((_,name),sml),ce,sn) -> - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - let sc_attr = - match sn with - | Some scope -> ["scope", scope] - | None -> [] in - xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] - | VernacNotation (_, ce, (lstr, sml), sn) -> - let name = snd lstr in - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - let sc_attr = - match sn with - | Some scope -> ["scope", scope] - | None -> [] in - xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] - | VernacBindScope _ as x -> xmlTODO ?loc x - | VernacNotationAddFormat _ as x -> xmlTODO ?loc x - | VernacUniverse _ - | VernacConstraint _ - | VernacPolymorphic (_, _) as x -> xmlTODO ?loc x - (* Gallina *) - | VernacDefinition (ldk, ((_,id),_), de) -> - let l, dk = - match ldk with - | Some l, dk -> (l, dk) - | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *) - let e = - match de with - | ProveBody (_, ce) -> ce - | DefineBody (_, Some _, ce, None) -> ce - | DefineBody (_, None , ce, None) -> ce - | DefineBody (_, Some _, ce, Some _) -> ce - | DefineBody (_, None , ce, Some _) -> ce in - let str_dk = Kindops.string_of_definition_kind (l, false, dk) in - let str_id = Id.to_string id in - (xmlDef ?loc str_dk str_id [pp_expr e]) - | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> - let str_tk = Kindops.string_of_theorem_kind tk in - let str_id = Id.to_string id in - (xmlThm ?loc str_tk str_id [pp_expr statement]) - | VernacStartTheoremProof _ as x -> xmlTODO ?loc x - | VernacEndProof pe -> - begin - match pe with - | Admitted -> xmlQed ?loc ?attr:None - | Proved (_, Some ((_, id), Some tk)) -> - let nam = Id.to_string id in - let typ = Kindops.string_of_theorem_kind tk in - xmlQed ?loc ~attr:["name", nam; "type", typ] - | Proved (_, Some ((_, id), None)) -> - let nam = Id.to_string id in - xmlQed ?loc ~attr:["name", nam] - | Proved _ -> xmlQed ?loc ?attr:None - end - | VernacExactProof _ as x -> xmlTODO ?loc x - | VernacAssumption ((l, a), _, sbwcl) -> - let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in - let many = - List.length (List.flatten (List.map fst binders)) > 1 in - let exprs = - List.flatten (List.map pp_simple_binder binders) in - let l = match l with Some x -> x | None -> Decl_kinds.Global in - let kind = string_of_assumption_kind l a many in - xmlAssumption ?loc kind exprs - | VernacInductive (_, _, _, iednll) -> - let kind = - let (_, _, _, k, _), _ = List.hd iednll in - begin - match k with - | Record -> "Record" - | Structure -> "Structure" - | Inductive_kw -> "Inductive" - | CoInductive -> "CoInductive" - | Class _ -> "Class" - | Variant -> "Variant" - end in - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (ie, dnl) -> (pp_inductive_expr ie) @ - (List.map pp_decl_notation dnl)) iednll) in - xmlInductive ?loc kind exprs - | VernacFixpoint (_, fednll) -> - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (fe, dnl) -> (pp_fixpoint_expr fe) @ - (List.map pp_decl_notation dnl)) fednll) in - xmlFixpoint exprs - | VernacCoFixpoint (_, cfednll) -> - (* Nota: it is like VernacFixpoint without so could be merged *) - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @ - (List.map pp_decl_notation dnl)) cfednll) in - xmlCoFixpoint exprs - | VernacScheme _ as x -> xmlTODO ?loc x - | VernacCombinedScheme _ as x -> xmlTODO ?loc x - - (* Gallina extensions *) - | VernacBeginSection (_, id) -> xmlBeginSection ?loc (Id.to_string id) - | VernacEndSegment (_, id) -> xmlEndSegment ?loc (Id.to_string id) - | VernacNameSectionHypSet _ as x -> xmlTODO ?loc x - | VernacRequire (from, import, l) -> - let import = match import with - | None -> [] - | Some true -> ["export","true"] - | Some false -> ["import","true"] - in - let from = match from with - | None -> [] - | Some r -> ["from", Libnames.string_of_reference r] - in - xmlRequire ?loc ~attr:(from @ import) (List.map (fun ref -> - xmlReference ref) l) - | VernacImport (true,l) -> - xmlImport ?loc ~attr:["export","true"] (List.map (fun ref -> - xmlReference ref) l) - | VernacImport (false,l) -> - xmlImport ?loc (List.map (fun ref -> xmlReference ref) l) - | VernacCanonical r -> - let attr = - match r with - | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q] - | AN (Ident (_, id)) -> ["id", Id.to_string id] - | ByNotation (_, (s, _)) -> ["notation", s] in - xmlCanonicalStructure ?loc attr - | VernacCoercion _ as x -> xmlTODO ?loc x - | VernacIdentityCoercion _ as x -> xmlTODO ?loc x - - (* Type classes *) - | VernacInstance _ as x -> xmlTODO ?loc x - - | VernacContext _ as x -> xmlTODO ?loc x - - | VernacDeclareInstances _ as x -> xmlTODO ?loc x - - | VernacDeclareClass _ as x -> xmlTODO ?loc x - - (* Modules and Module Types *) - | VernacDeclareModule _ as x -> xmlTODO ?loc x - | VernacDefineModule _ as x -> xmlTODO ?loc x - | VernacDeclareModuleType _ as x -> xmlTODO ?loc x - | VernacInclude _ as x -> xmlTODO ?loc x - - (* Solving *) - - | (VernacSolveExistential _) as x -> - xmlLtac ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - - (* Auxiliary file and library management *) - | VernacAddLoadPath (recf,name,None) -> - xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] - | VernacAddLoadPath (recf,name,Some dp) -> - xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] - [PCData (Names.DirPath.to_string dp)] - | VernacRemoveLoadPath name -> xmlRemoveLoadPath ?loc ~attr:["path",name] [] - | VernacAddMLPath (recf,name) -> - xmlAddMLPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] - | VernacDeclareMLModule sl -> xmlDeclareMLModule ?loc sl - | VernacChdir _ as x -> xmlTODO ?loc x - - (* State management *) - | VernacWriteState _ as x -> xmlTODO ?loc x - | VernacRestoreState _ as x -> xmlTODO ?loc x - - (* Resetting *) - | VernacResetName _ as x -> xmlTODO ?loc x - | VernacResetInitial as x -> xmlTODO ?loc x - | VernacBack _ as x -> xmlTODO ?loc x - | VernacBackTo _ -> PCData "VernacBackTo" - - (* Commands *) - | VernacCreateHintDb _ as x -> xmlTODO ?loc x - | VernacRemoveHints _ as x -> xmlTODO ?loc x - | VernacHints _ as x -> xmlTODO ?loc x - | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) -> - let name = Id.to_string name in - let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in - xmlNotation ?loc attrs name [pp_expr ce] - | VernacDeclareImplicits _ as x -> xmlTODO ?loc x - | VernacArguments _ as x -> xmlTODO ?loc x - | VernacArgumentsScope _ as x -> xmlTODO ?loc x - | VernacReserve _ as x -> xmlTODO ?loc x - | VernacGeneralizable _ as x -> xmlTODO ?loc x - | VernacSetOpacity _ as x -> xmlTODO ?loc x - | VernacSetStrategy _ as x -> xmlTODO ?loc x - | VernacUnsetOption _ as x -> xmlTODO ?loc x - | VernacSetOption _ as x -> xmlTODO ?loc x - | VernacSetAppendOption _ as x -> xmlTODO ?loc x - | VernacAddOption _ as x -> xmlTODO ?loc x - | VernacRemoveOption _ as x -> xmlTODO ?loc x - | VernacMemOption _ as x -> xmlTODO ?loc x - | VernacPrintOption _ as x -> xmlTODO ?loc x - | VernacCheckMayEval (_,_,e) -> xmlCheck ?loc [pp_expr e] - | VernacGlobalCheck _ as x -> xmlTODO ?loc x - | VernacDeclareReduction _ as x -> xmlTODO ?loc x - | VernacPrint _ as x -> xmlTODO ?loc x - | VernacSearch _ as x -> xmlTODO ?loc x - | VernacLocate _ as x -> xmlTODO ?loc x - | VernacRegister _ as x -> xmlTODO ?loc x - | VernacComments (cl) -> - xmlComment ?loc (List.flatten (List.map pp_comment cl)) - - (* Stm backdoor *) - | VernacStm _ as x -> xmlTODO ?loc x - - (* Proof management *) - | VernacGoal _ as x -> xmlTODO ?loc x - | VernacAbort _ as x -> xmlTODO ?loc x - | VernacAbortAll -> PCData "VernacAbortAll" - | VernacRestart as x -> xmlTODO ?loc x - | VernacUndo _ as x -> xmlTODO ?loc x - | VernacUndoTo _ as x -> xmlTODO ?loc x - | VernacBacktrack _ as x -> xmlTODO ?loc x - | VernacFocus _ as x -> xmlTODO ?loc x - | VernacUnfocus as x -> xmlTODO ?loc x - | VernacUnfocused as x -> xmlTODO ?loc x - | VernacBullet _ as x -> xmlTODO ?loc x - | VernacSubproof _ as x -> xmlTODO ?loc x - | VernacEndSubproof as x -> xmlTODO ?loc x - | VernacShow _ as x -> xmlTODO ?loc x - | VernacCheckGuard as x -> xmlTODO ?loc x - | VernacProof (tac,using) -> - let tac = None (** FIXME *) in - let using = Option.map (xmlSectionSubsetDescr "using") using in - xmlProof ?loc (Option.List.(cons tac (cons using []))) - | VernacProofMode name -> xmlProofMode ?loc name - - (* Toplevel control *) - | VernacToplevelControl _ as x -> xmlTODO ?loc x - - (* For extension *) - | VernacExtend _ as x -> - xmlExtend ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - - (* Flags *) - | VernacProgram e -> xmlApply ?loc (Element("program",[],[]) :: [tmpp ?loc e]) - | VernacLocal (b,e) -> - xmlApply ?loc (Element("local",["flag",string_of_bool b],[]) :: - [tmpp ?loc e]) - -let tmpp ?loc v = - match tmpp ?loc v with - | Element("ltac",_,_) as x -> x - | xml -> xmlGallina ?loc [xml] diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 7c12f9df5..31ec44470 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -331,7 +331,7 @@ type vernac_expr = (* Gallina *) | VernacDefinition of (locality option * definition_object_kind) * plident * definition_expr - | VernacStartTheoremProof of theorem_kind * proof_expr list * bool + | VernacStartTheoremProof of theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index dbd2fc401..fe8f517a7 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -151,7 +151,7 @@ GEXTEND Gram l = LIST0 [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c)) ] -> - VernacStartTheoremProof (thm, (Some id,(bl,c))::l, false) + VernacStartTheoremProof (thm, (Some id,(bl,c))::l) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index ad04e430c..35f092958 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -576,50 +576,44 @@ let map_option f = function | Some v -> Some (f v) open Constrexpr -open Topconstr -let make_assoc assoc l1 l2 = - let fold assoc a b = match a, b with - | (_, Name na), (_, Name id) -> Id.Map.add na id assoc - | _, _ -> assoc - in - List.fold_left2 fold assoc l1 l2 - -let rec rebuild_bl (aux,assoc) bl typ = - match bl,typ with - | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) - | (Constrexpr.CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Constrexpr.CLocalDef(na,_,_))::bl',{ CAst.v = Constrexpr.CLetIn(_,nat,ty,typ') } -> - rebuild_bl ((Constrexpr.CLocalDef(na,replace_vars_constr_expr assoc nat,Option.map (replace_vars_constr_expr assoc) ty (* ??? *))::aux),assoc) +let rec rebuild_bl aux bl typ = + match bl,typ with + | [], _ -> List.rev aux,typ + | (CLocalAssum(nal,bk,_))::bl',typ -> + rebuild_nal aux bk bl' nal typ + | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> + rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) bl' typ' | _ -> assert false - and rebuild_nal (aux,assoc) bk bl' nal lnal typ = - match nal, typ.CAst.v with - | [], _ -> rebuild_bl (aux,assoc) bl' typ - | _,CProdN([],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ - | _,CProdN((nal',bk',nal't)::rest,typ') -> - let lnal' = List.length nal' in - if lnal' >= lnal - then - let old_nal',new_nal' = List.chop lnal nal' in - let nassoc = make_assoc assoc old_nal' nal in - let assum = CLocalAssum(nal,bk,replace_vars_constr_expr assoc nal't) in - rebuild_bl ((assum :: aux), nassoc) bl' - (if List.is_empty new_nal' && List.is_empty rest - then typ' - else CAst.make @@ if List.is_empty new_nal' - then CProdN(rest,typ') - else CProdN(((new_nal',bk',nal't)::rest),typ')) - else - let captured_nal,non_captured_nal = List.chop lnal' nal in - let nassoc = make_assoc assoc nal' captured_nal in - let assum = CLocalAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in - rebuild_nal ((assum :: aux), nassoc) - bk bl' non_captured_nal (lnal - lnal') (CAst.make @@ CProdN(rest,typ')) - | _ -> assert false - -let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ +and rebuild_nal aux bk bl' nal typ = + match nal,typ with + | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + | [], _ -> rebuild_bl aux bl' typ + | na::nal,{ CAst.v = CProdN((na'::nal',bk',nal't)::rest,typ') } -> + if Name.equal (snd na) (snd na') || Name.is_anonymous (snd na') + then + let assum = CLocalAssum([na],bk',nal't) in + let new_rest = if nal' = [] then rest else ((nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + nal + (CAst.make @@ CProdN(new_rest,typ')) + else + let assum = CLocalAssum([na'],bk',nal't) in + let new_rest = if nal' = [] then rest else ((nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + (na::nal) + (CAst.make @@ CProdN(new_rest,typ')) + | _ -> + assert false + +let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in @@ -629,7 +623,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> - let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in + let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 07b8746fb..50013f558 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -17,7 +17,7 @@ open Stdarg open Extraargs open Names -DECLARE PLUGIN "coretactics" +DECLARE PLUGIN "ltac_plugin" (** Basic tactics *) @@ -324,11 +324,11 @@ let initial_atomic () = "fresh", TacArg(Loc.tag @@ TacFreshId []) ] -let () = Mltop.declare_cache_obj initial_atomic "coretactics" +let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" (* First-class Ltac access to primitive blocks *) -let initial_name s = { mltac_plugin = "coretactics"; mltac_tactic = s; } +let initial_name s = { mltac_plugin = "ltac_plugin"; mltac_tactic = s; } let initial_entry s = { mltac_name = initial_name s; mltac_index = 0; } let register_list_tactical name f = @@ -356,4 +356,4 @@ let initial_tacticals () = "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); ] -let () = Mltop.declare_cache_obj initial_tacticals "coretactics" +let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 7259faecd..36df25cc7 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -28,7 +28,7 @@ open Equality open Misctypes open Proofview.Notations -DECLARE PLUGIN "extratactics" +DECLARE PLUGIN "ltac_plugin" (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index dfd8e88a9..6145e373b 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -18,7 +18,7 @@ open Pcoq.Constr open Pltac open Hints -DECLARE PLUGIN "g_auto" +DECLARE PLUGIN "ltac_plugin" (* Hint bases *) diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index 905cfd02a..63451210c 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -13,7 +13,7 @@ open Class_tactics open Stdarg open Tacarg -DECLARE PLUGIN "g_class" +DECLARE PLUGIN "ltac_plugin" (** Options: depth, debug and transparency settings. *) diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 index 570cd4e69..dceefeaa1 100644 --- a/plugins/ltac/g_eqdecide.ml4 +++ b/plugins/ltac/g_eqdecide.ml4 @@ -17,7 +17,7 @@ open API open Eqdecide -DECLARE PLUGIN "g_eqdecide" +DECLARE PLUGIN "ltac_plugin" TACTIC EXTEND decide_equality | [ "decide" "equality" ] -> [ decideEqualityGoal ] diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index e6ddc5cc1..3e6f42006 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -27,7 +27,7 @@ open Pcoq.Prim open Pcoq.Constr open Pltac -DECLARE PLUGIN "g_rewrite" +DECLARE PLUGIN "ltac_plugin" type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index af1c7149d..12b4c81fc 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -21,7 +21,6 @@ G_auto G_class Rewrite G_rewrite -Tauto G_eqdecide G_tactic G_ltac diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 2a8ed7238..71f7082e7 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -13,13 +13,14 @@ open Hipattern open Names open Geninterp open Misctypes +open Ltac_plugin open Tacexpr open Tacinterp open Util open Tacticals.New open Proofview.Notations -let tauto_plugin = "tauto" +let tauto_plugin = "tauto_plugin" let () = Mltop.add_known_module tauto_plugin let assoc_var s ist = diff --git a/plugins/ltac/tauto_plugin.mlpack b/plugins/ltac/tauto_plugin.mlpack new file mode 100644 index 000000000..b3618018e --- /dev/null +++ b/plugins/ltac/tauto_plugin.mlpack @@ -0,0 +1 @@ +Tauto diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4a5cfe630..d0536a174 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -698,7 +698,7 @@ open Decl_kinds | Some cc -> str" :=" ++ spc() ++ cc)) ) - | VernacStartTheoremProof (ki,l,_) -> + | VernacStartTheoremProof (ki,l) -> return ( hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ prlist (pr_statement (spc () ++ keyword "with")) (List.tl l)) diff --git a/stm/stm.ml b/stm/stm.ml index a7ed84350..01edc9d2d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -476,7 +476,7 @@ end = struct (* {{{ *) let mk_branch_name { expr = x } = Branch.make (let rec aux x = match x with | VernacDefinition (_,((_,i),_),_) -> Names.string_of_id i - | VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> Names.string_of_id i + | VernacStartTheoremProof (_,[Some ((_,i),_),_]) -> Names.string_of_id i | VernacTime (_, e) | VernacTimeout (_, e) -> aux e | _ -> "branch" in aux x) @@ -1672,7 +1672,7 @@ end (* }}} *) and TacTask : sig - type output = Constr.constr * Evd.evar_universe_context + type output = (Constr.constr * Evd.evar_universe_context) option type task = { t_state : Stateid.t; t_state_fb : Stateid.t; @@ -1681,13 +1681,12 @@ and TacTask : sig t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } - exception NoProgress include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) - type output = Constr.constr * Evd.evar_universe_context + type output = (Constr.constr * Evd.evar_universe_context) option let forward_feedback msg = Hooks.(call forward_feedback msg) @@ -1709,10 +1708,9 @@ end = struct (* {{{ *) r_name : string } type response = - | RespBuiltSubProof of output + | RespBuiltSubProof of (Constr.constr * Evd.evar_universe_context) | RespError of Pp.std_ppcmds | RespNoProgress - exception NoProgress let name = ref "tacworker" let extra_env () = [||] @@ -1734,10 +1732,9 @@ end = struct (* {{{ *) let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp = match resp with - | RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[]) + | RespBuiltSubProof o -> t_assign (`Val (Some o)); `Stay ((),[]) | RespNoProgress -> - let e = (NoProgress, Exninfo.null) in - t_assign (`Exn e); + t_assign (`Val None); t_kill (); `Stay ((),[]) | RespError msg -> @@ -1848,8 +1845,8 @@ end = struct (* {{{ *) else tclUNIT () else let open Notations in - try - let pt, uc = Future.join f in + match Future.join f with + | Some (pt, uc) -> stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ @@ -1857,7 +1854,7 @@ end = struct (* {{{ *) (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> Tactics.exact_no_check (EConstr.of_constr pt)) - with TacTask.NoProgress -> + | None -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () end) in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 1234e15af..50e68852f 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -115,7 +115,7 @@ let rec classify_vernac e = VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater - | VernacStartTheoremProof (_,l,_) -> + | VernacStartTheoremProof (_,l) -> let ids = CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 73709268a..33e5d532a 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -39,7 +39,6 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) p = q. Declare ML Module "ltac_plugin". -Declare ML Module "coretactics". Set Default Proof Mode "Classic". diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index 179f81e66..a664a1ef1 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -3,7 +3,6 @@ (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) Declare ML Module "ltac_plugin". -Declare ML Module "coretactics". Set Default Proof Mode "Classic". Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). @@ -14,7 +13,6 @@ Axiom admit : forall {T}, T. Notation "A -> B" := (forall (_ : A), B) : type_scope. Reserved Infix "o" (at level 40, left associativity). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. -Ltac constr_eq a b := let test := constr:(@idpath _ _ : a = b) in idtac. Global Set Primitive Projections. Delimit Scope morphism_scope with morphism. Record PreCategory := diff --git a/test-suite/bugs/closed/4250.v b/test-suite/bugs/closed/4250.v new file mode 100644 index 000000000..74cacf559 --- /dev/null +++ b/test-suite/bugs/closed/4250.v @@ -0,0 +1,11 @@ +Require Import FunInd. +Require Vector. +Generalizable All Variables. + +Definition f `{n:nat , u:Vector.t A n} := n. + +Function f2 {A:Type} {n:nat} {v:Vector.t A n} : nat := n. + +(* fails with "The reference A was not found in the current environment." *) +Function f3 `{n:nat , u:Vector.t A n} := u. +Check R_f3_complete.
\ No newline at end of file diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index edcd53005..2b0fe1362 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -89,11 +89,5 @@ Open Scope type_scope. (** ML Tactic Notations *) Declare ML Module "ltac_plugin". -Declare ML Module "coretactics". -Declare ML Module "extratactics". -Declare ML Module "g_auto". -Declare ML Module "g_class". -Declare ML Module "g_eqdecide". -Declare ML Module "g_rewrite". Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 1e409607a..886533586 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -2,7 +2,7 @@ Require Import Notations. Require Import Datatypes. Require Import Logic. -Local Declare ML Module "tauto". +Declare ML Module "tauto_plugin". Local Ltac not_dep_intros := repeat match goal with diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index c68c34bbb..9224cdafe 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -74,7 +74,9 @@ let dot = '.' ( space+ | eof) rule coq_action = parse | "Require" space+ { require_modifiers None lexbuf } - | "Local"? "Declare" space+ "ML" space+ "Module" space+ + | "Local" space+ "Declare" space+ "ML" space+ "Module" space+ + { modules [] lexbuf } + | "Declare" space+ "ML" space+ "Module" space+ { modules [] lexbuf } | "Load" space+ { load_file lexbuf } diff --git a/vernac/classes.ml b/vernac/classes.ml index 007b70bc0..2e8ebb853 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -417,7 +417,7 @@ let context poly l = let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~poly ~univs:ctx ~types:t b in let hook = Lemmas.mk_hook (fun _ gr -> gr) in - let _ = Command.declare_definition id decl entry [] [] hook in + let _ = DeclareDef.declare_definition id decl entry [] [] hook in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/command.ml b/vernac/command.ml index 406477356..fd49e5324 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -145,59 +145,6 @@ let check_definition (ce, evd, _, imps) = check_evars_are_solved (Global.env ()) evd Evd.empty; ce -let warn_local_declaration = - CWarnings.create ~name:"local-declaration" ~category:"scope" - (fun (id,kind) -> - pr_id id ++ strbrk " is declared as a local " ++ str kind) - -let get_locality id ~kind = function -| Discharge -> - (** If a Let is defined outside a section, then we consider it as a local definition *) - warn_local_declaration (id,kind); - true -| Local -> true -| Global -> false - -let declare_global_definition ident ce local k pl imps = - let local = get_locality ident ~kind:"definition" local in - let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in - let gr = ConstRef kn in - let () = maybe_declare_manual_implicits false gr imps in - let () = Universes.register_universe_binders gr pl in - let () = definition_message ident in - gr - -let declare_definition_hook = ref ignore -let set_declare_definition_hook = (:=) declare_definition_hook -let get_declare_definition_hook () = !declare_definition_hook - -let warn_definition_not_visible = - CWarnings.create ~name:"definition-not-visible" ~category:"implicits" - (fun ident -> - strbrk "Section definition " ++ - pr_id ident ++ strbrk " is not visible from current goals") - -let declare_definition ident (local, p, k) ce pl imps hook = - let fix_exn = Future.fix_exn_of ce.const_entry_body in - let () = !declare_definition_hook ce in - let r = match local with - | Discharge when Lib.sections_are_opened () -> - let c = SectionLocalDef ce in - let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in - let () = definition_message ident in - let gr = VarRef ident in - let () = maybe_declare_manual_implicits false gr imps in - let () = if Proof_global.there_are_pending_proofs () then - warn_definition_not_visible ident - in - gr - | Discharge | Local | Global -> - declare_global_definition ident ce local k pl imps in - Lemmas.call_hook fix_exn hook local r - -let _ = Obligations.declare_definition_ref := - (fun i k c imps hook -> declare_definition i k c [] imps hook) - let do_definition ident k pl bl red_option c ctypopt hook = let (ce, evd, pl', imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt @@ -220,7 +167,7 @@ let do_definition ident k pl bl red_option c ctypopt hook = ignore(Obligations.add_definition ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(declare_definition ident k ce pl' imps + ignore(DeclareDef.declare_definition ident k ce pl' imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) @@ -243,7 +190,7 @@ match local with (r,Univ.Instance.empty,true) | Global | Local | Discharge -> - let local = get_locality ident ~kind:"axiom" local in + let local = DeclareDef.get_locality ident ~kind:"axiom" local in let inl = match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) @@ -876,13 +823,6 @@ let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx -let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps = - let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in - declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r)) - -let _ = Obligations.declare_fix_ref := - (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps) - let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in let names = List.map (fun id -> Name id) fixnames in @@ -1226,7 +1166,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind let evd = Evd.restrict_universe_context evd vars in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let pl, ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (declare_fix (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; @@ -1257,7 +1197,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in let pl, ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (declare_fix (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames diff --git a/vernac/command.mli b/vernac/command.mli index a636bc03c..1887885de 100644 --- a/vernac/command.mli +++ b/vernac/command.mli @@ -23,11 +23,6 @@ val do_universe : polymorphic -> Id.t Loc.located list -> unit val do_constraint : polymorphic -> (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit -(** {6 Hooks for Pcoq} *) - -val set_declare_definition_hook : (Safe_typing.private_constants definition_entry -> unit) -> unit -val get_declare_definition_hook : unit -> (Safe_typing.private_constants definition_entry -> unit) - (** {6 Definitions/Let} *) val interp_definition : @@ -35,10 +30,6 @@ val interp_definition : constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * Universes.universe_binders * Impargs.manual_implicits -val declare_definition : Id.t -> definition_kind -> - Safe_typing.private_constants definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> - Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference - val do_definition : Id.t -> definition_kind -> lident list option -> local_binder_expr list -> red_expr option -> constr_expr -> constr_expr option -> unit Lemmas.declaration_hook -> unit @@ -170,6 +161,3 @@ val do_cofixpoint : (** Utils *) val check_mutuality : Environ.env -> Evd.evar_map -> bool -> (Id.t * types) list -> unit - -val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t -> - Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml new file mode 100644 index 000000000..d7a4fcca3 --- /dev/null +++ b/vernac/declareDef.ml @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Decl_kinds +open Declare +open Entries +open Globnames +open Impargs +open Nameops + +let warn_definition_not_visible = + CWarnings.create ~name:"definition-not-visible" ~category:"implicits" + Pp.(fun ident -> + strbrk "Section definition " ++ + pr_id ident ++ strbrk " is not visible from current goals") + +let warn_local_declaration = + CWarnings.create ~name:"local-declaration" ~category:"scope" + Pp.(fun (id,kind) -> + pr_id id ++ strbrk " is declared as a local " ++ str kind) + +let get_locality id ~kind = function +| Discharge -> + (** If a Let is defined outside a section, then we consider it as a local definition *) + warn_local_declaration (id,kind); + true +| Local -> true +| Global -> false + +let declare_global_definition ident ce local k pl imps = + let local = get_locality ident ~kind:"definition" local in + let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in + let gr = ConstRef kn in + let () = maybe_declare_manual_implicits false gr imps in + let () = Universes.register_universe_binders gr pl in + let () = definition_message ident in + gr + +let declare_definition ident (local, p, k) ce pl imps hook = + let fix_exn = Future.fix_exn_of ce.const_entry_body in + let r = match local with + | Discharge when Lib.sections_are_opened () -> + let c = SectionLocalDef ce in + let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in + let () = definition_message ident in + let gr = VarRef ident in + let () = maybe_declare_manual_implicits false gr imps in + let () = if Proof_global.there_are_pending_proofs () then + warn_definition_not_visible ident + in + gr + | Discharge | Local | Global -> + declare_global_definition ident ce local k pl imps in + Lemmas.call_hook fix_exn hook local r + +let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps = + let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in + declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r)) + diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli new file mode 100644 index 000000000..5dea0ba27 --- /dev/null +++ b/vernac/declareDef.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Decl_kinds +open Names + +val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool + +val declare_definition : Id.t -> definition_kind -> + Safe_typing.private_constants Entries.definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> + Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference + +val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t -> + Safe_typing.private_constants Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> Globnames.global_reference diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 135e4c63a..c0acdaf57 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -22,9 +22,6 @@ open Util module NamedDecl = Context.Named.Declaration -let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) -let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) - let get_fix_exn, stm_get_fix_exn = Hook.make () let succfix (depth, fixrels) = @@ -496,14 +493,12 @@ let declare_definition prg = in let () = progmap_remove prg in let cst = - !declare_definition_ref prg.prg_name - prg.prg_kind ce prg.prg_implicits + DeclareDef.declare_definition prg.prg_name + prg.prg_kind ce [] prg.prg_implicits (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) in Universes.register_universe_binders cst pl; cst - -open Pp let rec lam_index n t acc = match kind_of_term t with @@ -569,7 +564,7 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) [] ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index a276f9f9a..9cbbf6082 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -12,23 +12,12 @@ open Evd open Names open Pp open Globnames -open Decl_kinds - -(** Forward declaration. *) -val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> - Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref - -val declare_definition_ref : - (Id.t -> definition_kind -> - Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits - -> global_reference Lemmas.declaration_hook -> global_reference) ref (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof * is not available here, so we provide a side channel to get it *) val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) Hook.t - val check_evars : env -> evar_map -> unit val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index d631fae8a..f74073e1f 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -8,6 +8,7 @@ Metasyntax Auto_ind_decl Search Indschemes +DeclareDef Obligations Command Classes diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 21f053fb9..acd218536 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -490,17 +490,13 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = Some (snd (Hook.get f_interp_redexp env evc r)) in do_definition id (local,p,k) pl bl red_option c typ_opt hook) -let vernac_start_proof locality p kind l lettop = +let vernac_start_proof locality p kind l = let local = enforce_locality_exp locality None in if Dumpglob.dump () then List.iter (fun (id, _) -> match id with | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; - if not(Proof_global.there_are_pending_proofs ()) then - if lettop then - user_err ~hdr:"Vernacentries.StartProof" - (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (local, p, Proof kind) l no_hook let vernac_end_proof ?proof = function @@ -1937,7 +1933,7 @@ let interp ?proof ?loc locality poly c = (* Gallina *) | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | VernacStartTheoremProof (k,l,top) -> vernac_start_proof locality poly k l top + | VernacStartTheoremProof (k,l) -> vernac_start_proof locality poly k l | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl @@ -2025,7 +2021,7 @@ let interp ?proof ?loc locality poly c = | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) - | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] false + | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () |