diff options
147 files changed, 1493 insertions, 838 deletions
@@ -1,5 +1,5 @@ -Changes beyond V8.5 -=================== +Changes from V8.5 to V8.6beta1 +============================== Bugfixes @@ -14,6 +14,9 @@ Bugfixes binders made more robust. - #4780: Induction with universe polymorphism on was creating ill-typed terms. - #3070: fixing "subst" in the presence of a chain of dependencies. +- When used as an argument of an ltac function, "auto" without "with" + nor "using" clause now correctly uses only the core hint database by + default. Specification language @@ -69,6 +72,9 @@ Tactics hypotheses of the form "~True" or "t<>t" (possible source of incompatibilities because of more successes in automation, but generally a more intuitive strategy). +- Option "Injection On Proofs" was renamed "Keep Proof Equalities". When + enabled, injection and inversion do not drop equalities between objects + in Prop. Still disabled by default. Hints @@ -97,6 +103,9 @@ Tools - Setting [Printing Dependent Evars Line] can be unset to disable the computation associated with printing the "dependent evars: " line in -emacs mode +- Removed the -verbose-compat-notations flag and the corresponding Set + Verbose Compat vernacular, since these warnings can now be silenced or + turned into errors using "-w". Changes from V8.5pl2 to V8.5pl3 =============================== diff --git a/checker/check.ml b/checker/check.ml index 863cf7b2cd..8b299bf2a2 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -11,6 +11,8 @@ open CErrors open Util open Names +let chk_pp = Pp.pp_with Format.std_formatter + let pr_dirpath dp = str (DirPath.to_string dp) let default_root_prefix = DirPath.empty let split_dirpath d = @@ -118,7 +120,6 @@ let check_one_lib admit (dir,m) = (Flags.if_verbose Feedback.msg_notice (str "Checking library: " ++ pr_dirpath dir); Safe_typing.import file md m.library_extra_univs dig); - Flags.if_verbose Feedback.msg_notice (fnl()); register_loaded_library m (*************************************************************************) @@ -298,7 +299,7 @@ let name_clash_message dir mdir f = let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = - Flags.if_verbose Feedback.msg_notice(str"[intern "++str f++str" ..."); + Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try let ch = System.with_magic_number_check raw_intern_library f in @@ -322,7 +323,7 @@ let intern_from_file (dir, f) = errorlabstrm "intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin - Feedback.msg_notice(str " (was a vio file) "); + chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then errorlabstrm "intern_from_file" (str "The file "++str f++str " is still a .vio")) @@ -333,12 +334,12 @@ let intern_from_file (dir, f) = Validate.validate !Flags.debug Values.v_libsum sd; Validate.validate !Flags.debug Values.v_lib md; Validate.validate !Flags.debug Values.v_opaques table; - Flags.if_verbose Feedback.msg_notice (str" done]"); + Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Cic.Dviovo (digest,udg) else (Cic.Dvo digest) in sd,md,table,opaque_csts,digest - with e -> Flags.if_verbose Feedback.msg_notice (str" failed!]"); raise e in + with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; opaque_tables := LibraryMap.add sd.md_name table !opaque_tables; Option.iter (fun (opaque_csts,_,_) -> diff --git a/checker/check_stat.ml b/checker/check_stat.ml index f196746a57..741f532848 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -57,8 +57,7 @@ let print_context env = (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_ax csts) ++ - fnl())); + str "* " ++ hov 0 (pr_ax csts))); end let stats () = diff --git a/checker/checker.ml b/checker/checker.ml index 503697b592..8dbb7e0119 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -16,6 +16,8 @@ open Check let () = at_exit flush_all +let chk_pp = Pp.pp_with Format.std_formatter + let fatal_error info anomaly = flush_all (); Feedback.msg_error info; flush_all (); exit (if anomaly then 129 else 1) @@ -283,7 +285,8 @@ let rec explain_exn = function Format.printf "@\nis not convertible with@\n"; Print.print_pure_constr a; Format.printf "@\n====== universes ====@\n"; - Feedback.msg_notice (Univ.pr_universes + chk_pp + (Univ.pr_universes (ctx.Environ.env_stratification.Environ.env_universes)); str "\nCantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" diff --git a/checker/print.ml b/checker/print.ml index c0d1ac3688..7ef752b002 100644 --- a/checker/print.ml +++ b/checker/print.ml @@ -10,7 +10,9 @@ open Format open Cic open Names -let print_instance i = Feedback.msg_notice (Univ.Instance.pr i) +let chk_pp = Pp.pp_with Format.std_formatter + +let print_instance i = chk_pp (Univ.Instance.pr i) let print_pure_constr csr = let rec term_display c = match c with @@ -108,7 +110,7 @@ let print_pure_constr csr = and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" - | Type u -> print_string "Type("; Feedback.msg_notice (Univ.pr_uni u); print_string ")" + | Type u -> print_string "Type("; chk_pp (Univ.pr_uni u); print_string ")" and name_display = function | Name id -> print_string (Id.to_string id) diff --git a/configure.ml b/configure.ml index 23ec93e078..507fd351a7 100644 --- a/configure.ml +++ b/configure.ml @@ -430,7 +430,7 @@ let dll = if os_type_win32 then ".dll" else ".so" let vcs = let git_dir = try Sys.getenv "GIT_DIR" with Not_found -> ".git" in - if dir_exists git_dir then "git" + if Sys.file_exists git_dir then "git" else if Sys.file_exists ".svn/entries" then "svn" else if dir_exists "{arch}" then "gnuarch" else "none" @@ -51,6 +51,7 @@ install_printer Top_printers.prsubst install_printer Top_printers.prdelta install_printer Top_printers.ppfconstr install_printer Top_printers.ppgenarginfo +install_printer Top_printers.ppgenargargt install_printer Top_printers.ppist install_printer Top_printers.ppconstrunderbindersidmap install_printer Top_printers.ppunbound_ltac_var_map diff --git a/dev/top_printers.ml b/dev/top_printers.ml index e09477014b..e34385e5c3 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -478,6 +478,8 @@ let prgenarginfo arg = let ppgenarginfo arg = pp (prgenarginfo arg) +let ppgenargargt arg = pp (str (Genarg.ArgT.repr arg)) + let ppist ist = let pr id arg = prgenarginfo arg in pp (pridmap pr ist.Geninterp.lfun) diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 587f4e5cb3..9378529cbe 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1289,7 +1289,7 @@ Prints a profile for all tactics that start with {\qstring}. Append a period (.) \begin{quote} {\tt Reset Ltac Profile}. \end{quote} -Resets the profile, that is, deletes all accumulated information +Resets the profile, that is, deletes all accumulated information. Note that backtracking across a {\tt Reset Ltac Profile} will not restore the information. \begin{coq_eval} Reset Initial. diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index c5fd40bf15..2da12c8d69 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -2289,6 +2289,12 @@ giving \texttt{injection {\term} as} (with an empty list of names). To obtain this behavior, the option {\tt Set Structural Injection} must be activated. This option is off by default. +By default, \texttt{injection} only creates new equalities between +terms whose type is in sort \texttt{Type} or \texttt{Set}, thus +implementing a special behavior for objects that are proofs +of a statement in \texttt{Prop}. This behavior can be turned off +by setting the option \texttt{Set Keep Proof Equalities}. +\optindex{Keep Proof Equalities} \subsection{\tt inversion \ident} \tacindex{inversion} @@ -2308,6 +2314,14 @@ latter is first introduced in the local context using stock the lemmas whenever the same instance needs to be inverted several times. See Section~\ref{Derive-Inversion}. +\Rem Part of the behavior of the \texttt{inversion} tactic is to generate +equalities between expressions that appeared in the hypothesis that is +being processed. By default, no equalities are generated if they relate +two proofs (i.e. equalities between terms whose type is in +sort \texttt{Prop}). This behavior can be turned off by using the option +\texttt{Set Keep Proof Equalities.} +\optindex{Keep Proof Equalities} + \begin{Variants} \item \texttt{inversion \num} @@ -4356,22 +4370,23 @@ vernacular command and printed using {\nobreak {\tt Print Firstorder Tries to solve the goal with {\tac} when no logical rule may apply. - \item {\tt firstorder with \ident$_1$ \dots\ \ident$_n$ } - \tacindex{firstorder with} - - Adds lemmas \ident$_1$ \dots\ \ident$_n$ to the proof-search - environment. - \item {\tt firstorder using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ } \tacindex{firstorder using} - Adds lemmas in {\tt auto} hints bases {\qualid}$_1$ \dots\ {\qualid}$_n$ - to the proof-search environment. If {\qualid}$_i$ refers to an inductive - type, it is the collection of its constructors which is added as hints. + Adds lemmas {\qualid}$_1$ \dots\ {\qualid}$_n$ to the proof-search + environment. If {\qualid}$_i$ refers to an inductive type, it is + the collection of its constructors which are added to the + proof-search environment. -\item \texttt{firstorder using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ with \ident$_1$ \dots\ \ident$_n$} + \item {\tt firstorder with \ident$_1$ \dots\ \ident$_n$ } + \tacindex{firstorder with} - This combines the effects of the {\tt using} and {\tt with} options. + Adds lemmas from {\tt auto} hint bases \ident$_1$ \dots\ \ident$_n$ + to the proof-search environment. + +\item \texttt{firstorder {\tac} using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ with \ident$_1$ \dots\ \ident$_n$} + + This combines the effects of the different variants of \texttt{firstorder}. \end{Variants} diff --git a/engine/evd.ml b/engine/evd.ml index 6ba8a51120..291c089784 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1411,6 +1411,7 @@ let print_env_short env = let pr_evar_constraints pbs = let pr_evconstr (pbty, env, t1, t2) = + let env = Namegen.make_all_name_different env in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ print_constr_env env t1 ++ spc () ++ str (match pbty with diff --git a/engine/ftactic.ml b/engine/ftactic.ml index 588709873e..aeaaea7e48 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -29,13 +29,28 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function | Uniform x -> (** We dispatch the uniform result on each goal under focus, as we know that the [m] argument was actually dependent. *) - Proofview.Goal.goals >>= fun l -> - let ans = List.map (fun _ -> x) l in + Proofview.Goal.goals >>= fun goals -> + let ans = List.map (fun g -> (g,x)) goals in Proofview.tclUNIT ans - | Depends l -> Proofview.tclUNIT l + | Depends l -> + Proofview.Goal.goals >>= fun goals -> + Proofview.tclUNIT (List.combine goals l) + in + (* After the tactic has run, some goals which were previously + produced may have been solved by side effects. The values + attached to such goals must be discarded, otherwise the list of + result would not have the same length as the list of focused + goals, which is an invariant of the [Ftactic] module. It is the + reason why a goal is attached to each result above. *) + let filter (g,x) = + g >>= fun g -> + Proofview.Goal.unsolved g >>= function + | true -> Proofview.tclUNIT (Some x) + | false -> Proofview.tclUNIT None in Proofview.tclDISPATCHL (List.map f l) >>= fun l -> - Proofview.tclUNIT (Depends (List.concat l)) + Proofview.Monad.List.map_filter filter (List.concat l) >>= fun filtered -> + Proofview.tclUNIT (Depends filtered) let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) let set_sigma r = diff --git a/engine/proofview.ml b/engine/proofview.ml index a2838a2de1..85a52fdcaf 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -685,6 +685,21 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let mark_in_evm ~goal evd content = + let info = Evd.find evd content in + let info = + if goal then + { info with Evd.evar_source = match info.Evd.evar_source with + | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x + | loc,_ -> loc,Evar_kinds.GoalEvar } + else info + in + let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with + | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } + | Some () -> info + in + Evd.add evd content info + let with_shelf tac = let open Proof in Pv.get >>= fun pv -> @@ -697,8 +712,11 @@ let with_shelf tac = let fgoals = Evd.future_goals solution in let pgoal = Evd.principal_future_goal solution in let sigma = Evd.restore_future_goals sigma fgoals pgoal in - Pv.set { npv with shelf; solution = sigma } >> - tclUNIT (CList.rev_append gls' gls, ans) + (* Ensure we mark and return only unsolved goals *) + let gls' = undefined sigma (CList.rev_append gls' gls) in + let sigma = CList.fold_left (mark_in_evm ~goal:false) sigma gls' in + let npv = { npv with shelf; solution = sigma } in + Pv.set npv >> tclUNIT (gls', ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -929,6 +947,8 @@ module Unsafe = struct { step with comb = step.comb @ gls } end + let tclSETENV = Env.set + let tclGETGOALS = Comb.get let tclSETGOALS = Comb.set @@ -943,20 +963,13 @@ module Unsafe = struct { p with solution = Evd.reset_future_goals p.solution } let mark_as_goal evd content = - let info = Evd.find evd content in - let info = - { info with Evd.evar_source = match info.Evd.evar_source with - | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x - | loc,_ -> loc,Evar_kinds.GoalEvar } - in - let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with - | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } - | Some () -> info - in - Evd.add evd content info + mark_in_evm ~goal:true evd content let advance = advance + let mark_as_unresolvable p gl = + { p with solution = mark_in_evm ~goal:false p.solution gl } + let typeclass_resolvable = typeclass_resolvable end @@ -1129,6 +1142,10 @@ module Goal = struct in tclUNIT (CList.map_filter map step.comb) + let unsolved { self=self } = + tclEVARMAP >>= fun sigma -> + tclUNIT (not (Option.is_empty (advance sigma self))) + (* compatibility *) let goal { self=self } = self diff --git a/engine/proofview.mli b/engine/proofview.mli index bc68f11ff0..725445251d 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -326,8 +326,9 @@ val unshelve : Goal.goal list -> proofview -> proofview (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool -(** [with_shelf tac] executes [tac] and returns its result together with the set - of goals shelved by [tac]. The current shelf is unchanged. *) +(** [with_shelf tac] executes [tac] and returns its result together with + the set of goals shelved by [tac]. The current shelf is unchanged + and the returned list contains only unsolved goals. *) val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] @@ -409,6 +410,9 @@ module Unsafe : sig (** Like {!tclEVARS} but also checks whether goals have been solved. *) val tclEVARSADVANCE : Evd.evar_map -> unit tactic + (** Set the global environment of the tactic *) + val tclSETENV : Environ.env -> unit tactic + (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently being proved, appending them to the list of focused goals. If a goal is already solved, it is not added. *) @@ -431,6 +435,9 @@ module Unsafe : sig and makes it unresolvable for type classes. *) val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + (** Make an evar unresolvable for type classes. *) + val mark_as_unresolvable : proofview -> Evar.t -> proofview + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) @@ -518,6 +525,10 @@ module Goal : sig FIXME: encapsulate the level in an existential type. *) val goals : ([ `LZ ], 'r) t tactic list tactic + (** [unsolved g] is [true] if [g] is still unsolved in the current + proof state. *) + val unsolved : ('a, 'r) t -> bool tactic + (** Compatibility: avoid if possible *) val goal : ([ `NF ], 'r) t -> Evar.t diff --git a/engine/termops.ml b/engine/termops.ml index a047bf53c7..17e56ec31e 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -975,11 +975,8 @@ let smash_rel_context sign = let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init -let rec mem_named_context id ctxt = - match ctxt with - | decl :: _ when Id.equal id (NamedDecl.get_id decl) -> true - | _ :: sign -> mem_named_context id sign - | [] -> false +let mem_named_context_val id ctxt = + try Environ.lookup_named_val id ctxt; true with Not_found -> false let compact_named_context_reverse sign = let compact l decl = diff --git a/engine/termops.mli b/engine/termops.mli index 5d85088f8d..0a7ac1f266 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -237,7 +237,7 @@ val map_rel_context_with_binders : val fold_named_context_both_sides : ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> Context.Named.t -> init:'a -> 'a -val mem_named_context : Id.t -> Context.Named.t -> bool +val mem_named_context_val : Id.t -> named_context_val -> bool val compact_named_context : Context.Named.t -> Context.NamedList.t val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index bb8723dfe6..5b07d3ec3b 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -100,7 +100,7 @@ let coqide_cmd_checks (loc,ast) = if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then - Feedback.msg_warning (strbrk"This will not work. Use CoqIDE display menu instead"); + Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); if is_query ast then diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml index 9de1df9f1e..680da7f54b 100644 --- a/ide/texmacspp.ml +++ b/ide/texmacspp.ml @@ -709,6 +709,7 @@ let rec tmpp v loc = | 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 diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e71daef999..dd8a48b85e 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -149,17 +149,8 @@ let extern_evar loc n l = CEvar (loc,n,l) For instance, in the debugger the tables of global references may be inaccurate *) -let safe_shortest_qualid_of_global vars r = - try shortest_qualid_of_global vars r - with Not_found -> - match r with - | VarRef v -> make_qualid DirPath.empty v - | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c)) - | IndRef (i,_) | ConstructRef ((i,_),_) -> - make_qualid DirPath.empty Names.(Label.to_id (mind_label i)) - let default_extern_reference loc vars r = - Qualid (loc,safe_shortest_qualid_of_global vars r) + Qualid (loc,shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference @@ -481,7 +472,7 @@ let explicitize loc inctx impl (cf,f) args = (!print_implicits && !print_implicits_explicit_args) || (is_needed_for_correct_partial_application tail imp) || (!print_implicits_defensive && - (not (is_inferable_implicit inctx n imp) || !Flags.beautify_file) && + (not (is_inferable_implicit inctx n imp) || !Flags.beautify) && is_significant_implicit (Lazy.force a)) in if visible then diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 4502aa7ace..e6340646f5 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1061,6 +1061,15 @@ let find_pattern_variable = function | Ident (loc,id) -> id | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) +let check_duplicate loc fields = + let eq (ref1, _) (ref2, _) = eq_reference ref1 ref2 in + let dups = List.duplicates eq fields in + match dups with + | [] -> () + | (r, _) :: _ -> + user_err_loc (loc, "", str "This record defines several times the field " ++ + pr_reference r ++ str ".") + (** [sort_fields ~complete loc fields completer] expects a list [fields] of field assignments [f = e1; g = e2; ...], where [f, g] are fields of a record and [e1] are "values" (either terms, when @@ -1094,6 +1103,7 @@ let sort_fields ~complete loc fields completer = try Qualid (loc, shortest_qualid_of_global Id.Set.empty global_record_id) with Not_found -> anomaly (str "Environment corruption for records") in + let () = check_duplicate loc fields in let (end_index, (* one past the last field index *) first_field_index, (* index of the first field of the record *) proj_list) (* list of projections *) @@ -1400,7 +1410,40 @@ let rec intern_pat genv aliases pat = check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') +(* [check_no_patcast p] raises an error if [p] contains a cast. This code is a + bit ad-hoc, and is due to current restrictions on casts in patterns. We + support them only in local binders and only at top level. In fact, they are + currently eliminated by the parser. The only reason why they are in the + [cases_pattern_expr] type is that the parser needs to factor the "(c : t)" + notation with user defined notations (such as the pair). In the long term, we + will try to support such casts everywhere, and use them to print the domains + of lambdas in the encoding of match in constr. We put this check here and not + in the parser because it would require to duplicate the levels of the + [pattern] rule. *) +let rec check_no_patcast = function + | CPatCast (loc,_,_) -> + CErrors.user_err_loc (loc, "check_no_patcast", + Pp.strbrk "Casts are not supported here.") + | CPatDelimiters(_,_,p) + | CPatAlias(_,p,_) -> check_no_patcast p + | CPatCstr(_,_,opl,pl) -> + Option.iter (List.iter check_no_patcast) opl; + List.iter check_no_patcast pl + | CPatOr(_,pl) -> + List.iter check_no_patcast pl + | CPatNotation(_,_,subst,pl) -> + check_no_patcast_subst subst; + List.iter check_no_patcast pl + | CPatRecord(_,prl) -> + List.iter (fun (_,p) -> check_no_patcast p) prl + | CPatAtom _ | CPatPrim _ -> () + +and check_no_patcast_subst (pl,pll) = + List.iter check_no_patcast pl; + List.iter (List.iter check_no_patcast) pll + let intern_cases_pattern genv scopes aliases pat = + check_no_patcast pat; intern_pat genv aliases (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) scopes pat) @@ -1409,6 +1452,7 @@ let _ = fun scopes p -> intern_cases_pattern (Global.env ()) scopes empty_alias p let intern_ind_pattern genv scopes pat = + check_no_patcast pat; let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat @@ -2003,14 +2047,14 @@ let interp_notation_constr ?(impls=empty_internalization_env) nenv a = tmp_scope = None; scopes = []; impls = impls} false (empty_ltac_sign, vl) a in (* Translate and check that [c] has all its free variables bound in [vars] *) - let a = notation_constr_of_glob_constr nenv c in + let a, reversible = notation_constr_of_glob_constr nenv c in (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in let vars = Id.Map.map (fun (isonlybinding, sc, typ) -> (!isonlybinding, out_scope !sc, typ)) vl in (* Returns [a] and the ordered list of variables with their scopes *) - vars, a + vars, a, reversible (* Interpret binders and contexts *) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index eea76aa310..61e7c6f5cb 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -186,7 +186,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr val interp_notation_constr : ?impls:internalization_env -> notation_interp_env -> constr_expr -> (bool * subscopes * notation_var_internalization_type) Id.Map.t * - notation_constr + notation_constr * reversibility_flag (** Globalization options *) val parsing_explicit : bool ref diff --git a/interp/notation.ml b/interp/notation.ml index d301ed21db..389a1c9dff 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1009,6 +1009,9 @@ let find_notation_parsing_rules ntn = try pi3 (String.Map.find ntn !notation_rules) with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn) +let get_defined_notations () = + String.Set.elements @@ String.Map.domain !notation_rules + let add_notation_extra_printing_rule ntn k v = try notation_rules := diff --git a/interp/notation.mli b/interp/notation.mli index b47e1975e3..2e92a00a8c 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -203,6 +203,9 @@ val find_notation_extra_printing_rules : notation -> extra_unparsing_rules val find_notation_parsing_rules : notation -> notation_grammar val add_notation_extra_printing_rule : notation -> string -> string -> unit +(** Returns notations with defined parsing/printing rules *) +val get_defined_notations : unit -> notation list + (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index cc81a00919..7b520c1c11 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -323,6 +323,7 @@ let compare_recursive_parts found f f' (iterator,subc) = let notation_constr_and_vars_of_glob_constr a = let found = ref ([],[],[]) in + let has_ltac = ref false in let rec aux c = let keepfound = !found in (* n^2 complexity but small and done only once per notation *) @@ -368,7 +369,9 @@ let notation_constr_and_vars_of_glob_constr a = NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) | GSort (_,s) -> NSort s - | GHole (_,w,naming,arg) -> NHole (w, naming, arg) + | GHole (_,w,naming,arg) -> + if arg != None then has_ltac := true; + NHole (w, naming, arg) | GRef (_,r,_) -> NRef r | GEvar _ | GPatVar _ -> error "Existential variables not allowed in notations." @@ -376,9 +379,10 @@ let notation_constr_and_vars_of_glob_constr a = in let t = aux a in (* Side effect *) - t, !found + t, !found, !has_ltac -let check_variables nenv (found,foundrec,foundrecbinding) = +let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = + let injective = ref true in let recvars = nenv.ninterp_rec_vars in let fold _ y accu = Id.Set.add y accu in let useless_vars = Id.Map.fold fold recvars Id.Set.empty in @@ -401,7 +405,7 @@ let check_variables nenv (found,foundrec,foundrecbinding) = error (Id.to_string x ^ " should not be bound in a recursive pattern of the right-hand side.") - else nenv.ninterp_only_parse <- true + else injective := false in let check_pair s x y where = if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then @@ -421,12 +425,13 @@ let check_variables nenv (found,foundrec,foundrecbinding) = with Not_found -> check_bound x end | NtnInternTypeIdent -> check_bound x in - Id.Map.iter check_type vars + Id.Map.iter check_type vars; + !injective let notation_constr_of_glob_constr nenv a = - let a, found = notation_constr_and_vars_of_glob_constr a in - let () = check_variables nenv found in - a + let a, found, has_ltac = notation_constr_and_vars_of_glob_constr a in + let injective = check_variables_and_reversibility nenv found in + a, not has_ltac && injective (**********************************************************************) (* Substitution of kernel names, avoiding a list of bound identifiers *) @@ -436,7 +441,6 @@ let notation_constr_of_constr avoiding t = let nenv = { ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } in notation_constr_of_glob_constr nenv t @@ -454,7 +458,7 @@ let rec subst_notation_constr subst bound raw = | NRef ref -> let ref',t = subst_global subst ref in if ref' == ref then raw else - notation_constr_of_constr bound t + fst (notation_constr_of_constr bound t) | NVar _ -> raw diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 4ebd3ddd80..c8fcbf7410 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -29,7 +29,7 @@ val ldots_var : Id.t bound by the notation; also interpret recursive patterns *) val notation_constr_of_glob_constr : notation_interp_env -> - glob_constr -> notation_constr + glob_constr -> notation_constr * reversibility_flag (** Re-interpret a notation as a [glob_constr], taking care of binders *) diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index d2dcbd92aa..2523063e64 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -84,11 +84,6 @@ let declare_syntactic_definition local id onlyparse pat = let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Id.Set.empty kn) -let verbose_compat_notations = ref true - -let is_verbose_compat () = - !verbose_compat_notations - let pr_compat_warning (kn, def, v) = let pp_def = match def with | [], NRef r -> spc () ++ str "is" ++ spc () ++ pr_global_env Id.Set.empty r @@ -98,11 +93,11 @@ let pr_compat_warning (kn, def, v) = pr_syndef kn ++ pp_def ++ since let warn_compatibility_notation = - CWarnings.create ~name:"compatibility-notation" - ~category:"deprecated" pr_compat_warning + CWarnings.(create ~name:"compatibility-notation" + ~category:"deprecated" ~default:Disabled pr_compat_warning) let verbose_compat kn def = function - | Some v when is_verbose_compat () && Flags.version_strictly_greater v -> + | Some v when Flags.version_strictly_greater v -> warn_compatibility_notation (kn, def, v) | _ -> () @@ -113,12 +108,3 @@ let search_syntactic_definition kn = def open Goptions - -let set_verbose_compat_notations = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "verbose compatibility notations"; - optkey = ["Verbose";"Compat";"Notations"]; - optread = (fun () -> !verbose_compat_notations); - optwrite = ((:=) verbose_compat_notations) } diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index aa2c9c3c1b..55e2848e69 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -17,6 +17,3 @@ val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : kernel_name -> syndef_interpretation - -(** Option concerning verbose display of compatibility notations *) -val set_verbose_compat_notations : bool -> unit diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 2b860173a6..79eeacf354 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -22,8 +22,7 @@ open Constrexpr_ops let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; - Goptions.optname = - "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments"; + Goptions.optname = "no parameters in constructors"; Goptions.optkey = ["Asymmetric";"Patterns"]; Goptions.optread = (fun () -> !asymmetric_patterns); Goptions.optwrite = (fun a -> asymmetric_patterns:=a); diff --git a/intf/notation_term.mli b/intf/notation_term.mli index 883b017727..1ab9980a5c 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -73,10 +73,11 @@ type interpretation = (Id.t * (subscopes * notation_var_instance_type)) list * notation_constr +type reversibility_flag = bool + type notation_interp_env = { ninterp_var_type : notation_var_internalization_type Id.Map.t; ninterp_rec_vars : Id.t Id.Map.t; - mutable ninterp_only_parse : bool; } type grammar_constr_prod_item = diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 1063a74d9f..8572870407 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -347,7 +347,7 @@ type vernac_expr = | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of (lident * Univ.constraint_type * lident) list + | VernacConstraint of (glob_level * Univ.constraint_type * glob_level) list (* Gallina extensions *) | VernacBeginSection of lident @@ -429,6 +429,7 @@ type vernac_expr = (Conv_oracle.level * reference or_by_notation list) list | VernacUnsetOption of Goptions.option_name | VernacSetOption of Goptions.option_name * option_value + | VernacSetAppendOption of Goptions.option_name * string | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index d475f097ce..fe9ec5794c 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -270,11 +270,9 @@ let info_env info = info.i_cache.i_env open Context.Named.Declaration -let rec assoc_defined id = function -| [] -> raise Not_found -| LocalAssum _ :: ctxt -> assoc_defined id ctxt -| LocalDef (id', c, _) :: ctxt -> - if Id.equal id id' then c else assoc_defined id ctxt +let assoc_defined id env = match Environ.lookup_named id env with +| LocalDef (_, c, _) -> c +| _ -> raise Not_found let ref_value_cache ({i_cache = cache} as infos) ref = try @@ -291,7 +289,7 @@ let ref_value_cache ({i_cache = cache} as infos) ref = | None -> raise Not_found | Some t -> lift n t end - | VarKey id -> assoc_defined id (named_context cache.i_env) + | VarKey id -> assoc_defined id cache.i_env | ConstKey cst -> constant_value_in cache.i_env cst in let v = cache.i_repr infos body in diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index e195618b6b..c27cb04870 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -191,7 +191,7 @@ and slot_for_fv env fv = | None -> let open Context.Named in let open Declaration in - env.env_named_context |> lookup id |> get_value |> fill_fv_cache nv id val_of_named idfun + env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> diff --git a/kernel/entries.mli b/kernel/entries.mli index df2c4653f7..ea7c266bcd 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -98,7 +98,12 @@ type module_entry = | MExpr of module_params_entry * module_struct_entry * module_struct_entry option -type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] + +type seff_env = + [ `Nothing + (* The proof term and its universes. + Same as the constant_body's but not in an ephemeron *) + | `Opaque of Constr.t * Univ.universe_context_set ] type side_eff = | SEsubproof of constant * Declarations.constant_body * seff_env diff --git a/kernel/environ.ml b/kernel/environ.ml index 7351a87d44..16ddfac64b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -56,14 +56,14 @@ let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded let universes env = env.env_stratification.env_universes -let named_context env = env.env_named_context -let named_context_val env = env.env_named_context,env.env_named_vals +let named_context env = env.env_named_context.env_named_ctx +let named_context_val env = env.env_named_context let rel_context env = env.env_rel_context let opaque_tables env = env.indirect_pterms let set_opaque_tables env indirect_pterms = { env with indirect_pterms } let empty_context env = - match env.env_rel_context, env.env_named_context with + match env.env_rel_context, env.env_named_context.env_named_ctx with | [], [] -> true | _ -> false @@ -99,14 +99,12 @@ let fold_rel_context f env ~init = (* Named context *) -let named_context_of_val = fst -let named_vals_of_val = snd +let named_context_of_val c = c.env_named_ctx (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) -let map_named_val f = - on_fst (Context.Named.map f) +let map_named_val = map_named_val let empty_named_context = Context.Named.empty @@ -118,8 +116,8 @@ let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named id env = Context.Named.lookup id env.env_named_context -let lookup_named_val id (ctxt,_) = Context.Named.lookup id ctxt +let lookup_named = lookup_named +let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map) let eq_named_context_val c1 c2 = c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2) @@ -139,10 +137,9 @@ let evaluable_named id env = | Some _ -> true | _ -> false -let reset_with_named_context (ctxt,ctxtv) env = +let reset_with_named_context ctxt env = { env with env_named_context = ctxt; - env_named_vals = ctxtv; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0 } @@ -157,11 +154,11 @@ let pop_rel_context n env = let fold_named_context f env ~init = let rec fold_right env = - match env.env_named_context with - | [] -> init - | d::ctxt -> + match match_named_context_val env.env_named_context with + | None -> init + | Some (d, v, rem) -> let env = - reset_with_named_context (ctxt,List.tl env.env_named_vals) env in + reset_with_named_context rem env in f env d (fold_right env) in fold_right env @@ -493,66 +490,35 @@ let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found -let apply_to_hyp (ctxt,vals) id f = - let rec aux rtail ctxt vals = - match ctxt, vals with - | d::ctxt, v::vals -> - if Id.equal (get_id d) id then - (f ctxt d rtail)::ctxt, v::vals - else - let ctxt',vals' = aux (d::rtail) ctxt vals in - d::ctxt', v::vals' - | [],[] -> raise Hyp_not_found - | _, _ -> assert false - in aux [] ctxt vals - -let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = - let rec aux ctxt vals = - match ctxt,vals with - | d::ctxt, v::vals -> +let apply_to_hyp ctxt id f = + let rec aux rtail ctxt = + match match_named_context_val ctxt with + | Some (d, v, ctxt) -> if Id.equal (get_id d) id then - let sign = ctxt,vals in - push_named_context_val (f d sign) sign + push_named_context_val_val (f ctxt.env_named_ctx d rtail) v ctxt else - let (ctxt,vals as sign) = aux ctxt vals in - push_named_context_val (g d sign) sign - | [],[] -> raise Hyp_not_found - | _,_ -> assert false - in aux ctxt vals - -let insert_after_hyp (ctxt,vals) id d check = - let rec aux ctxt vals = - match ctxt, vals with - | decl::ctxt', v::vals' -> - if Id.equal (get_id decl) id then begin - check ctxt; - push_named_context_val d (ctxt,vals) - end else - let ctxt,vals = aux ctxt vals in - d::ctxt, v::vals - | [],[] -> raise Hyp_not_found - | _, _ -> assert false - in aux ctxt vals - + let ctxt' = aux (d::rtail) ctxt in + push_named_context_val_val d v ctxt' + | None -> raise Hyp_not_found + in aux [] ctxt (* To be used in Logic.clear_hyps *) -let remove_hyps ids check_context check_value (ctxt, vals) = - let rec remove_hyps ctxt vals = match ctxt, vals with - | [], [] -> ([], []), false - | d :: rctxt, (nid, v) :: rvals -> - let (ans, seen) = remove_hyps rctxt rvals in +let remove_hyps ids check_context check_value ctxt = + let rec remove_hyps ctxt = match match_named_context_val ctxt with + | None -> empty_named_context_val, false + | Some (d, v, rctxt) -> + let (ans, seen) = remove_hyps rctxt in if Id.Set.mem (get_id d) ids then (ans, true) - else if not seen then (ctxt, vals), false + else if not seen then ctxt, false else - let (rctxt', rvals') = ans in + let rctxt' = ans in let d' = check_context d in let v' = check_value v in - if d == d' && v == v' && rctxt == rctxt' && rvals == rvals' then - (ctxt, vals), true - else (d' :: rctxt', (nid, v') :: rvals'), true - | _ -> assert false + if d == d' && v == v' && rctxt == rctxt' then + ctxt, true + else push_named_context_val_val d' v' rctxt', true in - fst (remove_hyps ctxt vals) + fst (remove_hyps ctxt) (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module diff --git a/kernel/environ.mli b/kernel/environ.mli index b5e5764354..6ac00088b3 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -78,7 +78,6 @@ val fold_rel_context : (** {5 Context of variables (section variables and goal assumptions) } *) val named_context_of_val : named_context_val -> Context.Named.t -val named_vals_of_val : named_context_val -> Pre_env.named_vals val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val @@ -265,18 +264,6 @@ val apply_to_hyp : named_context_val -> variable -> (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val -(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into - [tail::(id,_,_)::head] and - return [(g tail)::(f (id,_,_))::head]. *) -val apply_to_hyp_and_dependent_on : named_context_val -> variable -> - (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> - (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> - named_context_val - -val insert_after_hyp : named_context_val -> variable -> - Context.Named.Declaration.t -> - (Context.Named.t -> unit) -> named_context_val - val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ad5b04f3d1..eaddace4b7 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1861,7 +1861,7 @@ and compile_rel env sigma univ auxdefs n = and compile_named env sigma univ auxdefs id = let open Context.Named.Declaration in - match Context.Named.lookup id env.env_named_context with + match lookup_named id env with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 5afefeebde..7be8606ef4 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -61,12 +61,14 @@ let force_lazy_val vk = match !vk with let dummy_lazy_val () = ref VKnone let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) -type named_vals = (Id.t * lazy_val) list +type named_context_val = { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} type env = { env_globals : globals; - env_named_context : Context.Named.t; - env_named_vals : named_vals; + env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; @@ -77,9 +79,10 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = Context.Named.t * named_vals - -let empty_named_context_val = [],[] +let empty_named_context_val = { + env_named_ctx = []; + env_named_map = Id.Map.empty; +} let empty_env = { env_globals = { @@ -87,8 +90,7 @@ let empty_env = { env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; - env_named_context = Context.Named.empty; - env_named_vals = []; + env_named_context = empty_named_context_val; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0; @@ -125,17 +127,42 @@ let env_of_rel n env = (* Named context *) -let push_named_context_val d (ctxt,vals) = - let rval = ref VKnone in - Context.Named.add d ctxt, (get_id d,rval)::vals +let push_named_context_val_val d rval ctxt = +(* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) + { + env_named_ctx = Context.Named.add d ctxt.env_named_ctx; + env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map; + } + +let push_named_context_val d ctxt = + push_named_context_val_val d (ref VKnone) ctxt + +let match_named_context_val c = match c.env_named_ctx with +| [] -> None +| decl :: ctx -> + let (_, v) = Id.Map.find (get_id decl) c.env_named_map in + let map = Id.Map.remove (get_id decl) c.env_named_map in + let cval = { env_named_ctx = ctx; env_named_map = map } in + Some (decl, v, cval) + +let map_named_val f ctxt = + let open Context.Named.Declaration in + let fold accu d = + let d' = map_constr f d in + let accu = + if d == d' then accu + else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu + in + (accu, d') + in + let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in + { env_named_ctx = ctx; env_named_map = map } let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) - let rval = ref VKnone in { env_globals = env.env_globals; - env_named_context = Context.Named.add d env.env_named_context; - env_named_vals = (get_id d, rval) :: env.env_named_vals; + env_named_context = push_named_context_val d env.env_named_context; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; env_nb_rel = env.env_nb_rel; @@ -146,8 +173,11 @@ let push_named d env = indirect_pterms = env.indirect_pterms; } +let lookup_named id env = + fst (Id.Map.find id env.env_named_context.env_named_map) + let lookup_named_val id env = - snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals) + snd(Id.Map.find id env.env_named_context.env_named_map) (* Warning all the names should be different *) let env_of_named id env = env diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index e551d22c81..866790367d 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -40,12 +40,14 @@ val force_lazy_val : lazy_val -> (values * Id.Set.t) option val dummy_lazy_val : unit -> lazy_val val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit -type named_vals = (Id.t * lazy_val) list +type named_context_val = private { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} type env = { env_globals : globals; - env_named_context : Context.Named.t; - env_named_vals : named_vals; + env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; @@ -56,8 +58,6 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = Context.Named.t * named_vals - val empty_named_context_val : named_context_val val empty_env : env @@ -73,7 +73,15 @@ val env_of_rel : int -> env -> env val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val +val push_named_context_val_val : + Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val +val match_named_context_val : + named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option +val map_named_val : + (constr -> constr) -> named_context_val -> named_context_val + val push_named : Context.Named.Declaration.t -> env -> env +val lookup_named : Id.t -> env -> Context.Named.Declaration.t val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env diff --git a/lib/feedback.ml b/lib/feedback.ml index dd1ca2af36..44b3ee35d7 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -52,8 +52,7 @@ open Pp_control type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit -let msgnl_with fmt strm = msg_with fmt (strm ++ fnl ()) -let msgnl strm = msgnl_with !std_ft strm +let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) (* XXX: This is really painful! *) module Emacs = struct @@ -75,45 +74,100 @@ end open Emacs -let dbg_str = str "Debug:" ++ spc () +let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () let info_str = mt () -let warn_str = str "Warning:" ++ spc () -let err_str = str "Error:" ++ spc () +let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () +let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in quoter (hov 0 (loc ++ info ++ s)) (* Generic logger *) -let gen_logger dbg err ?loc level msg = match level with - | Debug -> msgnl (make_body dbg dbg_str ?loc msg) - | Info -> msgnl (make_body dbg info_str ?loc msg) - (* XXX: What to do with loc here? *) - | Notice -> msgnl msg +let gen_logger dbg err ?pp_tag ?loc level msg = match level with + | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) + | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) + | Notice -> msgnl_with ?pp_tag !std_ft msg | Warning -> Flags.if_warn (fun () -> - msgnl_with !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with !err_ft (make_body err err_str ?loc msg) + msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () + | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) -(** Standard loggers *) -let std_logger = gen_logger (fun x -> x) (fun x -> x) +(* We provide a generic clear_log_backend callback for backends + wanting to do clenaup after the print. +*) +let std_logger_tag = ref None +let std_logger_cleanup = ref (fun () -> ()) -(* Color logger *) -let color_terminal_logger ?loc level strm = - let msg = Ppstyle.color_msg in - match level with - | Debug -> msg ?loc ~header:("Debug", Ppstyle.debug_tag) !std_ft strm - | Info -> msg ?loc !std_ft strm - | Notice -> msg ?loc !std_ft strm - | Warning -> Flags.if_warn (fun () -> - msg ?loc ~header:("Warning", Ppstyle.warning_tag) !err_ft strm) () - | Error -> msg ?loc ~header:("Error", Ppstyle.error_tag) !err_ft strm +let std_logger ?loc level msg = + gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; + !std_logger_cleanup () (* Rules for emacs: - Debug/info: emacs_quote_info - Warning/Error: emacs_quote_err - Notice: unquoted + + Note the inconsistency. *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None + +(** Color logging. Moved from pp_style, it may need some more refactoring *) + +(** Not thread-safe. We should put a lock somewhere if we print from + different threads. Do we? *) +let make_style_stack () = + (** Default tag is to reset everything *) + let empty = Terminal.make () in + let default_tag = Terminal.({ + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + }) + in + let style_stack = ref [] in + let peek () = match !style_stack with + | [] -> default_tag (** Anomalous case, but for robustness *) + | st :: _ -> st + in + let push tag = + let style = match Ppstyle.get_style tag with + | None -> empty + | Some st -> st + in + (** Use the merging of the latest tag and the one being currently pushed. + This may be useful if for instance the latest tag changes the background and + the current one the foreground, so that the two effects are additioned. *) + let style = Terminal.merge (peek ()) style in + style_stack := style :: !style_stack; + Terminal.eval style + in + let pop _ = match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_tag + | _ :: rem -> style_stack := rem; + Terminal.eval (peek ()) + in + let clear () = style_stack := [] in + push, pop, clear + +let init_color_output () = + let open Pp_control in + let push_tag, pop_tag, clear_tag = make_style_stack () in + std_logger_cleanup := clear_tag; + std_logger_tag := Some Ppstyle.pp_tag; + let tag_handler = { + Format.mark_open_tag = push_tag; + Format.mark_close_tag = pop_tag; + Format.print_open_tag = ignore; + Format.print_close_tag = ignore; + } in + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true; + Format.pp_set_formatter_tag_functions !std_ft tag_handler; + Format.pp_set_formatter_tag_functions !err_ft tag_handler let logger = ref std_logger let set_logger l = logger := l diff --git a/lib/feedback.mli b/lib/feedback.mli index 48b1c19a67..5160bd5bc1 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -72,11 +72,8 @@ val set_logger : logger -> unit (** [std_logger] standard logger to [stdout/stderr] *) val std_logger : logger -val color_terminal_logger : logger -(* This logger will apply the proper {!Pp_style} tags, and in - particular use the formatters {!Pp_control.std_ft} and - {!Pp_control.err_ft} to display those messages. Be careful this is - not compatible with the Emacs mode! *) +(** [init_color_output ()] Enable color in the std_logger *) +val init_color_output : unit -> unit (** [feedback_logger] will produce feedback messages instead IO events *) val feedback_logger : logger diff --git a/lib/flags.ml b/lib/flags.ml index af55e9e2bb..65873e5214 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -231,7 +231,7 @@ let print_mod_uid = ref false let tactic_context_compat = ref false let profile_ltac = ref false -let profile_ltac_cutoff = ref 0.0 +let profile_ltac_cutoff = ref 2.0 let dump_bytecode = ref false let set_dump_bytecode = (:=) dump_bytecode diff --git a/lib/monad.ml b/lib/monad.ml index a1714a41b3..2e55e9698c 100644 --- a/lib/monad.ml +++ b/lib/monad.ml @@ -64,6 +64,9 @@ module type ListS = sig its second argument in a tail position. *) val iter : ('a -> unit t) -> 'a list -> unit t + (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) + val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t + (** {6 Two-list iterators} *) @@ -138,6 +141,14 @@ module Make (M:Def) : S with type +'a t = 'a M.t = struct | a::b::l -> f a >> f b >> iter f l + let rec map_filter f = function + | [] -> return [] + | a::l -> + f a >>= function + | None -> map_filter f l + | Some b -> + map_filter f l >>= fun filtered -> + return (b::filtered) let rec fold_left2 r f x l1 l2 = match l1,l2 with diff --git a/lib/monad.mli b/lib/monad.mli index c8655efa04..f7de71f53a 100644 --- a/lib/monad.mli +++ b/lib/monad.mli @@ -66,6 +66,9 @@ module type ListS = sig its second argument in a tail position. *) val iter : ('a -> unit t) -> 'a list -> unit t + (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) + val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t + (** {6 Two-list iterators} *) @@ -77,17 +77,6 @@ open Pp_control \end{description} *) -let comments = ref [] - -let rec split_com comacc acc pos = function - [] -> comments := List.rev acc; comacc - | ((b,e),c as com)::coms -> - (* Take all comments that terminates before pos, or begin exactly - at pos (used to print comments attached after an expression) *) - if e<=pos || pos=b then split_com (c::comacc) acc pos coms - else split_com comacc (com::acc) pos coms - - type block_type = | Pp_hbox of int | Pp_vbox of int @@ -111,7 +100,7 @@ type 'a ppcmd_token = | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_close_tbox - | Ppcmd_comment of int + | Ppcmd_comment of string list | Ppcmd_open_tag of Tag.t | Ppcmd_close_tag @@ -177,7 +166,7 @@ let tab () = Glue.atom(Ppcmd_set_tab) let fnl () = Glue.atom(Ppcmd_force_newline) let pifb () = Glue.atom(Ppcmd_print_if_broken) let ws n = Glue.atom(Ppcmd_white_space n) -let comment n = Glue.atom(Ppcmd_comment n) +let comment l = Glue.atom(Ppcmd_comment l) (* derived commands *) let mt () = Glue.empty @@ -321,8 +310,7 @@ let pp_dirs ?pp_tag ft = com_brk ft; Format.pp_force_newline ft () | Ppcmd_print_if_broken -> com_if ft (Lazy.from_fun(fun()->Format.pp_print_if_newline ft ())) - | Ppcmd_comment i -> - let coms = split_com [] [] i !comments in + | Ppcmd_comment coms -> (* Format.pp_open_hvbox ft 0;*) List.iter (pr_com ft) coms(*; Format.pp_close_box ft ()*) @@ -356,8 +344,8 @@ let pp_with ?pp_tag ft strm = pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) (* pretty printing functions WITH FLUSH *) -let msg_with ft strm = - pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) +let msg_with ?pp_tag ft strm = + pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch @@ -365,7 +353,7 @@ let msg_with ft strm = (** Output to a string formatter *) let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" msg_with c; + Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; Format.flush_str_formatter () (* Copy paste from Util *) diff --git a/lib/pp.mli b/lib/pp.mli index 3bd560812e..8342a983de 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -23,8 +23,7 @@ val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool -val comment : int -> std_ppcmds -val comments : ((int * int) * string) list ref +val comment : string list -> std_ppcmds (** {6 Manipulation commands} *) @@ -173,8 +172,8 @@ val pr_loc : Loc.t -> std_ppcmds (** FIXME: These ignore the logging settings and call [Format] directly *) type tag_handler = Tag.t -> Format.tag -(** [msg_with fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : Format.formatter -> std_ppcmds -> unit +(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) +val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit -(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index ecfaa822c7..aa47c51671 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -56,41 +56,6 @@ let default = Terminal.({ let empty = Terminal.make () -let make_style_stack style_tags = - (** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = - try - begin match String.Map.find tag style_tags with - | None -> empty - | Some st -> st - end - with Not_found -> empty - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - let () = style_stack := style :: !style_stack in - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> - (** Something went wrong, we fallback *) - Terminal.eval default - | _ :: rem -> - let () = style_stack := rem in - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - let error_tag = let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in make ~style ["message"; "error"] @@ -106,37 +71,3 @@ let debug_tag = let pp_tag t = match Pp.Tag.prj t tag with | None -> "" | Some key -> key - -let clear_tag_fn = ref (fun () -> ()) - -let init_color_output () = - let push_tag, pop_tag, clear_tag = make_style_stack !tags in - clear_tag_fn := clear_tag; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - let open Pp_control in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let color_msg ?loc ?header ft strm = - let pptag = tag in - let open Pp in - let ploc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - let strm = match header with - | None -> hov 0 (ploc ++ strm) - | Some (h, t) -> - let tag = Pp.Tag.inj t pptag in - let h = Pp.tag tag (str h ++ str ":") in - hov 0 (ploc ++ h ++ spc () ++ strm) - in - pp_with ~pp_tag ft strm; - Format.pp_print_newline ft (); - Format.pp_print_flush ft (); - (** In case something went wrong, we reset the stack *) - !clear_tag_fn () diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index b07fcd5d4c..d9fd757656 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -44,14 +44,7 @@ val parse_config : string -> unit val dump : unit -> (t * Terminal.style option) list (** Recover the list of known tags together with their current style. *) -(** {5 Setting color output} *) - -val init_color_output : unit -> unit - -val color_msg : ?loc:Loc.t -> ?header:string * Format.tag -> - Format.formatter -> Pp.std_ppcmds -> unit -(** {!color_msg ?header fmt pp} will format according to the tags - defined in this file *) +(** {5 Color output} *) val pp_tag : Pp.tag_handler (** Returns the name of a style tag that is understandable by the formatters diff --git a/library/declare.ml b/library/declare.ml index 7d32b93dc5..c5b83c11a0 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -507,12 +507,20 @@ let input_constraints : constraint_decl -> Libobject.obj = classify_function = (fun a -> Keep a) } let do_constraint poly l = - let u_of_id = - let names, _ = Universes.global_universe_names () in - fun (loc, id) -> - try Idmap.find id names - with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + let open Misctypes in + let u_of_id x = + match x with + | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) + | GSet -> Loc.dummy_loc, (false, Univ.Level.set) + | GType None -> + user_err_loc (Loc.dummy_loc, "Constraint", + str "Cannot declare constraints on anonymous universes") + | GType (Some (loc, id)) -> + let id = Id.of_string id in + let names, _ = Universes.global_universe_names () in + try loc, Idmap.find id names + with Not_found -> + user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = @@ -530,8 +538,8 @@ let do_constraint poly l = ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let p, lu = u_of_id l and p', ru = u_of_id r in - check_poly (fst l) p (fst r) p'; + let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in + check_poly ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in diff --git a/library/declare.mli b/library/declare.mli index e614f5206a..f70d594d7e 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -92,4 +92,6 @@ val exists_name : Id.t -> bool val declare_universe_context : polymorphic -> Univ.universe_context_set -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_constraint : polymorphic -> + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> + unit diff --git a/library/goptions.ml b/library/goptions.ml index 1cf25987b1..35616558a6 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -208,6 +208,10 @@ type 'a option_sig = { optread : unit -> 'a; optwrite : 'a -> unit } +type option_locality = OptLocal | OptDefault | OptGlobal + +type option_mod = OptSet | OptAppend + module OptionOrd = struct type t = option_name @@ -238,49 +242,51 @@ let warn_deprecated_option = (fun key -> str "Option" ++ spc () ++ str (nickname key) ++ strbrk " is deprecated") -let declare_option cast uncast +let get_locality = function + | Some true -> OptLocal + | Some false -> OptGlobal + | None -> OptDefault + +let declare_option cast uncast append { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in - (* spiwack: I use two spaces in the nicknames of "local" and "global" objects. - That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are - lists of strings *without* spaces. *) - let (write,lwrite,gwrite) = if sync then - let ldecl_obj = (* "Local": doesn't survive section or modules. *) - declare_object {(default_object ("L "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose)} - in - let decl_obj = (* default locality: survives sections but not modules. *) - declare_object {(default_object (nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose); - discharge_function = (fun (_,v) -> Some v)} - in - let gdecl_obj = (* "Global": survives section and modules. *) - declare_object {(default_object ("G "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun v -> Substitute v); - subst_function = (fun (_,v) -> v); - discharge_function = (fun (_,v) -> Some v); - load_function = (fun _ (_,v) -> write v)} - in - let _ = Summary.declare_summary (nickname key) - { Summary.freeze_function = (fun _ -> read ()); - Summary.unfreeze_function = write; - Summary.init_function = (fun () -> write default) } - in - begin fun v -> add_anonymous_leaf (decl_obj v) end , - begin fun v -> add_anonymous_leaf (ldecl_obj v) end , - begin fun v -> add_anonymous_leaf (gdecl_obj v) end - else write,write,write + let change = + if sync then + let _ = Summary.declare_summary (nickname key) + { Summary.freeze_function = (fun _ -> read ()); + Summary.unfreeze_function = write; + Summary.init_function = (fun () -> write default) } in + let cache_options (_,(l,m,v)) = + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v) in + let load_options i o = cache_options o in + let subst_options (subst,obj) = obj in + let discharge_options (_,(l,_,_ as o)) = + match l with OptLocal -> None | _ -> Some o in + let classify_options (l,_,_ as o) = + match l with OptGlobal -> Substitute o | _ -> Dispose in + let options : option_locality * option_mod * _ -> obj = + declare_object + { (default_object (nickname key)) with + load_function = load_options; + cache_function = cache_options; + subst_function = subst_options; + discharge_function = discharge_options; + classify_function = classify_options } in + (fun l m v -> Lib.add_anonymous_leaf (options (l, m, v))) + else + (fun _ m v -> + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v)) in let warn () = if depr then warn_deprecated_option key in let cread () = cast (read ()) in - let cwrite v = warn (); write (uncast v) in - let clwrite v = warn (); lwrite (uncast v) in - let cgwrite v = warn (); gwrite (uncast v) in - value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab; + let cwrite l v = warn (); change l OptSet (uncast v) in + let cappend l v = warn (); change l OptAppend (uncast v) in + value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab; write type 'a write_function = 'a -> unit @@ -289,18 +295,22 @@ let declare_int_option = declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_bool_option = declare_option (fun v -> BoolValue v) (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun x y -> x^","^y) let declare_stringopt_option = declare_option (fun v -> StringOptValue v) (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) @@ -315,13 +325,8 @@ let set_option_value locality check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (_,read,write,lwrite,gwrite)) -> - let write = match locality with - | None -> write - | Some true -> lwrite - | Some false -> gwrite - in - write (check_and_cast v (read ())) + | Some (name, depr, (_,read,write,append)) -> + write (get_locality locality) (check_and_cast v (read ())) let bad_type_error () = error "Bad type of value for this option." @@ -357,6 +362,13 @@ let set_string_option_value_gen locality = let unset_option_value_gen locality key = set_option_value locality check_unset_value key () +let set_string_option_append_value_gen locality key v = + let opt = try Some (get_option key) with Not_found -> None in + match opt with + | None -> warn_unknown_option key + | Some (name, depr, (_,read,write,append)) -> + append (get_locality locality) (check_string_value v (read ())) + let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None let set_string_option_value = set_string_option_value_gen None @@ -375,7 +387,7 @@ let msg_option_value (name,v) = (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = - let (name, depr, (_,read,_,_,_)) = get_option key in + let (name, depr, (_,read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> @@ -385,7 +397,7 @@ let print_option_value key = let get_tables () = let tables = !value_tab in - let fold key (name, depr, (sync,read,_,_,_)) accu = + let fold key (name, depr, (sync,read,_,_)) accu = let state = { opt_sync = sync; opt_name = name; @@ -404,13 +416,13 @@ let print_tables () = in str "Synchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p ++ print_option key name (read ()) depr else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p else p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ diff --git a/library/goptions.mli b/library/goptions.mli index 26864503b1..ca2df07104 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -154,6 +154,7 @@ val get_ref_table : val set_int_option_value_gen : bool option -> option_name -> int option -> unit val set_bool_option_value_gen : bool option -> option_name -> bool -> unit val set_string_option_value_gen : bool option -> option_name -> string -> unit +val set_string_option_append_value_gen : bool option -> option_name -> string -> unit val unset_option_value_gen : bool option -> option_name -> unit val set_int_option_value : option_name -> int option -> unit diff --git a/library/lib.ml b/library/lib.ml index 7218950da3..f680ecee3c 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -231,11 +231,16 @@ let add_leaves id objs = List.iter add_obj objs; oname -let add_anonymous_leaf obj = +let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in let oname = make_oname id in - cache_object (oname,obj); - add_entry oname (Leaf obj) + if cache_first then begin + cache_object (oname,obj); + add_entry oname (Leaf obj) + end else begin + add_entry oname (Leaf obj); + cache_object (oname,obj) + end let add_frozen_state () = add_anonymous_entry diff --git a/library/lib.mli b/library/lib.mli index 0a70152efb..a8e110c67a 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -54,7 +54,7 @@ val segment_of_objects : current list of operations (most recent ones coming first). *) val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name -val add_anonymous_leaf : Libobject.obj -> unit +val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 index de4d589eee..6186667584 100644 --- a/ltac/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -151,7 +151,10 @@ END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] +END + +TACTIC EXTEND symmetry_in +| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index c6d72e03e2..0db1cd7bae 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -260,6 +260,20 @@ END let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pcoq.Tactic.in_clause + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY pr_in_top_clause + RAW_TYPED AS clause_dft_concl + RAW_PRINTED BY pr_in_clause + GLOB_TYPED AS clause_dft_concl + GLOB_PRINTED BY pr_in_clause +| [ in_clause'(cl) ] -> [ cl ] +END + (* spiwack: the print functions are incomplete, but I don't know what they are used for *) let pr_r_nat_field natf = diff --git a/ltac/extraargs.mli b/ltac/extraargs.mli index 0cf77935c2..b12187e18a 100644 --- a/ltac/extraargs.mli +++ b/ltac/extraargs.mli @@ -71,3 +71,8 @@ val pr_by_arg_tac : val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type + +val wit_in_clause : + (Id.t Loc.located Locus.clause_expr, + Id.t Loc.located Locus.clause_expr, + Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index 82b79c883d..28078efd64 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -63,8 +63,17 @@ let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>" -let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>" +let pr_raw_strategy prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pptactic.pr_or_by_notation Libnames.pr_reference, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s ARGUMENT EXTEND rewstrategy PRINTED BY pr_strategy diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml index a91ff98fb9..2514ededb0 100644 --- a/ltac/profile_ltac.ml +++ b/ltac/profile_ltac.ml @@ -128,7 +128,7 @@ let to_ltacprof_results xml = | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") let feedback_results results = - Feedback.(feedback + Feedback.(feedback (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) (* ************** pretty printing ************************************* *) @@ -218,7 +218,7 @@ let to_string ~filter ?(cutoff=0.0) node = !global in warn_encountered_multi_success_backtracking (); - let filter s n = filter s && n >= cutoff in + let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in let msg = h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ fnl () ++ diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 69f45e1aeb..4d7c5d0e4b 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -1700,6 +1700,40 @@ let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ( | StratEval r -> StratEval (g r) | StratFold c -> StratFold (f c) +let pr_ustrategy = function +| Subterms -> str "subterms" +| Subterm -> str "subterm" +| Innermost -> str "innermost" +| Outermost -> str "outermost" +| Bottomup -> str "bottomup" +| Topdown -> str "topdown" +| Progress -> str "progress" +| Try -> str "try" +| Any -> str "any" +| Repeat -> str "repeat" + +let paren p = str "(" ++ p ++ str ")" + +let rec pr_strategy prc prr = function +| StratId -> str "id" +| StratFail -> str "fail" +| StratRefl -> str "refl" +| StratUnary (s, str) -> + pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) +| StratBinary (Choice, str1, str2) -> + str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ + paren (pr_strategy prc prr str2) +| StratBinary (Compose, str1, str2) -> + pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 +| StratConstr (c, true) -> prc c +| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c +| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl +| StratHints (old, id) -> + let cmd = if old then "old_hints" else "hints" in + str cmd ++ spc () ++ str id +| StratEval r -> str "eval" ++ spc () ++ prr r +| StratFold c -> str "fold" ++ spc () ++ prc c + let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail diff --git a/ltac/rewrite.mli b/ltac/rewrite.mli index f448c85430..35c4483513 100644 --- a/ltac/rewrite.mli +++ b/ltac/rewrite.mli @@ -62,6 +62,9 @@ val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strat val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast +val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> + ('a, 'b) strategy_ast -> Pp.std_ppcmds + (** Entry point for user-level "rewrite_strat" *) val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index bec891f7f1..181c4b7fd8 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -340,34 +340,46 @@ let comm_loc bp = match !comment_begin with | None -> comment_begin := Some bp | _ -> () -let current = Buffer.create 8192 -let between_com = ref true - -type com_state = int option * string * bool -let restore_com_state (o,s,b) = +let comments = ref [] +let current_comment = Buffer.create 8192 +let between_commands = ref true + +let rec split_comments comacc acc pos = function + [] -> comments := List.rev acc; comacc + | ((b,e),c as com)::coms -> + (* Take all comments that terminates before pos, or begin exactly + at pos (used to print comments attached after an expression) *) + if e<=pos || pos=b then split_comments (c::comacc) acc pos coms + else split_comments comacc (com::acc) pos coms + +let extract_comments pos = split_comments [] [] pos !comments + +type comments_state = int option * string * bool * ((int * int) * string) list +let restore_comments_state (o,s,b,c) = comment_begin := o; - Buffer.clear current; Buffer.add_string current s; - between_com := b -let dflt_com = (None,"",true) -let com_state () = - let s = (!comment_begin, Buffer.contents current, !between_com) in - restore_com_state dflt_com; s + Buffer.clear current_comment; Buffer.add_string current_comment s; + between_commands := b; + comments := c +let default_comments_state = (None,"",true,[]) +let comments_state () = + let s = (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) in + restore_comments_state default_comments_state; s -let real_push_char c = Buffer.add_char current c +let real_push_char c = Buffer.add_char current_comment c (* Add a char if it is between two commands, if it is a newline or if the last char is not a space itself. *) let push_char c = if - !between_com || List.mem c ['\n';'\r'] || + !between_commands || List.mem c ['\n';'\r'] || (List.mem c [' ';'\t']&& - (Int.equal (Buffer.length current) 0 || - not (let s = Buffer.contents current in + (Int.equal (Buffer.length current_comment) 0 || + not (let s = Buffer.contents current_comment in List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) then real_push_char c -let push_string s = Buffer.add_string current s +let push_string s = Buffer.add_string current_comment s let null_comment s = let rec null i = @@ -375,12 +387,12 @@ let null_comment s = null (String.length s - 1) let comment_stop ep = - let current_s = Buffer.contents current in - if !Flags.xml_export && Buffer.length current > 0 && - (!between_com || not(null_comment current_s)) then + let current_s = Buffer.contents current_comment in + if !Flags.xml_export && Buffer.length current_comment > 0 && + (!between_commands || not(null_comment current_s)) then Hook.get f_xml_output_comment current_s; - (if Flags.do_beautify() && Buffer.length current > 0 && - (!between_com || not(null_comment current_s)) then + (if Flags.do_beautify() && Buffer.length current_comment > 0 && + (!between_commands || not(null_comment current_s)) then let bp = match !comment_begin with Some bp -> bp | None -> @@ -389,10 +401,10 @@ let comment_stop ep = ++ str current_s ++str"' ending at " ++ int ep); ep-1 in - Pp.comments := ((bp,ep),current_s) :: !Pp.comments); - Buffer.clear current; + comments := ((bp,ep),current_s) :: !comments); + Buffer.clear current_comment; comment_begin := None; - between_com := false + between_commands := false (* Does not unescape!!! *) let rec comm_string loc bp = parser @@ -548,16 +560,16 @@ let rec next_token loc = parser bp | KEYWORD ("." | "...") -> if not (blank_or_eof s) then err (set_loc_pos loc bp (ep+1)) Undefined_token; - between_com := true; + between_commands := true; | _ -> () in (t, set_loc_pos loc bp ep) | [< ' ('-'|'+'|'*' as c); s >] -> - let t,new_between_com = - if !between_com then process_sequence loc bp c s, true + let t,new_between_commands = + if !between_commands then process_sequence loc bp c s, true else process_chars loc bp c s,false in - comment_stop bp; between_com := new_between_com; t + comment_stop bp; between_commands := new_between_commands; t | [< ''?'; s >] ep -> let t = parse_after_qmark loc bp s in comment_stop bp; (t, set_loc_pos loc ep bp) @@ -590,9 +602,9 @@ let rec next_token loc = parser bp (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart), _) -> let t = process_chars loc bp (Stream.next s) s in - let new_between_com = match t with - (KEYWORD ("{"|"}"),_) -> !between_com | _ -> false in - comment_stop bp; between_com := new_between_com; t + let new_between_commands = match t with + (KEYWORD ("{"|"}"),_) -> !between_commands | _ -> false in + comment_stop bp; between_commands := new_between_commands; t | EmptyStream -> comment_stop bp; (EOI, set_loc_pos loc bp (bp+1)) diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 3b4891d9ac..3ad49eb74a 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -34,12 +34,12 @@ type frozen_t val freeze : unit -> frozen_t val unfreeze : frozen_t -> unit -type com_state -val com_state: unit -> com_state -val restore_com_state: com_state -> unit - val xml_output_comment : (string -> unit) Hook.t +(* Retrieve the comments lexed at a given location of the stream + currently being processeed *) +val extract_comments : int -> string list + val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 18bc8d664f..ecf515111c 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -138,12 +138,21 @@ module type LexerSig = sig exception E of t val to_string : t -> string end + type comments_state + val default_comments_state : comments_state + val comments_state : unit -> comments_state + val restore_comments_state : comments_state -> unit end ELSE -module type LexerSig = - Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t +module type LexerSig = sig + include Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t + type comments_state + val default_comments_state : comments_state + val comments_state : unit -> comments_state + val restore_comments_state : comments_state -> unit +end END @@ -162,10 +171,13 @@ module type GrammarSig = sig string option * Gramext.g_assoc option * production_rule list type extend_statment = Gramext.position option * single_extend_statment list + type coq_parsable + val parsable : char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a + val entry_parse : 'a entry -> coq_parsable -> 'a val entry_print : Format.formatter -> 'a entry -> unit + val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b val srules' : production_rule list -> symbol val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a end @@ -181,14 +193,33 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct string option * Gramext.g_assoc option * production_rule list type extend_statment = Gramext.position option * single_extend_statment list + type coq_parsable = parsable * L.comments_state ref + let parsable c = + let state = ref L.default_comments_state in (parsable c, state) let action = Gramext.action let entry_create = Entry.create - let entry_parse e p = - try Entry.parse e p + let entry_parse e (p,state) = + L.restore_comments_state !state; + try + let c = Entry.parse e p in + state := L.comments_state (); + L.restore_comments_state L.default_comments_state; + c with Exc_located (loc,e) -> + L.restore_comments_state L.default_comments_state; let loc' = Loc.get_loc (Exninfo.info e) in let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in Loc.raise loc e + let with_parsable (p,state) f x = + L.restore_comments_state !state; + try + let a = f x in + state := L.comments_state (); + L.restore_comments_state L.default_comments_state; + a + with e -> + L.restore_comments_state L.default_comments_state; + raise e let entry_print ft x = Entry.print ft x let srules' = Gramext.srules @@ -202,12 +233,13 @@ module type GrammarSig = sig with module Loc = CompatLoc and type Token.t = Tok.t type 'a entry = 'a Entry.t type action = Action.t - type parsable - val parsable : char Stream.t -> parsable + type coq_parsable + val parsable : char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a + val entry_parse : 'a entry -> coq_parsable -> 'a val entry_print : Format.formatter -> 'a entry -> unit + val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b val srules' : production_rule list -> symbol end @@ -217,13 +249,31 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct include Camlp4.Struct.Grammar.Static.Make (L) type 'a entry = 'a Entry.t type action = Action.t - type parsable = char Stream.t - let parsable s = s + type comments_state = int option * string * bool * ((int * int) * string) list + type coq_parsable = char Stream.t * L.comments_state ref + let parsable s = let state = ref L.default_comments_state in (s, state) let action = Action.mk let entry_create = Entry.mk - let entry_parse e s = - try parse e (*FIXME*)CompatLoc.ghost s - with Exc_located (loc,e) -> raise_coq_loc loc e + let entry_parse e (s,state) = + L.restore_comments_state !state; + try + let c = parse e (*FIXME*)CompatLoc.ghost s in + state := L.comments_state (); + L.restore_comments_state L.default_comments_state; + c + with Exc_located (loc,e) -> + L.restore_comments_state L.default_comments_state; + raise_coq_loc loc e + let with_parsable (p,state) f x = + L.restore_comments_state !state; + try + let a = f x in + state := L.comments_state (); + L.restore_comments_state L.default_comments_state; + a + with e -> + L.restore_comments_state L.default_comments_state; + raise e let entry_print ft x = Entry.print ft x let srules' = srules (entry_create "dummy") end diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 74994c5e3d..7f3a3d10ca 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -127,7 +127,7 @@ let name_colon = let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None GEXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr sort global + GLOBAL: binder_constr lconstr constr operconstr universe_level sort global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; @@ -298,10 +298,10 @@ GEXTEND Gram | -> [] ] ] ; instance: - [ [ "@{"; l = LIST1 level; "}" -> Some l + [ [ "@{"; l = LIST1 universe_level; "}" -> Some l | -> None ] ] ; - level: + universe_level: [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType None diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 199ef9fcee..3152afb28d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -220,7 +220,7 @@ let warn_deprecated_eqn_syntax = GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr - simple_intropattern clause_dft_concl hypident destruction_arg; + simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: [ [ n = integer -> ArgArg n diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 1a40128916..bc02a46218 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -226,8 +226,8 @@ GEXTEND Gram [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] ; univ_constraint: - [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; - r = identref -> (l, ord, r) ] ] + [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; + r = universe_level -> (l, ord, r) ] ] ; finite_token: [ [ "Inductive" -> (Inductive_kw,Finite) @@ -850,7 +850,15 @@ GEXTEND Gram (* For acting on parameter tables *) | "Set"; table = option_table; v = option_value -> - VernacSetOption (table,v) + begin match v with + | StringValue s -> + let (last, prefix) = List.sep_last table in + if String.equal last "Append" && not (List.is_empty prefix) then + VernacSetAppendOption (prefix, s) + else + VernacSetOption (table, v) + | _ -> VernacSetOption (table, v) + end | "Set"; table = option_table -> VernacSetOption (table,BoolValue true) | IDENT "Unset"; table = option_table -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 714e25f85e..9e9a7e723e 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -304,6 +304,7 @@ module Constr = let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr "ident" let global = make_gen_entry uconstr "global" + let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" let pattern = Gram.entry_create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" @@ -349,6 +350,7 @@ module Tactic = let red_expr = make_gen_entry utactic "red_expr" let simple_intropattern = make_gen_entry utactic "simple_intropattern" + let in_clause = make_gen_entry utactic "in_clause" let clause_dft_concl = make_gen_entry utactic "clause" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 635b0170ae..7f6caf63fb 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -157,6 +157,7 @@ module Constr : val operconstr : constr_expr Gram.entry val ident : Id.t Gram.entry val global : reference Gram.entry + val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry @@ -192,6 +193,7 @@ module Tactic : val red_expr : raw_red_expr Gram.entry val simple_tactic : raw_tactic_expr Gram.entry val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry + val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry val tactic_arg : raw_tactic_arg Gram.entry val tactic_expr : raw_tactic_expr Gram.entry diff --git a/parsing/tok.ml b/parsing/tok.ml index 8ae1065120..f4b60aeec4 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -53,7 +53,7 @@ let to_string = function | INT s -> Format.sprintf "INT %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" - | BULLET s -> Format.sprintf "STRING %S" s + | BULLET s -> Format.sprintf "BULLET %S" s | EOI -> "EOI" let match_keyword kwd = function diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 8874afef33..e43c47d050 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -142,7 +142,8 @@ let rec json_expr env = function ("what", json_str "fix:item"); ("name", json_id fi); ("body", json_function env' ti) - ]) (Array.map2 (fun a b -> a,b) ids' defs))) + ]) (Array.map2 (fun a b -> a,b) ids' defs))); + ("for", json_int i); ] | MLexn s -> json_dict [ ("what", json_str "expr:exception"); diff --git a/pretyping/cases.ml b/pretyping/cases.ml index e89c3ea719..0ac34b7186 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1870,22 +1870,16 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = (* We put the tycon inside the arity signature, possibly discovering dependencies. *) -let add_subst c len (rel_subst,var_subst) = - match kind_of_term c with - | Rel n -> (n,len) :: rel_subst, var_subst - | Var id -> rel_subst, (id,len) :: var_subst - | _ -> assert false - let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in - let (rel_subst,var_subst), len = + let subst, len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match kind_of_term tm with - | Rel _ | Var _ when dependent tm c + | Rel n when dependent tm c && Int.equal signlen 1 (* The term to match is not of a dependent type itself *) -> - (add_subst tm len subst, len - signlen) - | Rel _ | Var _ when signlen > 1 (* The term is of a dependent type, + ((n, len) :: subst, len - signlen) + | Rel n when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> (match tmtype with NotInd _ -> (subst, len - signlen) @@ -1894,36 +1888,28 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_left (fun (subst, len) arg -> match kind_of_term arg with - | Rel _ | Var _ when dependent arg c -> - (add_subst arg len subst, pred len) + | Rel n when dependent arg c -> + ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if dependent tm c && List.for_all (fun c -> isRel c || isVar c) realargs - then add_subst tm len subst else subst + if dependent tm c && List.for_all isRel realargs + then (n, len) :: subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) - (List.rev tomatchs) arsign (([],[]), nar) + (List.rev tomatchs) arsign ([], nar) in let rec predicate lift c = match kind_of_term c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) - let idx = Int.List.assoc (n - lift) rel_subst in + let idx = Int.List.assoc (n - lift) subst in mkRel (idx + lift) with Not_found -> - (* A variable that is not matched, lift over the arsign *) + (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) - | Var id -> - (try - (* Make the predicate dependent on the matched variable *) - let idx = Id.List.assoc id var_subst in - mkRel (idx + lift) - with Not_found -> - (* A variable that is not matched *) - c) | _ -> map_constr_with_binders succ predicate lift c in @@ -1939,44 +1925,46 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = * type and 1 assumption for each term not _syntactically_ in an * inductive type. - * Each matched term is independently considered dependent or not. + * Each matched terms are independently considered dependent or not. + + * A type constraint but no annotation case: we try to specialize the + * tycon to make the predicate if it is not closed. *) let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let preds = - match pred with + match pred, tycon with (* No return clause *) - | None -> - let sigma,t = - match tycon with - | Some t -> sigma, t - | None -> - (* No type constraint: we first create a generic evar type constraint *) - let src = (loc, Evar_kinds.CasesType false) in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src in - let sigma = Sigma.to_evar_map sigma in - sigma, t in - (* First strategy: we build an "inversion" predicate, also replacing the *) - (* dependencies with existential variables *) - let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in - (* Optional second strategy: we abstract the tycon wrt to the dependencies *) - let p2 = + | None, Some t when not (noccur_with_meta 0 max_int t) -> + (* If the tycon is not closed w.r.t real variables, we try *) + (* two different strategies *) + (* First strategy: we abstract the tycon wrt to the dependencies *) + let p1 = prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in - (* Third strategy: we take the type constraint as it is; of course we could *) - (* need something inbetween, abstracting some but not all of the dependencies *) - (* the "inversion" strategy deals with that but unification may not be *) - (* powerful enough so strategy 2 and 3 helps; moreover, inverting does not *) - (* work (yet) when a constructor has a type not precise enough for the inversion *) - (* see log message for details *) - let pred3 = lift (List.length (List.flatten arsign)) t in - (match p2 with - | Some (sigma2,pred2) when not (Constr.equal pred2 pred3) -> - [sigma1, pred1; sigma2, pred2; sigma, pred3] - | _ -> - [sigma1, pred1; sigma, pred3]) + (* Second strategy: we build an "inversion" predicate *) + let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in + (match p1 with + | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2] + | None -> [sigma2, pred2]) + | None, _ -> + (* No dependent type constraint, or no constraints at all: *) + (* we use two strategies *) + let sigma,t = match tycon with + | Some t -> sigma,t + | None -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((t, _), sigma, _) = + new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in + let sigma = Sigma.to_evar_map sigma in + sigma, t + in + (* First strategy: we build an "inversion" predicate *) + let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in + (* Second strategy: we directly use the evar as a non dependent pred *) + let pred2 = lift (List.length (List.flatten arsign)) t in + [sigma1, pred1; sigma, pred2] (* Some type annotation *) - | Some rtntyp -> + | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in @@ -2577,6 +2565,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e typing_function = typing_fun } in let j = compile pb in + + (* We coerce to the tycon (if an elim predicate was provided) *) + let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in evdref := !myevdref; j in @@ -2587,6 +2578,4 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - (* We coerce to the tycon (if an elim predicate was provided) *) - inh_conv_coerce_to_tycon loc env evdref j tycon - + j diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b033f5a395..b7e0535dad 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -42,12 +42,7 @@ let _ = Goptions.declare_bool_option { let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then - let c' = Some (mkProj (Projection.make cst true, c)) in - match ReductionBehaviour.get (Globnames.ConstRef cst) with - | None -> c' - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags) then None - else c' + Some (mkProj (Projection.make cst true, c)) else None let eval_flexible_term ts env evd c = diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 6c8677855a..a97e248aee 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1591,6 +1591,8 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = * ass. *) +(* This criterion relies on the fact that we postpone only problems of the form: +?x [?x1 ... ?xn] = t or the symmetric case. *) let status_changed lev (pbty,_,t1,t2) = (try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) || (try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false) diff --git a/pretyping/program.ml b/pretyping/program.ml index b4333847b7..62aedcfbf6 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -15,10 +15,12 @@ open Term let make_dir l = DirPath.make (List.rev_map Id.of_string l) let find_reference locstr dir s = - let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in + let dp = make_dir dir in + let sp = Libnames.make_path dp (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> - anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) + user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++ + str " has to be required first.") let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index e4cca2679c..8ca40f829f 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -46,3 +46,5 @@ val type_of_global_reference_knowing_conclusion : val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr + +val print_retype_error : retype_error -> Pp.std_ppcmds diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 6573bd238c..531b615539 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1269,8 +1269,7 @@ let solve_simple_evar_eqn ts env evd ev rhs = match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); - | Success evd -> - Evarconv.consider_remaining_unif_problems env evd + | Success evd -> evd (* [w_merge env sigma b metas evars] merges common instances in metas or in evars, possibly generating new unification problems; if [b] @@ -1389,7 +1388,9 @@ let w_merge env with_types flags (evd,metas,evars) = in w_merge_rec evd [] [] eqns in let res = (* merge constraints *) - w_merge_rec evd (order_metas metas) (List.rev evars) [] + w_merge_rec evd (order_metas metas) + (* Assign evars in the order of assignments during unification *) + (List.rev evars) [] in if with_types then check_types res else res @@ -1587,7 +1588,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else - if mem_named_context x (named_context env) then + if mem_named_context_val x (named_context_val env) then errorlabstrm "Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index a00e4bab30..c94650f1ee 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -129,7 +129,7 @@ end) = struct str "`" ++ str hd ++ c ++ str tl let pr_com_at n = - if Flags.do_beautify() && not (Int.equal n 0) then comment n + if Flags.do_beautify() && not (Int.equal n 0) then comment (CLexer.extract_comments n) else mt() let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) @@ -149,6 +149,12 @@ end) = struct | GType [] -> tag_type (str "Type") | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) + let pr_glob_level = function + | GProp -> tag_type (str "Prop") + | GSet -> tag_type (str "Set") + | GType None -> tag_type (str "Type") + | GType (Some (_, u)) -> tag_type (str u) + let pr_qualid sp = let (sl, id) = repr_qualid sp in let id = tag_ref (pr_id id) in @@ -364,13 +370,13 @@ end) = struct let n = begin_of_binders bl in match bl with | [LocalRawAssum (nal,k,t)] -> - pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t) + kw n ++ pr_binder false pr_c (nal,k,t) | (LocalRawAssum _ | LocalPattern _) :: _ as bdl -> - pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl + kw n ++ pr_undelimited_binders sep pr_c bdl | _ -> assert false let pr_binders_gen pr_c sep is_open = - if is_open then pr_delimited_binders mt sep pr_c + if is_open then pr_delimited_binders pr_com_at sep pr_c else pr_undelimited_binders sep pr_c let rec extract_prod_binders = function @@ -519,9 +525,9 @@ end) = struct prlist_with_sep pr_semicolon (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr ltop c)) l - let pr_forall () = keyword "forall" ++ spc () + let pr_forall n = keyword "forall" ++ pr_com_at n ++ spc () - let pr_fun () = keyword "fun" ++ spc () + let pr_fun n = keyword "fun" ++ pr_com_at n ++ spc () let pr_fun_sep = spc () ++ str "=>" diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli index a59fc6d67d..3de0d805c4 100644 --- a/printing/ppconstrsig.mli +++ b/printing/ppconstrsig.mli @@ -44,6 +44,7 @@ module type Pp = sig val pr_qualid : qualid -> std_ppcmds val pr_patvar : patvar -> std_ppcmds + val pr_glob_level : glob_level -> std_ppcmds val pr_glob_sort : glob_sort -> std_ppcmds val pr_guard_annot : (constr_expr -> std_ppcmds) -> local_binder list -> diff --git a/printing/pptactic.ml b/printing/pptactic.ml index f3117db170..1e618b59eb 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -583,13 +583,13 @@ module Make | None -> mt() let pr_hyp_location pr_id = function - | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs + | occs, InHyp -> pr_with_occurrences pr_id occs | occs, InHypTypeOnly -> - spc () ++ pr_with_occurrences (fun id -> + pr_with_occurrences (fun id -> str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" ) occs | occs, InHypValueOnly -> - spc () ++ pr_with_occurrences (fun id -> + pr_with_occurrences (fun id -> str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" ) occs @@ -603,6 +603,17 @@ module Make | None -> mt () | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + let pr_in_clause pr_id = function + | { onhyps=None; concl_occs=NoOccurrences } -> + (str "* |-") + | { onhyps=None; concl_occs=occs } -> + (pr_with_occurrences (fun () -> str "*") (occs,())) + | { onhyps=Some l; concl_occs=NoOccurrences } -> + prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) + let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } when (match default_is_concl with Some true -> true | _ -> false) -> @@ -619,7 +630,7 @@ module Make | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) in pr_in - (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ pr_occs) + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) let pr_orient b = if b then mt () else str "<- " diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index c08d6044db..665e055f23 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -29,6 +29,9 @@ module type Pp = sig val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + val pr_clauses : bool option -> ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds diff --git a/printing/pputils.ml b/printing/pputils.ml index 906b463a85..57a1d957e0 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -11,5 +11,9 @@ open Pp let pr_located pr (loc, x) = if Flags.do_beautify () && loc <> Loc.ghost then let (b, e) = Loc.unloc loc in - Pp.comment b ++ pr x ++ Pp.comment e + (* Side-effect: order matters *) + let before = Pp.comment (CLexer.extract_comments b) in + let x = pr x in + let after = Pp.comment (CLexer.extract_comments e) in + before ++ x ++ after else pr x diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 503b29aaf2..cfb4e79f03 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -263,7 +263,7 @@ module Make let pr_decl_notation prc ((loc,ntn),c,scopt) = fnl () ++ keyword "where " ++ qs ntn ++ str " := " - ++ Flags.without_option Flags.beautify_file prc c ++ + ++ Flags.without_option Flags.beautify prc c ++ pr_opt (fun sc -> str ": " ++ str sc) scopt let pr_binders_arg = @@ -383,7 +383,7 @@ module Make | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) = - let pr_pure_lconstr c = Flags.without_option Flags.beautify_file pr_lconstr c in + let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in let annot = pr_guard_annot pr_lconstr_expr bl ro in pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ @@ -678,7 +678,7 @@ module Make | VernacNotation (_,c,((_,s),l),opt) -> return ( hov 2 (keyword "Notation" ++ spc() ++ qs s ++ - str " :=" ++ Flags.without_option Flags.beautify_file pr_constrarg c ++ pr_syntax_modifiers l ++ + str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ (match opt with | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) @@ -760,7 +760,7 @@ module Make let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ - Flags.without_option Flags.beautify_file pr_spc_lconstr c) + Flags.without_option Flags.beautify pr_spc_lconstr c) in let pr_constructor_list b l = match l with | Constructors [] -> mt() @@ -838,7 +838,8 @@ module Make ) | VernacConstraint v -> let pr_uconstraint (l, d, r) = - pr_lident l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_lident r + pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_level r in return ( hov 2 (keyword "Constraint" ++ spc () ++ @@ -1109,6 +1110,11 @@ module Make return ( hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v) ) + | VernacSetAppendOption (na,v) -> + return ( + hov 2 (keyword "Set" ++ spc() ++ pr_printoption na None ++ + spc() ++ keyword "Append" ++ spc() ++ str v) + ) | VernacAddOption (na,l) -> return ( hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l)) diff --git a/printing/printmod.ml b/printing/printmod.ml index c939f54e80..dfa66d4376 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -247,19 +247,24 @@ let get_typ_expr_alg mtb = match mtb.mod_type_alg with | _ -> raise Not_found let nametab_register_modparam mbid mtb = + let id = MBId.to_id mbid in match mtb.mod_type with - | MoreFunctor _ -> () (* functorial param : nothing to register *) + | MoreFunctor _ -> id (* functorial param : nothing to register *) | NoFunctor struc -> (* We first try to use the algebraic type expression if any, via a Declaremods function that converts back to module entries *) try - Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) + let () = Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) in + id with e when CErrors.noncritical e -> (* Otherwise, we try to play with the nametab ourselves *) let mp = MPbound mbid in - let dir = DirPath.make [MBId.to_id mbid] in + let check id = Nametab.exists_dir (DirPath.make [id]) in + let id = Namegen.next_ident_away_from id check in + let dir = DirPath.make [id] in nametab_register_dir mp; - List.iter (nametab_register_body mp dir) struc + List.iter (nametab_register_body mp dir) struc; + id let print_body is_impl env mp (l,body) = let name = pr_label l in @@ -353,7 +358,7 @@ let print_mod_expr env mp locals = function let rec print_functor fty fatom is_type env mp locals = function |NoFunctor me -> fatom is_type env mp locals me |MoreFunctor (mbid,mtb1,me2) -> - nametab_register_modparam mbid mtb1; + let id = nametab_register_modparam mbid mtb1 in let mp1 = MPbound mbid in let pr_mtb1 = fty env mp1 locals mtb1 in let env' = Option.map (Modops.add_module_type mp1 mtb1) env in @@ -361,7 +366,7 @@ let rec print_functor fty fatom is_type env mp locals = function let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ - str "(" ++ pr_id (MBId.to_id mbid) ++ str ":" ++ pr_mtb1 ++ str ")" ++ + str "(" ++ pr_id id ++ str ":" ++ pr_mtb1 ++ str ")" ++ spc() ++ print_functor fty fatom is_type env' mp locals' me2) let rec print_expression x = diff --git a/proofs/logic.ml b/proofs/logic.ml index e4c833627a..65497c80dd 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -538,7 +538,7 @@ let prim_refiner r sigma goal = nexthyp, t,cl,sigma else - (if !check && mem_named_context id (named_context_of_val sign) then + (if !check && mem_named_context_val id sign then errorlabstrm "Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in diff --git a/proofs/proof.ml b/proofs/proof.ml index 5fe29653d3..5c963d53e7 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -351,7 +351,14 @@ let run_tactic env tac pr = Proofview.apply env tac sp in let sigma = Proofview.return proofview in - let shelf = (undef sigma pr.shelf)@retrieved@(undef sigma to_shelve) in + let to_shelve = undef sigma to_shelve in + let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in + let proofview = + List.fold_left + Proofview.Unsafe.mark_as_unresolvable + proofview + to_shelve + in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace) diff --git a/proofs/refine.ml b/proofs/refine.ml index dc6f4cea10..e5114a2eca 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -51,6 +51,23 @@ let typecheck_proof c concl env sigma = let (pr_constrv,pr_constr) = Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") () +(* Get the side-effect's constant declarations to update the monad's + * environmnent *) +let add_if_undefined kn cb env = + try ignore(Environ.lookup_constant kn env); env + with Not_found -> Environ.add_constant kn cb env + +(* Add the side effects to the monad's environment, if not already done. *) +let add_side_effect env = function + | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> + add_if_undefined kn cb env + | { Entries.eff = Entries.SEscheme (l,_) } -> + List.fold_left (fun env (_,kn,cb,eff_env) -> + add_if_undefined kn cb env) env l + +let add_side_effects env effects = + List.fold_left (fun env eff -> add_side_effect env eff) env effects + let make_refine_enter ?(unsafe = true) f = { enter = fun gl -> let gl = Proofview.Goal.assume gl in @@ -66,6 +83,10 @@ let make_refine_enter ?(unsafe = true) f = let ((v,c), sigma) = Sigma.run (Evd.reset_future_goals sigma) f in let evs = Evd.future_goals sigma in let evkmain = Evd.principal_future_goal sigma in + (** Redo the effects in sigma in the monad's env *) + let privates_csts = Evd.eval_side_effects sigma in + let sideff = Safe_typing.side_effects_of_private_constants privates_csts in + let env = add_side_effects env sideff in (** Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in @@ -94,6 +115,7 @@ let make_refine_enter ?(unsafe = true) f = let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> + Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> Proofview.Unsafe.tclSETGOALS comb <*> Proofview.tclUNIT v diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index b9330ff007..2b129ad89c 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -187,9 +187,9 @@ module New = struct next_ident_away id ids let pf_get_hyp id gl = - let hyps = Proofview.Goal.hyps gl in + let hyps = Proofview.Goal.env gl in let sign = - try Context.Named.lookup id hyps + try Environ.lookup_named id hyps with Not_found -> raise (RefinerError (NoSuchHyp id)) in sign diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index fa7acd00ab..dc5be08a37 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -181,7 +181,7 @@ let rec classify_vernac e = | VernacReserve _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacUnsetOption _ | VernacSetOption _ + | VernacUnsetOption _ | VernacSetOption _ | VernacSetAppendOption _ | VernacAddOption _ | VernacRemoveOption _ | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ diff --git a/tactics/auto.ml b/tactics/auto.ml index 962af4b5c5..a6dc64b4e4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -269,10 +269,10 @@ let pr_info_nop = function let pr_dbg_header = function | (Off,_,_) -> mt () - | (Debug,0,_) -> str "(* debug trivial : *)" - | (Debug,_,_) -> str "(* debug auto : *)" - | (Info,0,_) -> str "(* info trivial : *)" - | (Info,_,_) -> str "(* info auto : *)" + | (Debug,0,_) -> str "(* debug trivial: *)" + | (Debug,_,_) -> str "(* debug auto: *)" + | (Info,0,_) -> str "(* info trivial: *)" + | (Info,_,_) -> str "(* info auto: *)" let tclTRY_dbg d tac = let (level, _, _) = d in @@ -375,7 +375,7 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") @@ -394,7 +394,14 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Extern tacast -> conclPattern concl p tacast in - tclLOG dbg (fun () -> pr_hint t) (run_hint t tactic) + let pr_hint () = + let origin = match dbname with + | None -> mt () + | Some n -> str " (in " ++ str n ++ str ")" + in + pr_hint t ++ origin + in + tclLOG dbg pr_hint (run_hint t tactic) and trivial_resolve dbg mod_delta db_list local_db cl = try diff --git a/tactics/auto.mli b/tactics/auto.mli index 1608a0ea63..5384140c2a 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -15,8 +15,6 @@ open Pattern open Decl_kinds open Hints -val priority : ('a * full_hint) list -> ('a * full_hint) list - val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8d6c085e63..0944cbe38f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -43,7 +43,11 @@ let typeclasses_modulo_eta = ref false let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta -let typeclasses_limit_intros = ref false +(** When this flag is enabled, the resolution of type classes tries to avoid + useless introductions. This is no longer useful since we have eta, but is + here for compatibility purposes. Another compatibility issues is that the + cost (in terms of search depth) can differ. *) +let typeclasses_limit_intros = ref true let set_typeclasses_limit_intros d = (:=) typeclasses_limit_intros d let get_typeclasses_limit_intros () = !typeclasses_limit_intros @@ -55,31 +59,22 @@ let typeclasses_iterative_deepening = ref false let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening -let get_compat_version d = - match d with - | "8.5" -> Flags.V8_5 - | _ -> Flags.Current - -let typeclasses_unif_compat = ref Flags.V8_5 -let set_typeclasses_unif_compat d = - if d == Flags.Current then set_typeclasses_limit_intros false - else set_typeclasses_limit_intros true; - (:=) typeclasses_unif_compat d - -let get_typeclasses_unif_compat () = !typeclasses_unif_compat -let set_typeclasses_unif_compat_string d = - set_typeclasses_unif_compat (get_compat_version d) -let get_typeclasses_unif_compat_string () = - Flags.pr_version (get_typeclasses_unif_compat ()) - -let typeclasses_compat = ref Flags.Current -let set_typeclasses_compat d = (:=) typeclasses_compat d -let get_typeclasses_compat () = !typeclasses_compat -let set_typeclasses_compat_string d = - set_typeclasses_compat (get_compat_version d) - -let get_typeclasses_compat_string () = - Flags.pr_version (get_typeclasses_compat ()) +(** [typeclasses_filtered_unif] governs the unification algorithm used by type + classes. If enabled, a new algorithm based on pattern filtering and refine + will be used. When disabled, the previous algorithm based on apply will be + used. *) +let typeclasses_filtered_unification = ref false +let set_typeclasses_filtered_unification d = + (:=) typeclasses_filtered_unification d +let get_typeclasses_filtered_unification () = + !typeclasses_filtered_unification + +(** [typeclasses_legacy_resolution] falls back to the 8.5 resolution algorithm, + instead of the 8.6 one which uses the native backtracking facilities of the + proof engine. *) +let typeclasses_legacy_resolution = ref false +let set_typeclasses_legacy_resolution d = (:=) typeclasses_legacy_resolution d +let get_typeclasses_legacy_resolution () = !typeclasses_legacy_resolution let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0) let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false @@ -133,22 +128,22 @@ let _ = optwrite = set_typeclasses_iterative_deepening; } let _ = - declare_string_option + declare_bool_option { optsync = true; optdepr = false; optname = "compat"; - optkey = ["Typeclasses";"Compatibility"]; - optread = get_typeclasses_compat_string; - optwrite = set_typeclasses_compat_string; } + optkey = ["Typeclasses";"Legacy";"Resolution"]; + optread = get_typeclasses_legacy_resolution; + optwrite = set_typeclasses_legacy_resolution; } let _ = - declare_string_option + declare_bool_option { optsync = true; optdepr = false; optname = "compat"; - optkey = ["Typeclasses";"Unification";"Compatibility"]; - optread = get_typeclasses_unif_compat_string; - optwrite = set_typeclasses_unif_compat_string; } + optkey = ["Typeclasses";"Filtered";"Unification"]; + optread = get_typeclasses_filtered_unification; + optwrite = set_typeclasses_filtered_unification; } let set_typeclasses_debug = declare_bool_option @@ -400,7 +395,7 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = function | Res_pf (term,cl) -> - if get_typeclasses_unif_compat () = Flags.Current then + if get_typeclasses_filtered_unification () then let tac = with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> @@ -410,13 +405,13 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = else let tac = with_prods nprods poly (term,cl) (unify_resolve poly flags) in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf (term,cl) -> - if get_typeclasses_unif_compat () = Flags.Current then + if get_typeclasses_filtered_unification () then let tac = (with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> (matches_pattern concl p) <*> @@ -425,7 +420,7 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = else let tac = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) @@ -445,7 +440,7 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in let pp = match p with - | Some pat when get_typeclasses_unif_compat () = Flags.Current -> + | Some pat when get_typeclasses_filtered_unification () -> str " with pattern " ++ Printer.pr_constr_pattern pat | _ -> mt () in @@ -1293,7 +1288,7 @@ let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Proofview.V82.tactic (fun gl -> try V85.eauto85 depth ~only_classes ~st dbs gl @@ -1419,10 +1414,10 @@ let resolve_all_evars debug depth unique env p oevd do_split fail = let p = select_and_update_evars p oevd (in_comp comp) in try let evd' = - if get_typeclasses_compat () = Flags.Current then - Search.typeclasses_resolve debug depth unique p evd - else + if get_typeclasses_legacy_resolution () then V85.resolve_all_evars_once debug depth unique p evd + else + Search.typeclasses_resolve debug depth unique p evd in if has_undefined p oevd evd' then raise Unresolved; docomp evd' comps @@ -1467,12 +1462,13 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let st = Hint_db.transparent_state hints in let depth = get_typeclasses_depth () in let gls' = - if get_typeclasses_compat () = Flags.Current then + if get_typeclasses_legacy_resolution () then + V85.eauto85 depth ~st [hints] gls + else try Proofview.V82.of_tactic (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found - else V85.eauto85 depth ~st [hints] gls in let evd = sig_sig gls' in let t' = let (ev, inst) = destEvar t in diff --git a/tactics/eauto.ml b/tactics/eauto.ml index ba9a2d95c8..c6d2448679 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -282,7 +282,8 @@ module SearchProblem = struct in let rec_tacs = let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + let concl = Reductionops.nf_evar (project g)(pf_concl g) in + filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) concl) in List.map (fun (lgls, cost, pp) -> @@ -350,8 +351,8 @@ let pr_info_nop = function let pr_dbg_header = function | Off -> () - | Debug -> Feedback.msg_debug (str "(* debug eauto : *)") - | Info -> Feedback.msg_debug (str "(* info eauto : *)") + | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") + | Info -> Feedback.msg_debug (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () diff --git a/tactics/equality.ml b/tactics/equality.ml index 3e5b7b65ff..e9d08d7375 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -701,16 +701,16 @@ let replace_in_clause_maybe_by c1 c2 cl tac_opt = exception DiscrFound of (constructor * int) list * constructor * constructor -let injection_on_proofs = ref false +let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection on prop arguments"; - optkey = ["Injection";"On";"Proofs"]; - optread = (fun () -> !injection_on_proofs) ; - optwrite = (fun b -> injection_on_proofs := b) } + optkey = ["Keep";"Proof";"Equalities"]; + optread = (fun () -> !keep_proof_equalities_for_injection) ; + optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = @@ -755,7 +755,7 @@ let find_positions env sigma t1 t2 = project env sorts posn t1_0 t2_0 in try - let sorts = if !injection_on_proofs then [InSet;InType;InProp] + let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) @@ -1389,7 +1389,10 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = | Inl _ -> tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> - let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in + let suggestion = + if !keep_proof_equalities_for_injection then + "" else + " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> tclZEROMSG (str"Nothing to inject.") @@ -1761,35 +1764,38 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let test decl = + let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with - | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> + | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> + Some (get_id decl) + | _, Var z when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None in let hyps = Proofview.Goal.hyps gl in - List.rev (List.map_filter test hyps) + List.rev (List.map_filter select_equation_name hyps) in (* Second step: treat equations *) let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with - | Var x', _ when not (occur_term x y) -> + | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (occur_term y x) -> + | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () diff --git a/tactics/hints.ml b/tactics/hints.ml index 8f3eb5eb51..89ecc6c0b2 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -108,6 +108,7 @@ type 'a with_metadata = { poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) + db : string option; (** The database from which the hint comes *) code : 'a; (* the tactic to apply when the concl matches pat *) } @@ -410,7 +411,35 @@ let rec subst_hints_path subst hp = if p' == p && q' == q then hp else PathOr (p', q') | _ -> hp -module Hint_db = struct +type hint_db_name = string + +module Hint_db : +sig +type t +val empty : ?name:hint_db_name -> transparent_state -> bool -> t +val find : global_reference -> t -> search_entry +val map_none : t -> full_hint list +val map_all : global_reference -> t -> full_hint list +val map_existential : (global_reference * constr array) -> constr -> t -> full_hint list +val map_eauto : (global_reference * constr array) -> constr -> t -> full_hint list +val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list +val add_one : env -> evar_map -> hint_entry -> t -> t +val add_list : env -> evar_map -> hint_entry list -> t -> t +val remove_one : global_reference -> t -> t +val remove_list : global_reference list -> t -> t +val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit +val use_dn : t -> bool +val transparent_state : t -> transparent_state +val set_transparent_state : t -> transparent_state -> t +val add_cut : hints_path -> t -> t +val add_mode : global_reference -> hint_mode array -> t -> t +val cut : t -> hints_path +val unfolds : t -> Id.Set.t * Cset.t +val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> + t -> 'a -> 'a + +end = +struct type t = { hintdb_state : Names.transparent_state; @@ -421,20 +450,22 @@ module Hint_db = struct hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) - hintdb_nopat : (global_reference option * stored_data) list + hintdb_nopat : (global_reference option * stored_data) list; + hintdb_name : string option; } let next_hint_id db = let h = db.hintdb_max_id in { db with hintdb_max_id = succ db.hintdb_max_id }, h - let empty st use_dn = { hintdb_state = st; + let empty ?name st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; - hintdb_nopat = [] } + hintdb_nopat = []; + hintdb_name = name; } let find key db = try Constr_map.find key db.hintdb_map @@ -502,7 +533,7 @@ module Hint_db = struct | _ -> false let addkv gr id v db = - let idv = id, v in + let idv = id, { v with db = db.hintdb_name } in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && is_unfold v.code.obj then None else Some gr @@ -606,8 +637,6 @@ type hint_db = Hint_db.t type hint_db_table = hint_db Hintdbmap.t ref -type hint_db_name = string - (** Initially created hint databases, for typeclasses and rewrite *) let typeclasses_db = "typeclass_instances" @@ -684,6 +713,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = poly = poly; pat = Some pat; name = name; + db = None; code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = @@ -704,6 +734,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, poly = poly; pat = Some pat; name = name; + db = None; code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; @@ -715,6 +746,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, poly = poly; pat = Some pat; name = name; + db = None; code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" @@ -799,6 +831,7 @@ let make_unfold eref = poly = false; pat = None; name = PathHints [g]; + db = None; code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = @@ -809,6 +842,7 @@ let make_extern pri pat tacast = poly = false; pat = pat; name = PathAny; + db = None; code = with_uid (Extern tacast) }) let make_mode ref m = @@ -832,6 +866,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; + db = None; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -845,7 +880,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let get_db dbname = try searchtable_map dbname - with Not_found -> Hint_db.empty empty_transparent_state false + with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false let add_hint dbname hintlist = let check (_, h) = @@ -905,7 +940,7 @@ type hint_obj = { let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with - | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) + | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddHints hints -> add_hint name hints | RemoveHints grs -> remove_hint name grs @@ -1262,11 +1297,11 @@ let make_db_list dbnames = let pr_hint_elt (c, _, _) = pr_constr c let pr_hint h = match h.obj with - | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c) - | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c) + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) | Res_pf_THEN_trivial_fail (c, _) -> - (str"apply " ++ pr_hint_elt c ++ str" ; trivial") + (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = diff --git a/tactics/hints.mli b/tactics/hints.mli index 6f5ee8ba5e..411540aa1b 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -43,11 +43,14 @@ type hints_path_atom = (* For forward hints, their names is the list of projections *) | PathAny +type hint_db_name = string + type 'a with_metadata = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) + db : hint_db_name option; code : 'a; (** the tactic to apply when the concl matches pat *) } @@ -77,7 +80,7 @@ val pp_hint_mode : hint_mode -> Pp.std_ppcmds module Hint_db : sig type t - val empty : transparent_state -> bool -> t + val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry val map_none : t -> full_hint list @@ -113,8 +116,6 @@ module Hint_db : val unfolds : t -> Id.Set.t * Cset.t end -type hint_db_name = string - type hint_db = Hint_db.t type hnf = bool diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 642bf520b1..40b600c890 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -202,11 +202,11 @@ let inversion_scheme env sigma t sort dep_option inv_op = tclTHEN intro (onLastHypId inv_op)) pf) in let pfterm = List.hd (Proof.partial_proof pf) in - let global_named_context = Global.named_context () in + let global_named_context = Global.named_context_val () in let ownSign = ref begin fold_named_context (fun env d sign -> - if mem_named_context (get_id d) global_named_context then sign + if mem_named_context_val (get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 87fdcf14d4..66da9ee182 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -322,7 +322,7 @@ module New = struct try Refiner.catch_failerror e; tclUNIT () - with e -> tclZERO e + with e when CErrors.noncritical e -> tclZERO e (* spiwack: I chose to give the Ltac + the same semantics as [Proofview.tclOR], however, for consistency with the or-else diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2d901c2dbc..893f33f1a8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -48,7 +48,11 @@ let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost -let typ_of env sigma c = Retyping.get_type_of env (Sigma.to_evar_map sigma) c +let typ_of env sigma c = + let open Retyping in + try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c + with RetypeError e -> + user_err_loc (Loc.ghost, "", print_retype_error e) open Goptions @@ -179,10 +183,10 @@ let introduction ?(check=true) id = let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in - let hyps = Proofview.Goal.hyps gl in + let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in - let () = if check && mem_named_context id hyps then + let () = if check && mem_named_context_val id hyps then errorlabstrm "Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in @@ -518,7 +522,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; - if mem_named_context f (named_context_of_val sign) then + if mem_named_context_val f sign then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth @@ -571,7 +575,7 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> | [] -> sign | (f, ar) :: oth -> let open Context.Named.Declaration in - if mem_named_context f (named_context_of_val sign) then + if mem_named_context_val f sign then error "Name already used in the environment."; mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in @@ -1937,9 +1941,7 @@ let exact_check c = let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - Refine.refine ~unsafe:true { run = begin fun sigma -> - Sigma.here (Term.mkCast (c, cast, concl)) sigma - end } + exact_no_check (Term.mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c @@ -1976,7 +1978,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } + exact_no_check (mkVar (get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -2793,7 +2795,7 @@ let old_generalize_dep ?(with_let=false) c gl = let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with - | Var id when mem_named_context id sign && not (Id.List.mem id init_ids) + | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in @@ -2807,6 +2809,8 @@ let old_generalize_dep ?(with_let=false) c gl = in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in + (** Check that the generalization is indeed well-typed *) + let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; @@ -2819,10 +2823,12 @@ let generalize_dep ?(with_let = false) c = (** *) let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in + let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) @@ -2943,8 +2949,8 @@ let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let xval = match Context.Named.lookup x hyps with + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in + let xval = match Environ.lookup_named x env with | LocalAssum _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval @@ -4366,7 +4372,7 @@ let induction_gen clear_flag isrec with_evars elim let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = - isVar c && not (mem_named_context (destVar c) (Global.named_context())) + isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env ccl in @@ -4413,7 +4419,7 @@ let induction_gen_l isrec with_evars elim names lc = | [] -> Proofview.tclUNIT () | c::l' -> match kind_of_term c with - | Var id when not (mem_named_context id (Global.named_context())) + | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' @@ -4835,7 +4841,7 @@ let abstract_subproof id gk tac = let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let current_sign = Global.named_context() + let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in @@ -4843,8 +4849,8 @@ let abstract_subproof id gk tac = List.fold_right (fun d (s1,s2) -> let id = get_id d in - if mem_named_context id current_sign && - interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d + if mem_named_context_val id current_sign && + interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in diff --git a/test-suite/Makefile b/test-suite/Makefile index a40ea80ae4..b32071e802 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -51,7 +51,7 @@ SINGLE_QUOTE=" get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) # get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop has_compile_flag = $(filter "-compile",$(call get_coq_prog_args,$(1))) -has_profile_ltac_or_compile_flag = $(filter "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) +has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqc),$(command)) @@ -281,6 +281,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ | grep -v "^<W>" \ + | sed 's/File "[^"]*"/File "stdin"/' \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ @@ -304,16 +305,19 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ | grep -v "^<W>" \ - | sed -e 's/\s*[0-9]*\.[0-9][0-9]*\s*//g' \ + | sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \ -e 's/\s*0\.\s*//g' \ -e 's/\s*[-+]nan\s*//g' \ -e 's/\s*[-+]inf\s*//g' \ + -e 's/^[^a-zA-Z]*//' \ + | sort \ > $$tmpoutput; \ - sed -e 's/\s*[0-9]*\.[0-9][0-9]*\s*//g' \ + sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \ -e 's/\s*0\.\s*//g' \ -e 's/\s*[-+]nan\s*//g' \ -e 's/\s*[-+]inf\s*//g' \ - $*.out > $$tmpexpected; \ + -e 's/^[^a-zA-Z]*//' \ + $*.out | sort > $$tmpexpected; \ diff -b -u $$tmpexpected $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ diff --git a/test-suite/bugs/closed/4416.v b/test-suite/bugs/closed/4416.v new file mode 100644 index 0000000000..b97a8ce640 --- /dev/null +++ b/test-suite/bugs/closed/4416.v @@ -0,0 +1,3 @@ +Goal exists x, x. +unshelve refine (ex_intro _ _ _); match goal with _ => refine (_ _) end. +(* Error: Incorrect number of goals (expected 2 tactics). *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4464.v b/test-suite/bugs/closed/4464.v new file mode 100644 index 0000000000..f8e9405d93 --- /dev/null +++ b/test-suite/bugs/closed/4464.v @@ -0,0 +1,4 @@ +Goal True -> True. +Proof. + intro H'. + let H := H' in destruct H; try destruct H. diff --git a/test-suite/bugs/closed/4471.v b/test-suite/bugs/closed/4471.v new file mode 100644 index 0000000000..36efc42d47 --- /dev/null +++ b/test-suite/bugs/closed/4471.v @@ -0,0 +1,6 @@ +Goal forall (A B : Type) (P : forall _ : prod A B, Type) (a : A) (b : B) (p p0 : forall (x : A) (x' : B), P (@pair A B x x')), + @eq (P (@pair A B a b)) (p (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b))) + (p0 (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b))). +Proof. + intros. + Fail generalize dependent (a, b). diff --git a/test-suite/bugs/closed/4529.v b/test-suite/bugs/closed/4529.v new file mode 100644 index 0000000000..8b3c24fec6 --- /dev/null +++ b/test-suite/bugs/closed/4529.v @@ -0,0 +1,45 @@ +(* File reduced by coq-bug-finder from original input, then from 1334 lines to 1518 lines, then from 849 lines to 59 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 22 2016 18:20:47 with OCaml 4.02.3 + coqtop version r-schnelltop:/home/r/src/coq/coq,(HEAD detached at V8.5) (5e23fb90b39dfa014ae5c4fb46eb713cca09dbff) *) +Require Coq.Setoids.Setoid. +Import Coq.Setoids.Setoid. + +Class Equiv A := equiv: relation A. +Infix "≡" := equiv (at level 70, no associativity). +Notation "(≡)" := equiv (only parsing). + +(* If I remove this line, everything compiles. *) +Set Primitive Projections. + +Class Dist A := dist : nat -> relation A. +Notation "x ={ n }= y" := (dist n x y) + (at level 70, n at next level, format "x ={ n }= y"). + +Record CofeMixin A `{Equiv A, Dist A} := { + mixin_equiv_dist x y : x ≡ y <-> forall n, x ={n}= y; + mixin_dist_equivalence n : Equivalence (dist n); +}. + +Structure cofeT := CofeT { + cofe_car :> Type; + cofe_equiv : Equiv cofe_car; + cofe_dist : Dist cofe_car; + cofe_mixin : CofeMixin cofe_car +}. +Existing Instances cofe_equiv cofe_dist. +Arguments cofe_car : simpl never. + +Section cofe_mixin. + Context {A : cofeT}. + Implicit Types x y : A. + Lemma equiv_dist x y : x ≡ y <-> forall n, x ={n}= y. +Admitted. +End cofe_mixin. + Context {A : cofeT}. + Global Instance cofe_equivalence : Equivalence ((≡) : relation A). + Proof. + split. + * + intros x. +apply equiv_dist. + diff --git a/test-suite/bugs/closed/4661.v b/test-suite/bugs/closed/4661.v new file mode 100644 index 0000000000..03d2350a69 --- /dev/null +++ b/test-suite/bugs/closed/4661.v @@ -0,0 +1,10 @@ +Module Type Test. + Parameter t : Type. +End Test. + +Module Type Func (T:Test). + Parameter x : Type. +End Func. + +Module Shortest_path (T : Test). +Print Func. diff --git a/test-suite/bugs/closed/4762.v b/test-suite/bugs/closed/4762.v new file mode 100644 index 0000000000..7a87b07a8e --- /dev/null +++ b/test-suite/bugs/closed/4762.v @@ -0,0 +1,24 @@ +Inductive myand (P Q : Prop) := myconj : P -> Q -> myand P Q. + +Lemma foo P Q R : R = myand P Q -> P -> Q -> R. +Proof. intros ->; constructor; auto. Qed. + +Hint Extern 0 (myand _ _) => eapply foo; [reflexivity| |] : test1. + +Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R). +Proof. + intros. + eauto with test1. +Qed. + +Hint Extern 0 => + match goal with + | |- myand _ _ => eapply foo; [reflexivity| |] + end : test2. + +Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R). +Proof. + intros. + eauto with test2. (* works *) +Qed. + diff --git a/test-suite/bugs/closed/4763.v b/test-suite/bugs/closed/4763.v new file mode 100644 index 0000000000..ae8ed0e6e8 --- /dev/null +++ b/test-suite/bugs/closed/4763.v @@ -0,0 +1,13 @@ +Require Import Coq.Arith.Arith Coq.Classes.Morphisms Coq.Classes.RelationClasses. +Coercion is_true : bool >-> Sortclass. +Global Instance: Transitive leb. +Admitted. + +Goal forall x y z, leb x y -> leb y z -> True. + intros ??? H H'. + lazymatch goal with + | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ] + => pose proof (transitivity H H' : is_true (R x z)) + end. + exact I. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4863.v b/test-suite/bugs/closed/4863.v new file mode 100644 index 0000000000..e884355fde --- /dev/null +++ b/test-suite/bugs/closed/4863.v @@ -0,0 +1,32 @@ +Require Import Classes.DecidableClass. + +Inductive Foo : Set := +| foo1 | foo2. + +Instance Decidable_sumbool : forall P, {P}+{~P} -> Decidable P. +Proof. + intros P H. + refine (Build_Decidable _ (if H then true else false) _). + intuition congruence. +Qed. + +Hint Extern 100 ({?A = ?B}+{~ ?A = ?B}) => abstract (abstract (abstract (decide equality))) : typeclass_instances. + +Goal forall (a b : Foo), {a=b}+{a<>b}. +intros. +abstract (abstract (decide equality)). (*abstract works here*) +Qed. + +Check ltac:(abstract (exact I)) : True. + +Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). +intros. +split. typeclasses eauto. typeclasses eauto. Qed. + +Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). +intros. +split. +refine _. +refine _. +Defined. +(*fails*) diff --git a/test-suite/bugs/closed/4869.v b/test-suite/bugs/closed/4869.v new file mode 100644 index 0000000000..6d21b66fe9 --- /dev/null +++ b/test-suite/bugs/closed/4869.v @@ -0,0 +1,18 @@ +Universes i. + +Fail Constraint i < Set. +Fail Constraint i <= Set. +Fail Constraint i = Set. +Constraint Set <= i. +Constraint Set < i. +Fail Constraint i < j. (* undeclared j *) +Fail Constraint i < Type. (* anonymous *) + +Set Universe Polymorphism. + +Section Foo. + Universe j. + Constraint Set < j. + + Definition foo := Type@{j}. +End Foo.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4970.v b/test-suite/bugs/closed/4970.v new file mode 100644 index 0000000000..7a896582f5 --- /dev/null +++ b/test-suite/bugs/closed/4970.v @@ -0,0 +1,3 @@ +(* Check "{{" is not confused with "{" in notations *) +Reserved Notation "x {{ y }}" (at level 40). +Notation "x {{ y }}" := (x y) (only parsing). diff --git a/test-suite/bugs/closed/5045.v b/test-suite/bugs/closed/5045.v new file mode 100644 index 0000000000..dc38738d8f --- /dev/null +++ b/test-suite/bugs/closed/5045.v @@ -0,0 +1,3 @@ +Axiom silly : 1 = 1 -> nat -> nat. +Goal forall pf : 1 = 1, silly pf 0 = 0 -> True. + Fail generalize (@eq nat). diff --git a/test-suite/bugs/closed/5066.v b/test-suite/bugs/closed/5066.v new file mode 100644 index 0000000000..eed7f0f3ff --- /dev/null +++ b/test-suite/bugs/closed/5066.v @@ -0,0 +1,7 @@ +Require Import Vector. + +Fail Program Fixpoint vector_rev {A : Type} {n1 n2 : nat} (v1 : Vector.t A n1) (v2 : Vector.t A n2) : Vector.t A (n1+n2) := + match v1 with + | nil _ => v2 + | cons _ e n' sv => vector_rev sv (cons A e n2 v2) + end. diff --git a/test-suite/bugs/closed/5123.v b/test-suite/bugs/closed/5123.v new file mode 100644 index 0000000000..bcde510ee6 --- /dev/null +++ b/test-suite/bugs/closed/5123.v @@ -0,0 +1,33 @@ +(* IN 8.5pl2 and 8.6 (4da2131), the following shows different typeclass resolution behaviors following an unshelve tactical vs. an Unshelve command: *) + +(*Pose an open constr to prevent immediate typeclass resolution in holes:*) +Tactic Notation "opose" open_constr(x) "as" ident(H) := pose x as H. + +Inductive vect A : nat -> Type := +| vnil : vect A 0 +| vcons : forall (h:A) (n:nat), vect A n -> vect A (S n). + +Class Eqdec A := eqdec : forall a b : A, {a=b}+{a<>b}. + +Require Bool. + +Instance Bool_eqdec : Eqdec bool := Bool.bool_dec. + +Context `{vect_sigT_eqdec : forall A : Type, Eqdec A -> Eqdec {a : nat & vect A a}}. + +Typeclasses eauto := debug. + +Goal True. + unshelve opose (@vect_sigT_eqdec _ _ _ _) as H. + all:cycle 2. + eapply existT. (*BUG: Why does this do typeclass resolution in the evar?*) + Focus 5. +Abort. + +Goal True. + opose (@vect_sigT_eqdec _ _ _ _) as H. + Unshelve. + all:cycle 3. + eapply existT. (*This does no typeclass resultion, which is correct.*) + Focus 5. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/5145.v b/test-suite/bugs/closed/5145.v new file mode 100644 index 0000000000..0533d21e0c --- /dev/null +++ b/test-suite/bugs/closed/5145.v @@ -0,0 +1,10 @@ +Class instructions := + { + W : Type; + ldi : nat -> W + }. + +Fail Definition foo := + let y2 := ldi 0 in + let '(CF, _) := (true, 0) in + y2. diff --git a/test-suite/output-modulo-time/ltacprof.v b/test-suite/output-modulo-time/ltacprof.v index d79451f0f7..6611db70e2 100644 --- a/test-suite/output-modulo-time/ltacprof.v +++ b/test-suite/output-modulo-time/ltacprof.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-emacs" "-profile-ltac") -*- *) +(* -*- coq-prog-args: ("-emacs" "-profile-ltac-cutoff" "0.0") -*- *) Ltac sleep' := do 100 (do 100 (do 100 idtac)). Ltac sleep := sleep'. diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.out b/test-suite/output-modulo-time/ltacprof_cutoff.out new file mode 100644 index 0000000000..0cd5777ccf --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_cutoff.out @@ -0,0 +1,31 @@ +total time: 1.584s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +─sleep --------------------------------- 100.0% 100.0% 3 0.572s +─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +└foo1 ---------------------------------- 0.0% 63.9% 1 1.012s + +total time: 1.584s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─sleep --------------------------------- 100.0% 100.0% 3 0.572s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─foo0 ---------------------------------- 0.0% 31.3% 1 0.496s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s + ├─foo1 -------------------------------- 0.0% 63.9% 1 1.012s + │ ├─sleep ----------------------------- 32.6% 32.6% 1 0.516s + │ └─foo0 ------------------------------ 0.0% 31.3% 1 0.496s + │ └sleep ----------------------------- 31.3% 31.3% 1 0.496s + └─sleep ------------------------------- 36.1% 36.1% 1 0.572s + diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v new file mode 100644 index 0000000000..50131470eb --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -0,0 +1,12 @@ +(* -*- coq-prog-args: ("-emacs" "-profile-ltac") -*- *) +Require Coq.ZArith.BinInt. +Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). + +Ltac foo0 := idtac; sleep. +Ltac foo1 := sleep; foo0. +Ltac foo2 := sleep; foo1. +Goal True. + foo2. + Show Ltac Profile CutOff 47. + constructor. +Qed. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 815305581c..1633ad9765 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,20 +1,20 @@ -File "/home/gares/COQ/coq/test-suite/output/Arguments_renaming.v", line 1, characters 0-36: +File "stdin", line 1, characters 0-36: Warning: Ignoring rename of x into y. Only implicit arguments can be renamed. -[arguments-assert,vernacular] +[arguments-ignore-rename-nonimpl,vernacular] The command has indeed failed with message: Error: To rename arguments the "rename" flag must be specified. Argument A renamed to B. -File "/home/gares/COQ/coq/test-suite/output/Arguments_renaming.v", line 2, characters 0-25: +File "stdin", line 2, characters 0-25: Warning: Ignoring rename of A into T. Only implicit arguments can be renamed. -[arguments-assert,vernacular] -File "/home/gares/COQ/coq/test-suite/output/Arguments_renaming.v", line 2, characters 0-25: +[arguments-ignore-rename-nonimpl,vernacular] +File "stdin", line 2, characters 0-25: Warning: This command is just asserting the number and names of arguments of identity. If this is what you want add ': assert' to silence the warning. If you want to clear implicit arguments add ': clear implicits'. If you want to clear notation scopes add ': clear scopes' [arguments-assert,vernacular] -File "/home/gares/COQ/coq/test-suite/output/Arguments_renaming.v", line 4, characters 0-40: +File "stdin", line 4, characters 0-40: Warning: Ignoring rename of x into y. Only implicit arguments can be renamed. -[arguments-assert,vernacular] +[arguments-ignore-rename-nonimpl,vernacular] @eq_refl : forall (B : Type) (y : B), y = y eq_refl @@ -121,9 +121,9 @@ The command has indeed failed with message: Error: Argument z cannot be declared implicit. The command has indeed failed with message: Error: Extra argument y. -File "/home/gares/COQ/coq/test-suite/output/Arguments_renaming.v", line 53, characters 0-26: +File "stdin", line 53, characters 0-26: Warning: Ignoring rename of x into s. Only implicit arguments can be renamed. -[arguments-assert,vernacular] +[arguments-ignore-rename-nonimpl,vernacular] The command has indeed failed with message: Error: To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out index db464fd07e..751d5fcc48 100644 --- a/test-suite/output/PrintModule.out +++ b/test-suite/output/PrintModule.out @@ -2,3 +2,4 @@ Module N : S with Definition T := nat := M Module N : S with Module T := K := M +Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v index 999d9a9862..5f30f7cda6 100644 --- a/test-suite/output/PrintModule.v +++ b/test-suite/output/PrintModule.v @@ -32,3 +32,19 @@ Module N : S with Module T := K := M. Print Module N. End BAR. + +Module QUX. + +Module Type Test. + Parameter t : Type. +End Test. + +Module Type Func (T:Test). + Parameter x : T.t. +End Func. + +Module Shortest_path (T : Test). +Print Func. +End Shortest_path. + +End QUX. diff --git a/test-suite/output/qualification.out b/test-suite/output/qualification.out new file mode 100644 index 0000000000..3cf3c2d8fb --- /dev/null +++ b/test-suite/output/qualification.out @@ -0,0 +1,3 @@ +File "/home/pm/sources/coq/test-suite/output/qualification.v", line 19, characters 0-7: +Error: Signature components for label test do not match: expected type +"Top.M2.t = Top.M2.M.t" but found type "Top.M2.t = Top.M2.t". diff --git a/test-suite/output/qualification.v b/test-suite/output/qualification.v new file mode 100644 index 0000000000..d39097e2dd --- /dev/null +++ b/test-suite/output/qualification.v @@ -0,0 +1,19 @@ +Module Type T1. + Parameter t : Type. +End T1. + +Module Type T2. + Declare Module M : T1. + Parameter t : Type. + Parameter test : t = M.t. +End T2. + +Module M1 <: T1. + Definition t : Type := bool. +End M1. + +Module M2 <: T2. + Module M := M1. + Definition t : Type := nat. + Lemma test : t = t. Proof. reflexivity. Qed. +End M2. diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v index 356a67efec..8f95484cfd 100644 --- a/test-suite/success/Case13.v +++ b/test-suite/success/Case13.v @@ -87,41 +87,3 @@ Check fun (x : E) => match x with c => e c end. Inductive C' : bool -> Set := c' : C' true. Inductive E' (b : bool) : Set := e' :> C' b -> E' b. Check fun (x : E' true) => match x with c' => e' true c' end. - -(* Check use of the no-dependency strategy when a type constraint is - given (and when the "inversion-and-dependencies-as-evars" strategy - is not strong enough because of a constructor with a type whose - pattern structure is not refined enough for it to be captured by - the inversion predicate) *) - -Inductive K : bool -> bool -> Type := F : K true true | G x : K x x. - -Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y, P y -> Q y z) => - match y with - | F => f y H1 - | G _ => f y H2 - end : Q y z. - -(* Check use of the maximal-dependency-in-variable strategy even when - no explicit type constraint is given (and when the - "inversion-and-dependencies-as-evars" strategy is not strong enough - because of a constructor with a type whose pattern structure is not - refined enough for it to be captured by the inversion predicate) *) - -Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z) => - match y with - | F => f y true H1 - | G b => f y b H2 - end. - -(* Check use of the maximal-dependency-in-variable strategy for "Var" - variables *) - -Goal forall z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z), Q y z. -intros z P Q y H1 H2 f. -Show. -refine (match y with - | F => f y true H1 - | G b => f y b H2 - end). -Qed. diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v index 599b9566cb..6424fe92dd 100644 --- a/test-suite/success/CaseInClause.v +++ b/test-suite/success/CaseInClause.v @@ -24,3 +24,6 @@ Theorem foo : forall (n m : nat) (pf : n = m), (* Check redundant clause is removed *) Inductive I : nat * nat -> Type := C : I (0,0). Check fun x : I (1,1) => match x in I (y,z) return y = z with C => eq_refl end. + +(* An example of non-local inference of the type of an impossible case *) +Check (fun y n (x:Vector.t nat (S n)) => match x with a::_ => a | _ => y end) 2. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 8745cf2fbd..da2183841d 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -135,6 +135,21 @@ intros * [= H]. exact H. Abort. +(* Test the Keep Proof Equalities option. *) +Set Keep Proof Equalities. +Unset Structural Injection. + +Inductive pbool : Prop := Pbool1 | Pbool2. + +Inductive pbool_shell : Set := Pbsc : pbool -> pbool_shell. + +Goal Pbsc Pbool1 = Pbsc Pbool2 -> True. +injection 1. +match goal with + |- Pbool1 = Pbool2 -> True => idtac | |- True => fail +end. +Abort. + (* Injection does not project at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index dfa438d90a..3eaa04144f 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -5,7 +5,7 @@ Record Equ (A : Type) (R : A -> A -> Prop). Definition equiv {A} R (e : Equ A R) := R. Record Refl (A : Type) (R : A -> A -> Prop). Axiom equ_refl : forall A R (e : Equ A R), Refl _ (@equiv A R e). -Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [|shelve|] : foo. +Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [shelve|] : foo. Variable R : nat -> nat -> Prop. Lemma bas : Equ nat R. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index c9c7c611cc..4db547f4e4 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -117,7 +117,7 @@ Lemma simpl_plus_l_rr1 : Undo. Set Typeclasses Debug. Set Typeclasses Iterative Deepening. - Time typeclasses eauto 2 with nocore. Show Proof. + Time typeclasses eauto 6 with nocore. Show Proof. Undo. Time eauto. (* does EApply H *) Qed. diff --git a/test-suite/success/subst.v b/test-suite/success/subst.v index 8336f6a806..25ee81b587 100644 --- a/test-suite/success/subst.v +++ b/test-suite/success/subst.v @@ -23,3 +23,20 @@ subst. change (y = S (S y)) in H0. change (S y = y). Abort. + +(* A bug revealed by OCaml 4.03 warnings *) +(* fixes in 4e3d464 and 89ec88f for v8.5, 4e3d4646 and 89ec88f1e for v8.6 *) +Goal forall y, let x:=0 in y=x -> y=y. +intros * H; +(* This worked as expected *) +subst. +Fail clear H. +Abort. + +Goal forall y, let x:=0 in x=y -> y=y. +intros * H; +(* Before the fix, this unfolded x instead of + substituting y and erasing H *) +subst. +Fail clear H. +Abort. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index 490e95c918..74b416aae7 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -22,3 +22,26 @@ Global Unset Structural Injection. Global Unset Shrink Abstract. Global Unset Shrink Obligations. Global Set Refolding Reduction. + +(** The resolution algorithm for type classes has changed. *) +Global Set Typeclasses Legacy Resolution. +Global Set Typeclasses Limit Intros. +Global Unset Typeclasses Filtered Unification. + +(** In Coq 8.5, [] meant Vector, and [ ] meant list. Restore this + behavior, to allow user-defined [] to not override vector + notations. See https://coq.inria.fr/bugs/show_bug.cgi?id=4785. *) + +Require Coq.Lists.List. +Require Coq.Vectors.VectorDef. +Module Export Coq. +Module Export Vectors. +Module VectorDef. +Export Coq.Vectors.VectorDef. +Module VectorNotations. +Export Coq.Vectors.VectorDef.VectorNotations. +Notation "[]" := (VectorDef.nil _) : vector_scope. +End VectorNotations. +End VectorDef. +End Vectors. +End Coq. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index ad067eb3d8..1db6a71e81 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -357,17 +357,8 @@ the above form: | _ => idtac end. - (** [if t then t1 else t2] executes [t] and, if it does not - fail, then [t1] will be applied to all subgoals - produced. If [t] fails, then [t2] is executed. *) - Tactic Notation - "if" tactic(t) - "then" tactic(t1) - "else" tactic(t2) := - first [ t; first [ t1 | fail 2 ] | t2 ]. - Ltac abstract_term t := - if (is_var t) then fail "no need to abstract a variable" + tryif (is_var t) then fail "no need to abstract a variable" else (let x := fresh "x" in set (x := t) in *; try clearbody x). Ltac abstract_elements := @@ -478,11 +469,11 @@ the above form: repeat ( match goal with | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - if (change T with E.t in H) then fail - else if (change T with t in H) then fail + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail else clear H | H : ?P |- _ => - if prop (FSet_Prop P) holds by + tryif prop (FSet_Prop P) holds by (auto 100 with FSet_Prop) then fail else clear H @@ -747,7 +738,7 @@ the above form: | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => contradict H; fsetdec_body | H: ?P -> False |- ?Q -> False => - if prop (FSet_elt_Prop P) holds by + tryif prop (FSet_elt_Prop P) holds by (auto 100 with FSet_Prop) then (contradict H; fsetdec_body) else fsetdec_body diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index f2555791b2..9c622fd786 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -357,17 +357,8 @@ the above form: | _ => idtac end. - (** [if t then t1 else t2] executes [t] and, if it does not - fail, then [t1] will be applied to all subgoals - produced. If [t] fails, then [t2] is executed. *) - Tactic Notation - "if" tactic(t) - "then" tactic(t1) - "else" tactic(t2) := - first [ t; first [ t1 | fail 2 ] | t2 ]. - Ltac abstract_term t := - if (is_var t) then fail "no need to abstract a variable" + tryif (is_var t) then fail "no need to abstract a variable" else (let x := fresh "x" in set (x := t) in *; try clearbody x). Ltac abstract_elements := @@ -478,11 +469,11 @@ the above form: repeat ( match goal with | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - if (change T with E.t in H) then fail - else if (change T with t in H) then fail + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail else clear H | H : ?P |- _ => - if prop (MSet_Prop P) holds by + tryif prop (MSet_Prop P) holds by (auto 100 with MSet_Prop) then fail else clear H @@ -747,7 +738,7 @@ the above form: | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => contradict H; fsetdec_body | H: ?P -> False |- ?Q -> False => - if prop (MSet_elt_Prop P) holds by + tryif prop (MSet_elt_Prop P) holds by (auto 100 with MSet_Prop) then (contradict H; fsetdec_body) else fsetdec_body diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 6f8fc1b324..0115d8a544 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -434,14 +434,14 @@ Lemma eqb_compare x y : (x =? y) = match compare x y with Eq => true | _ => false end. Proof. apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. -destruct compare; now split. +now destruct compare. Qed. Lemma ltb_compare x y : (x <? y) = match compare x y with Lt => true | _ => false end. Proof. apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. -destruct compare; now split. +now destruct compare. Qed. Lemma leb_compare x y : diff --git a/tools/coqc.ml b/tools/coqc.ml index ecbbfefac6..b59bbdb1e0 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -107,7 +107,7 @@ let parse_args () = |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o" + |"-o"|"-profile-ltac-cutoff" as o) :: rem -> begin match rem with diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 180b836ea5..0561fc4b82 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -54,7 +54,7 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of constant +exception ParameterWithoutEquality of global_reference exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported @@ -181,7 +181,13 @@ let build_beq_scheme mode kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Safe_typing.empty_private_constants + | Var x -> + let eid = id_of_string ("eq_"^(string_of_id x)) in + let () = + try ignore (Environ.lookup_named eid env) + with Not_found -> raise (ParameterWithoutEquality (VarRef x)) + in + mkVar eid, Safe_typing.empty_private_constants | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> @@ -209,7 +215,7 @@ let build_beq_scheme mode kn = | LetIn _ -> raise (EqUnknown "LetIn") | Const kn -> (match Environ.constant_opt_value_in env kn with - | None -> raise (ParameterWithoutEquality (fst kn)) + | None -> raise (ParameterWithoutEquality (ConstRef (fst kn))) | Some c -> aux (applist (c,a))) | Proj _ -> raise (EqUnknown "Proj") | Construct _ -> raise (EqUnknown "Construct") diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index b6c66a1e84..fa5c61484e 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -21,7 +21,7 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of constant +exception ParameterWithoutEquality of Globnames.global_reference exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported diff --git a/toplevel/command.mli b/toplevel/command.mli index d353724294..616afb91f0 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -22,7 +22,7 @@ open Pfedit val do_universe : polymorphic -> Id.t Loc.located list -> unit val do_constraint : polymorphic -> - (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit (** {6 Hooks for Pcoq} *) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 69d68bd357..71e1f9593d 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -23,7 +23,7 @@ type input_buffer = { mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of beginning of lines *) - mutable tokens : Gram.parsable; (* stream of tokens *) + mutable tokens : Gram.coq_parsable; (* stream of tokens *) mutable start : int } (* stream count of the first char of the buffer *) (* Double the size of the buffer. *) @@ -274,9 +274,9 @@ let rec discard_to_dot () = | End_of_input -> raise End_of_input | e when CErrors.noncritical e -> () -let read_sentence () = +let read_sentence input = try - let (loc, _ as r) = Vernac.parse_sentence (top_buffer.tokens, None) in + let (loc, _ as r) = Vernac.parse_sentence input in CWarnings.set_current_loc loc; r with reraise -> let reraise = CErrors.push reraise in @@ -298,7 +298,8 @@ let do_vernac () = if !print_emacs then top_stderr (str (top_buffer.prompt())); resynch_buffer top_buffer; try - Vernac.eval_expr (read_sentence ()) + let input = (top_buffer.tokens, None) in + Vernac.eval_expr input (read_sentence input) with | End_of_input | CErrors.Quit -> top_stderr (fnl ()); raise CErrors.Quit diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 00554da308..e40353e0f9 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -18,7 +18,7 @@ type input_buffer = { mutable str : string; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) - mutable tokens : Pcoq.Gram.parsable; (** stream of tokens *) + mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *) mutable start : int } (** stream count of the first char of the buffer *) (** The input buffer of stdin. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 47d433d790..7a67e0951f 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -61,8 +61,7 @@ let init_color () = match colors with | None -> (** Default colors *) - Ppstyle.init_color_output (); - Feedback.set_logger Feedback.color_terminal_logger + Feedback.init_color_output () | Some "" -> (** No color output *) () @@ -70,8 +69,7 @@ let init_color () = (** Overwrite all colors *) Ppstyle.clear_styles (); Ppstyle.parse_config s; - Ppstyle.init_color_output (); - Feedback.set_logger Feedback.color_terminal_logger + Feedback.init_color_output () end let toploop_init = ref begin fun x -> @@ -332,9 +330,6 @@ let error_missing_arg s = let filter_opts = ref false let exitcode () = if !filter_opts then 2 else 0 -let verb_compat_ntn = ref false -let no_compat_ntn = ref false - let print_where = ref false let print_config = ref false let print_tags = ref false @@ -558,7 +553,6 @@ let parse_args arglist = |"-just-parsing" -> Vernac.just_parsing := true |"-m"|"--memory" -> memory_stat := true |"-noinit"|"-nois" -> load_init := false - |"-no-compat-notations" -> no_compat_ntn := true |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then @@ -576,7 +570,6 @@ let parse_args arglist = |"-unicode" -> add_require "Utf8_core" |"-v"|"--version" -> Usage.version (exitcode ()) |"--print-version" -> Usage.machine_readable_version (exitcode ()) - |"-verbose-compat-notations" -> verb_compat_ntn := true |"-where" -> print_where := true |"-xml" -> Flags.xml_export := true @@ -637,9 +630,6 @@ let init_toplevel arglist = inputstate (); Mltop.init_known_plugins (); engage (); - (* Be careful to set these variables after the inputstate *) - Syntax_def.set_verbose_compat_notations !verb_compat_ntn; -(* Syntax_def.set_compat_notations (not !no_compat_ntn); FIXME *) if (not !batch_mode || List.is_empty !compile_list) && Global.env_is_initial () then Option.iter Declaremods.start_library !toplevel_name; diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 6ee695bc24..56b4779555 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -516,7 +516,8 @@ let explain_cant_find_case_type env sigma c = let c = Evarutil.nf_evar sigma c in let env = make_all_name_different env in let pe = pr_lconstr_env env sigma c in - str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "." + str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++ + pe ++ str "." let explain_occur_check env sigma ev rhs = let rhs = Evarutil.nf_evar sigma rhs in diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index f9e6c207c3..e8ea617f45 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -161,7 +161,7 @@ let try_declare_scheme what f internal names kn = let msg = match fst e with | ParameterWithoutEquality cst -> alarm what internal - (str "Boolean equality not found for parameter " ++ pr_con cst ++ + (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ str".") | InductiveWithProduct -> alarm what internal diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index ce8798c713..008d5cf9f5 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -890,12 +890,12 @@ let warn_non_reversible_notation = (fun () -> strbrk "This notation will not be used for printing as it is not reversible.") -let is_not_printable onlyparse noninjective = function +let is_not_printable onlyparse nonreversible = function | NVar _ -> if not onlyparse then warn_notation_bound_to_variable (); true | _ -> - if not onlyparse && noninjective then + if not onlyparse && nonreversible then (warn_non_reversible_notation (); true) else onlyparse @@ -1093,7 +1093,10 @@ let contract_notation ntn = let rec aux ntn i = if i <= String.length ntn - 5 then let ntn' = - if String.is_sub "{ _ }" ntn i then + if String.is_sub "{ _ }" ntn i && + (i = 0 || ntn.[i-1] = ' ') && + (i = String.length ntn - 5 || ntn.[i+5] = ' ') + then String.sub ntn 0 i ^ "_" ^ String.sub ntn (i+5) (String.length ntn -i-5) else ntn in @@ -1182,12 +1185,11 @@ let add_notation_in_scope local df c mods scope = let nenv = { ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; - ninterp_only_parse = false; } in - let (acvars, ac) = interp_notation_constr nenv c in + let (acvars, ac, reversible) = interp_notation_constr nenv c in let interp = make_interpretation_vars recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in + let onlyparse = is_not_printable onlyparse (not reversible) ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1222,12 +1224,11 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) let nenv = { ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; - ninterp_only_parse = false; } in - let (acvars, ac) = interp_notation_constr ~impls nenv c in + let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in let interp = make_interpretation_vars recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in + let onlyparse = is_not_printable onlyparse (not reversible) ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1364,10 +1365,9 @@ let add_syntactic_definition ident (vars,c) local onlyparse = let nenv = { ninterp_var_type = i_vars; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } in - let nvars, pat = interp_notation_constr nenv c in - let () = nonprintable := nenv.ninterp_only_parse in + let nvars, pat, reversible = interp_notation_constr nenv c in + let () = nonprintable := not reversible in let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in List.map map vars, pat in diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index 0a5b92270f..b6690fe47b 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -411,7 +411,7 @@ let inMLModule : ml_module_object -> obj = let declare_ml_modules local l = let l = List.map mod_of_name l in - Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l}) + Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l}) let print_ml_path () = let l = !coq_mlpath_copy in diff --git a/toplevel/search.ml b/toplevel/search.ml index e670b59b79..921308f78a 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -155,8 +155,9 @@ let full_name_of_reference ref = DirPath.to_string dir ^ "." ^ Id.to_string id (** Whether a reference is blacklisted *) -let blacklist_filter ref env typ = +let blacklist_filter_aux () = let l = SearchBlacklist.elements () in + fun ref env typ -> let name = full_name_of_reference ref in let is_not_bl str = not (String.string_contains ~where:name ~what:str) in List.for_all is_not_bl l @@ -182,11 +183,11 @@ let search_about_filter query gr env typ = match query with let search_pattern gopt pat mods = let ans = ref [] in + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = pattern_filter pat ref env typ in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + pattern_filter pat ref env typ && + blacklist_filter ref env typ in let iter ref env typ = if filter ref env typ then plain_display ans ref env typ @@ -208,14 +209,12 @@ let search_rewrite gopt pat mods = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in let ans = ref [] in + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = - pattern_filter pat1 ref env typ || - pattern_filter pat2 ref env typ - in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + (pattern_filter pat1 ref env typ || + pattern_filter pat2 ref env typ) && + blacklist_filter ref env typ in let iter ref env typ = if filter ref env typ then plain_display ans ref env typ @@ -227,11 +226,11 @@ let search_rewrite gopt pat mods = let search_by_head gopt pat mods = let ans = ref [] in + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = head_filter pat ref env typ in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + head_filter pat ref env typ && + blacklist_filter ref env typ in let iter ref env typ = if filter ref env typ then plain_display ans ref env typ @@ -243,12 +242,13 @@ let search_by_head gopt pat mods = let search_about gopt items mods = let ans = ref [] in + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in - let f_module = module_filter mods ref env typ in - let f_about (b, i) = eqb b (search_about_filter i ref env typ) in - let f_blacklist = blacklist_filter ref env typ in - f_module && List.for_all f_about items && f_blacklist + module_filter mods ref env typ && + List.for_all + (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && + blacklist_filter ref env typ in let iter ref env typ = if filter ref env typ then plain_display ans ref env typ @@ -287,6 +287,7 @@ let interface_search = let (name, tpe, subtpe, mods, blacklist) = extract_flags [] [] [] [] false flags in + let blacklist_filter = blacklist_filter_aux () in let filter_function ref env constr = let id = Names.Id.to_string (Nametab.basename_of_global ref) in let path = Libnames.dirpath (Nametab.path_of_global ref) in @@ -305,13 +306,11 @@ let interface_search = let match_module (mdl, flag) = toggle (Libnames.is_dirpath_prefix_of mdl path) flag in - let in_blacklist = - blacklist || (blacklist_filter ref env constr) - in List.for_all match_name name && List.for_all match_type tpe && List.for_all match_subtype subtpe && - List.for_all match_module mods && in_blacklist + List.for_all match_module mods && + (blacklist || blacklist_filter ref env constr) in let ans = ref [] in let print_function ref env constr = @@ -342,3 +341,6 @@ let interface_search = in let () = generic_search glnum iter in !ans + +let blacklist_filter ref env typ = + blacklist_filter_aux () ref env typ diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 8f77aea440..de41f7b190 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -82,7 +82,7 @@ let print_usage_channel co command = \n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ \n stdout (if unset)\ \n -time display the time taken by each command\ -\n -profile-ltac display the time taken by each (sub)tactic\ +\n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ \n (use environment variable\ \n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 55f3a31a34..b8e44db9a7 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -124,34 +124,37 @@ let set_formatter_translator() = Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int -let pr_new_syntax loc ocom = +let pr_new_syntax_in_context loc ocom = let loc = Loc.unloc loc in if !beautify_file then set_formatter_translator(); let fs = States.freeze ~marshallable:`No in + (* Side-effect: order matters *) + let before = comment (CLexer.extract_comments (fst loc)) in let com = match ocom with | Some com -> Ppvernac.pr_vernac com | None -> mt() in + let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Feedback.msg_notice (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) + Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; Format.set_formatter_out_channel stdout +let pr_new_syntax (po,_) loc ocom = + (* Reinstall the context of parsing which includes the bindings of comments to locations *) + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context loc) ocom + let save_translator_coqdoc () = (* translator state *) let ch = !chan_beautify in - let cl = !Pp.comments in - let cs = CLexer.com_state() in (* end translator state *) let coqdocstate = CLexer.location_table () in - ch,cl,cs,coqdocstate + ch,coqdocstate -let restore_translator_coqdoc (ch,cl,cs,coqdocstate) = +let restore_translator_coqdoc (ch,coqdocstate) = if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; - Pp.comments := cl; - CLexer.restore_com_state cs; CLexer.restore_location_table coqdocstate (* For coqtop -time, we display the position in the file, @@ -182,7 +185,7 @@ let print_cmd_header loc com = Pp.pp_with !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () -let rec vernac_com checknav (loc,com) = +let rec vernac_com input checknav (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in @@ -194,7 +197,6 @@ let rec vernac_com checknav (loc,com) = if !Flags.beautify_file then begin chan_beautify := open_out (f^beautify_suffix); - Pp.comments := [] end; begin try @@ -214,13 +216,11 @@ let rec vernac_com checknav (loc,com) = in try checknav loc com; - if do_beautify () then pr_new_syntax loc (Some com); + if do_beautify () then pr_new_syntax input loc (Some com); (* XXX: This is not 100% correct if called from an IDE context *) if !Flags.time then print_cmd_header loc com; let com = if !Flags.time then VernacTime (loc,com) else com in - let a = CLexer.com_state () in - interp com; - CLexer.restore_com_state a + interp com with reraise -> let (reraise, info) = CErrors.push reraise in Format.set_formatter_out_channel stdout; @@ -240,7 +240,7 @@ and read_vernac_file verbosely s = while true do let loc_ast = parse_sentence input in CWarnings.set_current_loc (fst loc_ast); - vernac_com checknav loc_ast; + vernac_com input checknav loc_ast; done with any -> (* whatever the exception *) let (e, info) = CErrors.push any in @@ -249,7 +249,7 @@ and read_vernac_file verbosely s = match e with | End_of_input -> if do_beautify () then - pr_new_syntax (Loc.make_loc (max_int,max_int)) None + pr_new_syntax input (Loc.make_loc (max_int,max_int)) None | reraise -> iraise (disable_drop e, info) @@ -264,7 +264,7 @@ let checknav loc ast = if is_deep_navigation_vernac ast then user_error loc "Navigation commands forbidden in nested commands" -let eval_expr loc_ast = vernac_com checknav loc_ast +let eval_expr input loc_ast = vernac_com input checknav loc_ast (* XML output hooks *) let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore () diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 7bfddd9470..2fd86ddc22 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -11,7 +11,7 @@ (** Read a vernac command on the specified input (parse only). Raises [End_of_file] if EOF (or Ctrl-D) is reached. *) -val parse_sentence : Pcoq.Gram.parsable * in_channel option -> +val parse_sentence : Pcoq.Gram.coq_parsable * in_channel option -> Loc.t * Vernacexpr.vernac_expr (** Reads and executes vernac commands from a stream. @@ -21,7 +21,7 @@ exception End_of_input val just_parsing : bool ref -val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit +val eval_expr : Pcoq.Gram.coq_parsable * in_channel option -> Loc.t * Vernacexpr.vernac_expr -> unit (** Set XML hooks *) val xml_start_library : (unit -> unit) Hook.t diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 1d6278066a..feec23b50b 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -575,18 +575,18 @@ let vernac_inductive poly lo finite indl = | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> CErrors.error "The Variant keyword cannot be used to define a record type. Use Record instead." | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> - vernac_record (match b with Class true -> Class false | _ -> b) + vernac_record (match b with Class _ -> Class false | _ -> b) poly finite id bl c oc fs - | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> + | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) poly finite id bl c None [f] - | [ ( id , bl , c , Class true, _), _ ] -> - CErrors.error "Definitional classes must have a single method" - | [ ( id , bl , c , Class false, Constructors _), _ ] -> + | [ ( _ , _, _, Class _, Constructors _), [] ] -> CErrors.error "Inductive classes not supported" + | [ ( id , bl , c , Class _, _), _ :: _ ] -> + CErrors.error "where clause not supported for classes" | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> CErrors.error "where clause not supported for (co)inductive records" | _ -> let unpack = function @@ -980,7 +980,8 @@ let warn_arguments_assert = strbrk "If you want to clear notation scopes add ': clear scopes'") let warn_renaming_nonimplicit = - CWarnings.create ~name:"arguments-assert" ~category:"vernacular" + CWarnings.create ~name:"arguments-ignore-rename-nonimpl" + ~category:"vernacular" (fun (oldn, newn) -> strbrk "Ignoring rename of "++pr_id oldn++str" into "++pr_id newn++ strbrk ". Only implicit arguments can be renamed.") @@ -1011,7 +1012,9 @@ let vernac_declare_arguments locality r l nargs flags = | _::li, _::ld, _::ls -> check li ld ls | _ -> assert false in let () = match l with - | [[]] when List.exists ((<>) `Assert) flags -> () + | [[]] when List.exists ((<>) `Assert) flags || + (* Arguments f /. used to be allowed by mistake *) + (Flags.version_less_or_equal Flags.V8_5 && nargs >= 0) -> () | _ -> List.iter2 (check inf_names) (names :: rest) scopes in @@ -1150,7 +1153,6 @@ let vernac_declare_arguments locality r l nargs flags = let default_env () = { Notation_term.ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } let vernac_reserve bl = @@ -1159,7 +1161,7 @@ let vernac_reserve bl = let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in - let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in + let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1453,6 +1455,9 @@ let vernac_set_option locality key = function | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b +let vernac_set_append_option locality key s = + set_string_option_append_value_gen locality key s + let vernac_unset_option locality key = unset_option_value_gen locality key @@ -1922,6 +1927,7 @@ let interp ?proof ~loc locality poly c = | VernacSetOpacity qidl -> vernac_set_opacity locality qidl | VernacSetStrategy l -> vernac_set_strategy locality l | VernacSetOption (key,v) -> vernac_set_option locality key v + | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v | VernacUnsetOption key -> vernac_unset_option locality key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v @@ -1994,7 +2000,7 @@ let check_vernac_supports_locality c l = | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacSetOption _ | VernacUnsetOption _ + | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _ | VernacDeclareReduction _ | VernacExtend _ | VernacInductive _) -> () |