diff options
53 files changed, 1160 insertions, 509 deletions
@@ -120,6 +120,7 @@ Changes from V8.5pl2 to V8.5pl3 =============================== Critical bugfix + - #4876: Guard checker incompleteness when using primitive projections Other bugfixes @@ -128,7 +129,50 @@ Other bugfixes - #4673: regression in setoid_rewrite, unfolding let-ins for type unification. - #4754: Regression in setoid_rewrite, allow postponed unification problems to remain. - #4769: Anomaly with universe polymorphic schemes defined inside sections. -- #3886: Program: duplicate obligations of mutual fixpoints +- #3886: Program: duplicate obligations of mutual fixpoints. +- #4994: Documentation typo. +- #5008: Use the "md5" command on OpenBSD. +- #5007: Do not assume the "TERM" environment variable is always set. +- #4606: Output a break before a list only if there was an empty line. +- #5001: metas not cleaned properly in clenv_refine_in. +- #2336: incorrect glob data for module symbols (bug #2336). +- #4832: Remove extraneous dot in error message. +- Anomaly in printing a unification error message. +- #4947: Options which take string arguments are not backwards compatible. +- #4156: micromega cache files are now hidden files. +- #4871: interrupting par:abstract kills coqtop. +- #5043: [Admitted] lemmas pick up section variables. +- Fix name of internal refine ("simple refine"). +- #5062: probably a typo in Strict Proofs mode. +- #5065: Anomaly: Not a proof by induction. +- Restore native compiler optimizations, they were disabled since 8.5! +- #5077: failure on typing a fixpoint with evars in its type. +- Fix recursive notation bug. +- #5095: non relevant too strict test in let-in abstraction. +- Ensuring that the evar name is preserved by "rename". +- #4887: confusion between using and with in documentation of firstorder. +- Bug in subst with let-ins. +- #4762: eauto weaker than auto. +- Remove if_then_else (was buggy). Use tryif instead. +- #4970: confusion between special "{" and non special "{{" in notations. +- #4529: primitive projections unfolding. +- #4416: Incorrect "Error: Incorrect number of goals". +- #4863: abstract in typeclass hint fails. +- #5123: unshelve can impact typeclass resolution +- Fix a collision about the meta-variable ".." in recursive notations. +- Fix printing of info_auto. +- #3209: Not_found due to an occur-check cycle. +- #5097: status of evars refined by "clear" in ltac: closed wrt evars. +- #5150: Missing dependency of the test-suite subsystems in prerequisite. +- Fix a bug in error printing of unif constraints +- #3941: Do not stop propagation of signals when Coq is busy. +- #4822: Incorrect assertion in cbn. +- #3479 parsing of "{" and "}" when a keyword starts with "{" or "}". +- #5127: Memory corruption with the VM. +- #5102: bullets parsing broken by calls to parse_entry. + +Various documentation improvements + Changes from V8.5pl1 to V8.5pl2 =============================== diff --git a/META.coq b/META.coq new file mode 100644 index 000000000..5be69d5fd --- /dev/null +++ b/META.coq @@ -0,0 +1,249 @@ +description = "The Coq Proof Assistant Plugin API" +version = "8.6" + +directory = "" +requires = "camlp5" + +package "config" ( + + description = "Coq Configuration Variables" + version = "8.6" + + directory = "config" + +) + +package "lib" ( + + description = "Base Coq Library" + version = "8.6" + + directory = "lib" + + requires = "coq.config" + + archive(byte) = "clib.cma" + archive(byte) += "lib.cma" + + archive(native) = "clib.cmxa" + archive(native) += "lib.cmxa" + +) + +package "vm" ( + + description = "Coq VM" + + version = "8.6" + +# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq +# install. In a local one we'll want kernel/byterun, in a non-local +# one we want to set it to coqlib. We should thus generate this file +# at configure time, but let's hear for some more feedback from +# experts. + +# Enable for local native & byte builds +# directory = "kernel/byterun" + +# Enable for local byte builds and set up properly +# linkopts(byte) = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun" + +# Disable for local byte builds + linkopts(byte) = "-dllib -lcoqrun" + linkopts(native) = "-cclib -lcoqrun" + +) + +package "kernel" ( + + description = "The Coq's Kernel" + version = "8.6" + + directory = "kernel" + + requires = "coq.lib, coq.vm" + + archive(byte) = "kernel.cma" + archive(native) = "kernel.cmxa" + +) + +package "library" ( + + description = "Coq Libraries (vo) support" + version = "8.6" + + requires = "coq.kernel" + + directory = "library" + + archive(byte) = "library.cma" + archive(native) = "library.cmxa" + +) + +package "intf" ( + + description = "Coq Public Data Types" + version = "8.6" + + requires = "coq.library" + + directory = "intf" + +) + +package "engine" ( + + description = "Coq Libraries (vo) support" + version = "8.6" + + requires = "coq.library" + directory = "engine" + + archive(byte) = "engine.cma" + archive(native) = "engine.cmxa" + +) + +package "pretyping" ( + + description = "Coq Pretyper" + version = "8.6" + + requires = "coq.engine" + directory = "pretyping" + + archive(byte) = "pretyping.cma" + archive(native) = "pretyping.cmxa" + +) + +package "interp" ( + + description = "Coq Term Interpretation" + version = "8.6" + + requires = "coq.pretyping" + directory = "interp" + + archive(byte) = "interp.cma" + archive(native) = "interp.cmxa" + +) + +package "grammar" ( + + description = "Coq Base Grammar" + version = "8.6" + + requires = "coq.interp" + directory = "grammar" + + archive(byte) = "grammar.cma" + archive(native) = "grammar.cmxa" +) + +package "proofs" ( + + description = "Coq Proof Engine" + version = "8.6" + + requires = "coq.interp" + directory = "proofs" + + archive(byte) = "proofs.cma" + archive(native) = "proofs.cmxa" + +) + +package "parsing" ( + + description = "Coq Parsing Engine" + version = "8.6" + + requires = "coq.proofs" + directory = "parsing" + + archive(byte) = "parsing.cma" + archive(native) = "parsing.cmxa" + +) + +package "printing" ( + + description = "Coq Printing Libraries" + version = "8.6" + + requires = "coq.parsing" + directory = "printing" + + archive(byte) = "printing.cma" + archive(native) = "printing.cmxa" + +) + +package "tactics" ( + + description = "Coq Tactics" + version = "8.6" + + requires = "coq.printing" + directory = "tactics" + + archive(byte) = "tactics.cma" + archive(native) = "tactics.cmxa" + +) + +package "stm" ( + + description = "Coq State Transactional Machine" + version = "8.6" + + requires = "coq.tactics" + directory = "stm" + + archive(byte) = "stm.cma" + archive(native) = "stm.cmxa" + +) + +package "toplevel" ( + + description = "Coq Toplevel" + version = "8.6" + + requires = "coq.stm" + directory = "toplevel" + + archive(byte) = "toplevel.cma" + archive(native) = "toplevel.cmxa" + +) + +package "highparsing" ( + + description = "Coq Extra Parsing" + version = "8.6" + + requires = "coq.toplevel" + directory = "parsing" + + archive(byte) = "highparsing.cma" + archive(native) = "highparsing.cmxa" + +) + +package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.6" + + requires = "coq.highparsing" + directory = "ltac" + + archive(byte) = "ltac.cma" + archive(native) = "ltac.cmxa" + +) diff --git a/Makefile.install b/Makefile.install index 4dad8cf0d..4800ea0b9 100644 --- a/Makefile.install +++ b/Makefile.install @@ -18,7 +18,7 @@ ifeq ($(LOCAL),true) install: @echo "Nothing to install in a local build!" else -install: install-coq install-coqide install-doc-$(WITHDOC) +install: install-coq install-coqide install-doc-$(WITHDOC) install-meta endif # NOTA: for install-coqide, see Makefile.ide @@ -58,6 +58,7 @@ endif .PHONY: install-coq install-binaries install-byte install-opt .PHONY: install-tools install-library install-devfiles .PHONY: install-coq-info install-coq-manpages install-emacs install-latex +.PHONY: install-meta install-coq: install-binaries install-library install-coq-info install-devfiles @@ -140,6 +141,9 @@ install-latex: $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) +install-meta: META.coq + $(INSTALLLIB) META.coq $(FULLCOQLIB)/META + # For emacs: # Local Variables: # mode: makefile diff --git a/engine/evd.ml b/engine/evd.ml index 69ca45444..bde0182cc 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -643,6 +643,7 @@ let set_universe_context evd uctx' = { evd with universes = uctx' } let add_conv_pb ?(tail=false) pb d = + (** MS: we have duplicates here, why? *) if tail then {d with conv_pbs = d.conv_pbs @ [pb]} else {d with conv_pbs = pb::d.conv_pbs} @@ -1410,7 +1411,16 @@ 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 + let env = + (** We currently allow evar instances to refer to anonymous de + Bruijn indices, so we protect the error printing code in this + case by giving names to every de Bruijn variable in the + rel_context of the conversion problem. MS: we should rather + stop depending on anonymous variables, they can be used to + indicate independency. Also, this depends on a strategy for + naming/renaming. *) + 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/termops.ml b/engine/termops.ml index 5e65652c0..5327f1829 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -600,6 +600,10 @@ let collect_vars c = | _ -> fold_constr aux vars c in aux Id.Set.empty c +let vars_of_global_reference env gr = + let c, _ = Universes.unsafe_constr_of_global gr in + vars_of_global (Global.env ()) c + (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) diff --git a/engine/termops.mli b/engine/termops.mli index 7d6e99acc..c58e3728c 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -121,6 +121,7 @@ val dependent_in_decl : constr -> Context.Named.Declaration.t -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) +val vars_of_global_reference : env -> Globnames.global_reference -> Id.Set.t val occur_term : constr -> constr -> bool (** Synonymous of dependent Substitution of metavariables *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index d7f283e95..7dbd94aa7 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -248,6 +248,10 @@ let check_is_hole id = function GHole _ -> () | t -> let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' +type recursive_pattern_kind = +| RecursiveTerms of bool (* associativity *) +| RecursiveBinders of glob_constr * glob_constr + let compare_recursive_parts found f f' (iterator,subc) = let diff = ref None in let terminator = ref None in @@ -269,18 +273,16 @@ let compare_recursive_parts found f f' (iterator,subc) = let x,y = if lassoc then y,x else x,y in begin match !diff with | None -> - let () = diff := Some (x, y, Some lassoc) in + let () = diff := Some (x, y, RecursiveTerms lassoc) in true | Some _ -> false end | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> (* We found a binding position where it differs *) - check_is_hole x t_x; - check_is_hole y t_y; begin match !diff with | None -> - let () = diff := Some (x, y, None) in + let () = diff := Some (x, y, RecursiveBinders (t_x,t_y)) in aux c term | Some _ -> false end @@ -294,7 +296,7 @@ let compare_recursive_parts found f f' (iterator,subc) = (* Here, we would need a loc made of several parts ... *) user_err ~loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") - | Some (x,y,Some lassoc) -> + | Some (x,y,RecursiveTerms lassoc) -> let newfound,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) @@ -312,11 +314,13 @@ let compare_recursive_parts found f f' (iterator,subc) = (* found have been collected by compare_constr *) found := newfound; NList (x,y,iterator,f (Option.get !terminator),lassoc) - | Some (x,y,None) -> + | Some (x,y,RecursiveBinders (t_x,t_y)) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in let iterator = f' (subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in (* found have been collected by compare_constr *) found := newfound; + check_is_hole x t_x; + check_is_hole y t_y; NBinderList (x,y,iterator,f (Option.get !terminator)) else raise Not_found diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 7424fd85a..1e7c2ec27 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -415,10 +415,12 @@ type vernac_expr = | VernacDeclareImplicits of reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of reference or_by_notation * - (vernac_argument_status list) list * - int * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | - `DefaultImplicits ] list + vernac_argument_status list (* Main arguments status list *) * + (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) * + int option (* Number of args to trigger reduction *) * + [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | + `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | + `DefaultImplicits ] list | VernacArgumentsScope of reference or_by_notation * scope_name option list | VernacReserve of simple_binder list @@ -474,11 +476,13 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr +and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit + and vernac_argument_status = { name : Name.t; recarg_like : bool; notation_scope : (Loc.t * string) option; - implicit_status : [ `Implicit | `MaximallyImplicit | `NotImplicit]; + implicit_status : vernac_implicit_status; } (* A vernac classifier has to tell if a command: diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 29e33d349..d5feafbf9 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -57,7 +57,7 @@ void init_arity () { arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ISCONST]= 1; + arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[ARECONST]=arity[PROJ]=2; @@ -79,7 +79,7 @@ void * coq_stat_alloc (asize_t sz) value coq_makeaccu (value i) { code_t q; - code_t res = coq_stat_alloc(8); + code_t res = coq_stat_alloc(2 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); @@ -91,13 +91,13 @@ value coq_pushpop (value i) { int n; n = Int_val(i); if (n == 0) { - res = coq_stat_alloc(4); + res = coq_stat_alloc(sizeof(opcode_t)); *res = VALINSTR(STOP); return (value)res; } else { code_t q; - res = coq_stat_alloc(12); + res = coq_stat_alloc(3 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index 885594ac7..d92e85fdf 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -39,6 +39,7 @@ enum instructions { GETFIELD0, GETFIELD1, GETFIELD, SETFIELD0, SETFIELD1, SETFIELD, PROJ, + ENSURESTACKCAPACITY, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index ddf40e2eb..792a311fc 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -76,6 +76,14 @@ sp is a local copy of the global variable extern_sp. */ # define print_lint(i) #endif +#define CHECK_STACK(num_args) { \ +if (sp - num_args < coq_stack_threshold) { \ + coq_sp = sp; \ + realloc_coq_stack(num_args + Coq_stack_threshold / sizeof(value)); \ + sp = coq_sp; \ + } \ +} + /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } @@ -198,6 +206,9 @@ value coq_interprete sp = coq_sp; pc = coq_pc; accu = coq_accu; + + CHECK_STACK(0); + #ifdef THREADED_CODE goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ #else @@ -354,7 +365,7 @@ value coq_interprete coq_extra_args = *pc - 1; pc = Code_val(accu); coq_env = accu; - goto check_stacks; + goto check_stack; } Instruct(APPLY1) { value arg1 = sp[0]; @@ -371,7 +382,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; - goto check_stacks; + goto check_stack; } Instruct(APPLY2) { value arg1 = sp[0]; @@ -386,7 +397,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 1; - goto check_stacks; + goto check_stack; } Instruct(APPLY3) { value arg1 = sp[0]; @@ -403,17 +414,13 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 2; - goto check_stacks; + goto check_stack; } /* Stack checks */ - check_stacks: - print_instr("check_stacks"); - if (sp < coq_stack_threshold) { - coq_sp = sp; - realloc_coq_stack(Coq_stack_threshold); - sp = coq_sp; - } + check_stack: + print_instr("check_stack"); + CHECK_STACK(0); /* We also check for signals */ if (caml_signals_are_pending) { /* If there's a Ctrl-C, we reset the vm */ @@ -422,6 +429,16 @@ value coq_interprete } Next; + Instruct(ENSURESTACKCAPACITY) { + print_instr("ENSURESTACKCAPACITY"); + int size = *pc++; + /* CHECK_STACK may trigger here a useless allocation because of the + threshold, but check_stack: often does it anyway, so we prefer to + factorize the code. */ + CHECK_STACK(size); + Next; + } + Instruct(APPTERM) { int nargs = *pc++; int slotsize = *pc; @@ -436,7 +453,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args += nargs - 1; - goto check_stacks; + goto check_stack; } Instruct(APPTERM1) { value arg1 = sp[0]; @@ -445,7 +462,7 @@ value coq_interprete sp[0] = arg1; pc = Code_val(accu); coq_env = accu; - goto check_stacks; + goto check_stack; } Instruct(APPTERM2) { value arg1 = sp[0]; @@ -458,7 +475,7 @@ value coq_interprete print_lint(accu); coq_env = accu; coq_extra_args += 1; - goto check_stacks; + goto check_stack; } Instruct(APPTERM3) { value arg1 = sp[0]; @@ -472,7 +489,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args += 2; - goto check_stacks; + goto check_stack; } Instruct(RETURN) { @@ -503,6 +520,7 @@ value coq_interprete int num_args = Wosize_val(coq_env) - 2; int i; print_instr("RESTART"); + CHECK_STACK(num_args); sp -= num_args; for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); coq_env = Field(coq_env, 1); @@ -863,29 +881,7 @@ value coq_interprete sp++; Next; } - - /* *sp = accu; - * Netoyage des cofix * - size = Wosize_val(accu); - for (i = 2; i < size; i++) { - accu = Field(*sp, i); - if (IS_EVALUATED_COFIX(accu)) { - size_aux = Wosize_val(accu); - *--sp = accu; - Alloc_small(accu, size_aux, Accu_tag); - for(j = 0; j < size_aux; j++) Field(accu, j) = Field(*sp, j); - *sp = accu; - Alloc_small(accu, 1, ATOM_COFIX_TAG); - Field(accu, 0) = Field(Field(*sp, 1), 0); - caml_modify(&Field(*sp, 1), accu); - accu = *sp; sp++; - caml_modify(&Field(*sp, i), accu); - } - } - sp++; - Next; - } */ - + Instruct(SETFIELD){ print_instr("SETFIELD"); caml_modify(&Field(accu, *pc),*sp); @@ -979,28 +975,31 @@ value coq_interprete } Instruct(MAKESWITCHBLOCK) { print_instr("MAKESWITCHBLOCK"); - *--sp = accu; - accu = Field(accu,1); + *--sp = accu; // Save matched block on stack + accu = Field(accu,1); // Save atom to accu register switch (Tag_val(accu)) { - case ATOM_COFIX_TAG: + case ATOM_COFIX_TAG: // We are forcing a cofix { mlsize_t i, nargs; print_instr("COFIX_TAG"); sp-=2; pc++; + // Push the return address sp[0] = (value) (pc + *pc); sp[1] = coq_env; - coq_env = Field(accu,0); - accu = sp[2]; - sp[2] = Val_long(coq_extra_args); - nargs = Wosize_val(accu) - 2; + coq_env = Field(accu,0); // Pointer to suspension + accu = sp[2]; // Save accumulator to accu register + sp[2] = Val_long(coq_extra_args); // Push number of args for return + nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + // Push arguments to stack + CHECK_STACK(nargs+1); sp -= nargs; - for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); - *--sp = accu; + for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); + *--sp = accu; // Last argument is the pointer to the suspension print_lint(nargs); coq_extra_args = nargs; - pc = Code_val(coq_env); - goto check_stacks; + pc = Code_val(coq_env); // Trigger evaluation + goto check_stack; } case ATOM_COFIXEVALUATED_TAG: { @@ -1458,26 +1457,32 @@ value coq_push_val(value v) { value coq_push_arguments(value args) { int nargs,i; + value * sp = coq_sp; nargs = Wosize_val(args) - 2; + CHECK_STACK(nargs); coq_sp -= nargs; print_instr("push_args");print_int(nargs); for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); return Val_unit; } -value coq_push_vstack(value stk) { +value coq_push_vstack(value stk, value max_stack_size) { int len,i; + value * sp = coq_sp; len = Wosize_val(stk); + CHECK_STACK(len); coq_sp -= len; print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); + sp = coq_sp; + CHECK_STACK(uint32_of_value(max_stack_size)); return Val_unit; } value coq_interprete_ml(value tcode, value a, value e, value ea) { print_instr("coq_interprete"); return coq_interprete((code_t)tcode, a, e, Long_val(ea)); - print_instr("end coq_interprete"); + print_instr("end coq_interprete"); } value coq_eval_tcode (value tcode, value e) { diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index c9bcdc32f..45cfae509 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -130,6 +130,7 @@ value init_coq_vm(value unit) /* ML */ return Val_unit;; } +/* [required_space] is a size in words */ void realloc_coq_stack(asize_t required_space) { asize_t size; diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 8d4de523a..810c34699 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -43,7 +43,7 @@ type structured_constant = type reloc_table = (tag * int) array type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool} + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} module Label = struct @@ -87,6 +87,7 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of int * Constant.t (* index of the projected argument, name of projection *) + | Kensurestackcapacity of int (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) | Kaddint31 (* adds the int31 in the accu @@ -264,6 +265,8 @@ let rec pp_instr i = | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p + | Kensurestackcapacity size -> str "growstack " ++ int size + | Kaddint31 -> str "addint31" | Kaddcint31 -> str "addcint31" | Kaddcarrycint31 -> str "addcarrycint31" diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 5f1f09d00..b8de7619c 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -39,7 +39,7 @@ val pp_struct_const : structured_constant -> Pp.std_ppcmds type reloc_table = (tag * int) array type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool} + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} module Label : sig @@ -84,6 +84,7 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of int * Constant.t (** index of the projected argument, name of projection *) + | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 2fe917eca..57b397e6f 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -91,6 +91,11 @@ open Pre_env (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +module Config = struct + let stack_threshold = 256 (* see byterun/coq_memory.h *) + let stack_safety_margin = 15 +end + type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = []; fv_fwd = FvMap.empty } @@ -112,6 +117,26 @@ let empty_comp_env ?(univs=0) ()= in_env = ref empty_fv } +(* Maximal stack size reached during the current function body. Used to + reallocate the stack if we lack space. *) +let max_stack_size = ref 0 + +let set_max_stack_size stack_size = + if stack_size > !max_stack_size then + max_stack_size := stack_size + +let ensure_stack_capacity f x = + let old = !max_stack_size in + max_stack_size := 0; + let code = f x in + let used_safe = + !max_stack_size + Config.stack_safety_margin + in + max_stack_size := old; + if used_safe > Config.stack_threshold then + Kensurestackcapacity used_safe :: code + else code + (*i Creation functions for comp_env *) let rec add_param n sz l = @@ -370,14 +395,28 @@ let const_bn tag args = else Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args) - -let code_makeblock arity tag cont = +(* +If [tag] hits the OCaml limitation for non constant constructors, we switch to +another representation for the remaining constructors: +[last_variant_tag|tag - last_variant_tag|args] + +We subtract last_variant_tag for efficiency of match interpretation. + *) + +let nest_block tag arity cont = + Kconst (Const_b0 (tag - last_variant_tag)) :: + Kmakeblock(arity+1, last_variant_tag) :: cont + +let code_makeblock ~stack_size ~arity ~tag cont = if tag < last_variant_tag then Kmakeblock(arity, tag) :: cont - else - Kpush :: Kconst (Const_b0 (tag - last_variant_tag)) :: - Kmakeblock(arity+1, last_variant_tag) :: cont + else begin + set_max_stack_size (stack_size + 1); + Kpush :: nest_block tag arity cont + end +(* [code_construct] compiles an abstracted constructor dropping parameters and + updates [fun_code] *) (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = let f_cont = @@ -386,11 +425,11 @@ let code_construct tag nparams arity cont = [Kconst (Const_b0 tag); Kreturn 0] else if tag < last_variant_tag then [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0] - else - [Kconst (Const_b0 (tag - last_variant_tag)); - Kmakeblock(arity+1, last_variant_tag); Kreturn 0]) + else + nest_block tag arity [Kreturn 0]) in let lbl = Label.create() in + (* No need to grow the stack here, as the function does not push stuff. *) fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont @@ -536,11 +575,12 @@ let compile_fv_elem reloc fv sz cont = let rec compile_fv reloc l sz cont = match l with | [] -> cont - | [fvn] -> compile_fv_elem reloc fvn sz cont + | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont | fvn :: tl -> compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) + (* Compiling constants *) let rec get_alias env kn = @@ -555,6 +595,7 @@ let rec get_alias env kn = (* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = + set_max_stack_size sz; match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" @@ -603,6 +644,7 @@ let rec compile_constr reloc c sz cont = compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont else let compile_get_univ reloc idx sz cont = + set_max_stack_size sz; compile_fv_elem reloc (FVuniv_var idx) sz cont in comp_app compile_str_cst compile_get_univ reloc @@ -622,7 +664,8 @@ let rec compile_constr reloc c sz cont = let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in let cont_fun = - compile_constr r_fun body arity [Kreturn arity] in + ensure_stack_capacity (compile_constr r_fun body arity) [Kreturn arity] + in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) @@ -642,9 +685,10 @@ let rec compile_constr reloc c sz cont = (* Compilation des types *) let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + let fcode = + ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + in + let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; @@ -654,7 +698,8 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in let cont1 = - compile_constr env_body body arity [Kreturn arity] in + ensure_stack_capacity (compile_constr env_body body arity) [Kreturn arity] + in let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in @@ -672,9 +717,10 @@ let rec compile_constr reloc c sz cont = let rfv = ref empty_fv in let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + let fcode = + ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + in + let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; @@ -684,14 +730,17 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in - let cont1 = - compile_constr env_body body (arity+1) (cont_cofix arity) in - let cont2 = - add_grab (arity+1) lbl cont1 in + let comp arity = + (* 4 stack slots are needed to update the cofix when forced *) + set_max_stack_size (arity + 4); + compile_constr env_body body (arity+1) (cont_cofix arity) + in + let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; - fun_code := [Ksequence(cont2,!fun_code)]; + fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; done; let fv = !rfv in + set_max_stack_size (sz + fv.size + ndef + 2); compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) @@ -709,9 +758,11 @@ let rec compile_constr reloc c sz cont = let lbl_eblocks = Array.make neblock Label.no in let branch1,cont = make_branch cont in (* Compiling return type *) - let lbl_typ,fcode = - label_code (compile_constr reloc t sz [Kpop sz; Kstop]) - in fun_code := [Ksequence(fcode,!fun_code)]; + let fcode = + ensure_stack_capacity (compile_constr reloc t sz) [Kpop sz; Kstop] + in + let lbl_typ,fcode = label_code fcode in + fun_code := [Ksequence(fcode,!fun_code)]; (* Compiling branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = @@ -721,14 +772,9 @@ let rec compile_constr reloc c sz cont = sz, branch1, true | _ -> sz+3, Kjump, false in - let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in - (* Compiling branch for accumulators *) - let lbl_accu, code_accu = - label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) - in - lbl_blocks.(0) <- lbl_accu; - let c = ref code_accu in - (* perform the extra match if needed (to many block constructors) *) + + let c = ref cont in + (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin let lbl_b, code_b = label_code ( @@ -758,14 +804,34 @@ let rec compile_constr reloc c sz cont = compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c) in let code_b = - if tag < last_variant_tag then Kpushfields arity :: code_b - else Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b in + if tag < last_variant_tag then begin + set_max_stack_size (sz_b + arity); + Kpushfields arity :: code_b + end + else begin + set_max_stack_size (sz_b + arity + 1); + Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b + end + in let lbl_b,code_b = label_code code_b in if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; c := code_b done; - c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; + + let annot = + {ci = ci; rtbl = tbl; tailcall = is_tailcall; + max_stack_size = !max_stack_size - sz} + in + + (* Compiling branch for accumulators *) + let lbl_accu, code_accu = + set_max_stack_size (sz+3); + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c) + in + lbl_blocks.(0) <- lbl_accu; + + c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead @@ -782,12 +848,14 @@ let rec compile_constr reloc c sz cont = code_sw) and compile_str_cst reloc sc sz cont = + set_max_stack_size sz; match sc with | Bconstr c -> compile_constr reloc c sz cont | Bstrconst sc -> Kconst sc :: cont | Bmakeblock(tag,args) -> - let nargs = Array.length args in - comp_args compile_str_cst reloc args sz (code_makeblock nargs tag cont) + let arity = Array.length args in + let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in + comp_args compile_str_cst reloc args sz cont | Bconstruct_app(tag,nparams,arity,args) -> if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont @@ -801,6 +869,7 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_get_global reloc (kn,u) sz cont = + set_max_stack_size sz; let kn = get_alias !global_env kn in if Univ.Instance.is_empty u then Kgetglobal kn :: cont @@ -809,11 +878,13 @@ and compile_get_global reloc (kn,u) sz cont = compile_universe reloc () (Univ.Instance.to_array u) sz cont and compile_universe reloc uni sz cont = + set_max_stack_size sz; match Univ.Level.var_index uni with | None -> Kconst (Const_univ_level uni) :: cont | Some idx -> pos_universe_var idx reloc sz :: cont and compile_const reloc kn u args sz cont = + set_max_stack_size sz; let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function @@ -875,7 +946,7 @@ let compile fail_on_error ?universes:(universes=0) env c = let reloc, init_code = if Int.equal universes 0 then let reloc = empty_comp_env () in - reloc, compile_constr reloc c 0 cont + reloc, ensure_stack_capacity (compile_constr reloc c 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. @@ -892,11 +963,16 @@ let compile fail_on_error ?universes:(universes=0) env c = let r_fun = comp_env_fun ~univs:universes arity in let lbl_fun = Label.create () in let cont_fun = - compile_constr r_fun body full_arity [Kreturn full_arity] + ensure_stack_capacity (compile_constr r_fun body full_arity) + [Kreturn full_arity] in fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in - reloc, compile_fv reloc fv.fv_rev 0 (Kclosure(lbl_fun,fv.size) :: cont) + let init_code = + ensure_stack_capacity (compile_fv reloc fv.fv_rev 0) + (Kclosure(lbl_fun,fv.size) :: cont) + in + reloc, init_code in let fv = List.rev (!(reloc.in_env).fv_rev) in (if !Flags.dump_bytecode then diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index d779a81ff..ad7a41a34 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -234,6 +234,7 @@ let emit_instr = function else (out opSETFIELD;out_int n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) + | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size (* spiwack *) | Kbranch lbl -> out opBRANCH; out_label lbl | Kaddint31 -> out opADDINT31 diff --git a/kernel/vm.ml b/kernel/vm.ml index eb992ef89..53483a222 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -170,7 +170,7 @@ type whd = external push_ra : tcode -> unit = "coq_push_ra" external push_val : values -> unit = "coq_push_val" external push_arguments : arguments -> unit = "coq_push_arguments" -external push_vstack : vstack -> unit = "coq_push_vstack" +external push_vstack : vstack -> int -> unit = "coq_push_vstack" (* interpreteur *) @@ -206,7 +206,9 @@ let apply_varray vf varray = else begin push_ra stop; - push_vstack varray; + (* The fun code of [vf] will make sure we have enough stack, so we put 0 + here. *) + push_vstack varray 0; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end @@ -560,7 +562,9 @@ let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl let case_info sw = sw.sw_annot.ci let type_of_switch sw = - push_vstack sw.sw_stk; + (* The fun code of types will make sure we have enough stack, so we put 0 + here. *) + push_vstack sw.sw_stk 0; interprete sw.sw_type_code crazy_val sw.sw_env 0 let branch_arg k (tag,arity) = @@ -580,9 +584,10 @@ let branch_arg k (tag,arity) = let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then - (push_ra stop;push_vstack sw.sw_stk) + (push_ra stop;push_vstack sw.sw_stk sw.sw_annot.max_stack_size) else - (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); + (push_vstack sw.sw_stk sw.sw_annot.max_stack_size; + push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 let branch_of_switch k sw = diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 48a8305bc..dbebe6a48 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,6 +16,16 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) +(* XXX: To move to common tagging functions in Pp, blocked on tag + * system cleanup as we cannot define generic error tags now. + * + * Anyways, tagging should not happen here, but in the specific + * listener to the msg_* stuff. + *) +let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () +let err_str = tag_err_str "Error:" +let ann_str = tag_err_str "Anomaly:" + let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -92,7 +102,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ + hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else @@ -114,7 +124,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (str "Error: " ++ where s ++ pps) + hov 0 (err_str ++ where s ++ pps) | _ -> raise Unhandled end diff --git a/lib/stateid.ml b/lib/stateid.ml index 500581a39..ae25735c5 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -22,7 +22,7 @@ let to_int id = id let newer_than id1 id2 = id1 > id2 let state_id_info : (t * t) Exninfo.t = Exninfo.make () -let add exn ?(valid = initial) id = +let add exn ~valid id = Exninfo.add exn state_id_info (valid, id) let get exn = Exninfo.get exn state_id_info diff --git a/lib/stateid.mli b/lib/stateid.mli index cd8fddf0c..1d87a343b 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -26,9 +26,8 @@ val newer_than : t -> t -> bool (* Attaches to an exception the concerned state id, plus an optional * state id that is a valid state id before the error. - * Backtracking to the valid id is safe. - * The initial_state_id is assumed to be safe. *) -val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info + * Backtracking to the valid id is safe. *) +val add : Exninfo.info -> valid:t -> t -> Exninfo.info val get : Exninfo.info -> (t * t) option type ('a,'b) request = { diff --git a/library/impargs.ml b/library/impargs.ml index ea2805b67..836568b89 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -492,13 +492,15 @@ let implicits_of_global ref = let l = Refmap.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in - let rename imp name = match imp, name with - | Some (_, x,y), Name id -> Some (id, x,y) - | _ -> imp in - List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l + let rec rename implicits names = match implicits, names with + | [], _ -> [] + | _, [] -> implicits + | Some (_, x,y) :: implicits, Name id :: names -> + Some (id, x,y) :: rename implicits names + | imp :: implicits, _ :: names -> imp :: rename implicits names + in + List.map (fun (t, il) -> t, rename il rename_l) l with Not_found -> l - | Invalid_argument _ -> - anomaly (Pp.str "renamings list and implicits list have different lenghts") with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = @@ -654,7 +656,7 @@ let check_inclusion l = let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then - error "Sequences of implicit arguments must be of different lengths"; + error "Sequences of implicit arguments must be of different lengths."; aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) diff --git a/ltac/tactic_debug.ml b/ltac/tactic_debug.ml index e1c9fed63..5cbddc7f6 100644 --- a/ltac/tactic_debug.ml +++ b/ltac/tactic_debug.ml @@ -385,6 +385,8 @@ let skip_extensions trace = | [] -> [] in List.rev (aux (List.rev trace)) +let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 + let extract_ltac_trace trace eloc = let trace = skip_extensions trace in let (loc,c),tail = List.sep_last trace in @@ -392,11 +394,10 @@ let extract_ltac_trace trace eloc = (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, loc + Some msg, if finer_loc eloc loc then eloc else loc else (* We entered a primitive tactic, we don't display trace but report on the finest location *) - let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 in let best_loc = (* trace is with innermost call coming first *) let rec aux best_loc = function diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 8e12e4525..69e4eb8d2 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -105,7 +105,7 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) end open Error diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index cb521ec54..7bc5bfca3 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -651,58 +651,29 @@ GEXTEND Gram (* Arguments *) | IDENT "Arguments"; qid = smart_global; - impl = LIST1 [ l = LIST0 - [ item = argument_spec -> - let name, recarg_like, notation_scope = item in - [`Id { name=name; recarg_like=recarg_like; - notation_scope=notation_scope; - implicit_status = `NotImplicit}] - | "/" -> [`Slash] - | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = `NotImplicit}) items - | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = `Implicit}) items - | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = `MaximallyImplicit}) items - ] -> l ] SEP ","; + args = LIST0 argument_spec_block; + more_implicits = OPT + [ ","; impl = LIST1 + [ impl = LIST0 more_implicits_block -> List.flatten impl] + SEP "," -> impl + ]; mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> let mods = match mods with None -> [] | Some l -> List.flatten l in - let impl = List.map List.flatten impl in - let rec aux n (narg, impl) = function - | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl - | `Slash :: tl -> aux (n+1) (n, impl) tl - | [] -> narg, impl in - let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in - let nargs, rest = List.hd nargs, List.tl nargs in - if List.exists (fun arg -> not (Int.equal arg nargs)) rest then - error "All arguments lists must have the same length"; - let err_incompat x y = - error ("Options \""^x^"\" and \""^y^"\" are incompatible") in - if nargs > 0 && List.mem `ReductionNeverUnfold mods then - err_incompat "simpl never" "/"; - if List.mem `ReductionNeverUnfold mods && - List.mem `ReductionDontExposeCase mods then - err_incompat "simpl never" "simpl nomatch"; - VernacArguments (qid, impl, nargs, mods) - + let slash_position = ref None in + let rec parse_args i = function + | [] -> [] + | `Id x :: args -> x :: parse_args (i+1) args + | `Slash :: args -> + if Option.is_empty !slash_position then + (slash_position := Some i; parse_args i args) + else + error "The \"/\" modifier can occur only once" + in + let args = parse_args 0 (List.flatten args) in + let more_implicits = Option.default [] more_implicits in + VernacArguments (qid, args, more_implicits, !slash_position, mods) + + (* moved there so that camlp5 factors it with the previous rule *) | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" -> @@ -759,6 +730,49 @@ GEXTEND Gram snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s ] ]; + (* List of arguments implicit status, scope, modifiers *) + argument_spec_block: [ + [ item = argument_spec -> + let name, recarg_like, notation_scope = item in + [`Id { name=name; recarg_like=recarg_like; + notation_scope=notation_scope; + implicit_status = NotImplicit}] + | "/" -> [`Slash] + | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = NotImplicit}) items + | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = Implicit}) items + | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = MaximallyImplicit}) items + ] + ]; + (* Same as [argument_spec_block], but with only implicit status and names *) + more_implicits_block: [ + [ name = name -> [(snd name, Vernacexpr.NotImplicit)] + | "["; items = LIST1 name; "]" -> + List.map (fun name -> (snd name, Vernacexpr.Implicit)) items + | "{"; items = LIST1 name; "}" -> + List.map (fun name -> (snd name, Vernacexpr.MaximallyImplicit)) items + ] + ]; strategy_level: [ [ IDENT "expand" -> Conv_oracle.Expand | IDENT "opaque" -> Conv_oracle.Opaque diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index f43251bc5..54066edfb 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1538,7 +1538,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num begin if do_observe () then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else anomaly (Pp.str "Cannot create equation Lemma") + else CErrors.user_err ~hdr:"Cannot create equation Lemma" + (str "Cannot create equation lemma." ++ spc () ++ + str "This may be because the function is nested-recursive.") ; true end diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 610c4c92d..77e25b2a5 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -113,8 +113,7 @@ let guard_term ch1 s i = match s.[i] with (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = - msg_with Format.str_formatter (prc c); - let s = Format.flush_str_formatter () ^ "$" in + let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) let pr_constr = pr_constr diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 077ee4e15..1bd03491a 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -18,12 +18,12 @@ module NamedDecl = Context.Named.Declaration (*i*) let name_table = - Summary.ref (Refmap.empty : Name.t list list Refmap.t) + Summary.ref (Refmap.empty : Name.t list Refmap.t) ~name:"rename-arguments" type req = | ReqLocal - | ReqGlobal of global_reference * Name.t list list + | ReqGlobal of global_reference * Name.t list let load_rename_args _ (_, (_, (r, names))) = name_table := Refmap.add r names !name_table @@ -51,7 +51,7 @@ let discharge_rename_args = function let vars,_,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in - let names' = List.map (fun l -> var_names @ l) names in + let names' = var_names @ names in Some (ReqGlobal (c', names), (c', names')) with Not_found -> Some req) | _ -> None @@ -85,7 +85,7 @@ let rec rename_prod c = function | _ -> c let rename_type ty ref = - try rename_prod ty (List.hd (arguments_names ref)) + try rename_prod ty (arguments_names ref) with Not_found -> ty let rename_type_of_constant env c = diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index a33405501..e123e7786 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -11,10 +11,10 @@ open Globnames open Environ open Term -val rename_arguments : bool -> global_reference -> Name.t list list -> unit +val rename_arguments : bool -> global_reference -> Name.t list -> unit -(** [Not_found] is raised is no names are defined for [r] *) -val arguments_names : global_reference -> Name.t list list +(** [Not_found] is raised if no names are defined for [r] *) +val arguments_names : global_reference -> Name.t list val rename_type_of_constant : env -> pconstant -> types val rename_type_of_inductive : env -> pinductive -> types diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 934cefbfe..d5b125135 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -67,10 +67,11 @@ let error_wrong_numarg_inductive ?loc env c n = let list_try_compile f l = let rec aux errors = function - | [] -> if errors = [] then anomaly (str "try_find_f") else raise (List.last errors) + | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors) | h::t -> try f h with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> + let e = CErrors.push e in aux (e::errors) t in aux [] l diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3045d66b8..3ef0bb1b3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1179,9 +1179,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 +let error_cannot_unify env evd pb ?reason t1 t2 = + Pretype_errors.error_cannot_unify + ~loc:(loc_of_conv_pb evd pb) env + evd ?reason (t1, t2) + let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with - | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) + | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 | _ -> () let max_undefined_with_candidates evd = @@ -1250,17 +1255,15 @@ let consider_remaining_unif_problems env aux evd pbs progress (pb :: stuck) end | UnifFailure (evd,reason) -> - Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) - env evd ~reason (t1, t2)) + error_cannot_unify env evd pb ~reason t1 t2) | _ -> if progress then aux evd stuck false [] else match stuck with | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> - (* There remains stuck problems *) - Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) - env evd (t1, t2) + (* There remains stuck problems *) + error_cannot_unify env evd pb t1 t2 in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 5d7249aff..93c3179bc 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1021,7 +1021,7 @@ module Make str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") impls) ) - | VernacArguments (q, impl, nargs, mods) -> + | VernacArguments (q, args, more_implicits, nargs, mods) -> return ( hov 2 ( keyword "Arguments" ++ spc() ++ @@ -1029,19 +1029,28 @@ module Make let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in let pr_if b x = if b then x else str "" in let pr_br imp x = match imp with - | `Implicit -> str "[" ++ x ++ str "]" - | `MaximallyImplicit -> str "{" ++ x ++ str "}" - | `NotImplicit -> x in - let rec aux n l = + | Vernacexpr.Implicit -> str "[" ++ x ++ str "]" + | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}" + | Vernacexpr.NotImplicit -> x in + let rec print_arguments n l = match n, l with - | 0, l -> spc () ++ str"/" ++ aux ~-1 l + | Some 0, l -> spc () ++ str"/" ++ print_arguments None l | _, [] -> mt() | n, { name = id; recarg_like = k; notation_scope = s; implicit_status = imp } :: tl -> spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ - aux (n-1) tl in - prlist_with_sep (fun () -> str", ") (aux nargs) impl ++ + print_arguments (Option.map pred n) tl + in + let rec print_implicits = function + | [] -> mt () + | (name, impl) :: rest -> + spc() ++ pr_br impl (pr_name name) ++ print_implicits rest + in + print_arguments nargs args ++ + if not (List.is_empty more_implicits) then + str ", " ++ prlist_with_sep (fun () -> str", ") print_implicits more_implicits + else (mt ()) ++ (if not (List.is_empty mods) then str" : " else str"") ++ prlist_with_sep (fun () -> str", " ++ spc()) (function | `ReductionDontExposeCase -> keyword "simpl nomatch" diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 3d0b07a1e..b19f8376c 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -243,7 +243,7 @@ let print_name_infos ref = let impls = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in let renames = - try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in + try Arguments_renaming.arguments_names ref with Not_found -> [] in let type_info_for_implicit = if need_expansion (select_impargs_size 0 impls) ref then (* Need to reduce since implicits are computed with products flattened *) @@ -283,7 +283,7 @@ let print_inductive_implicit_args = let print_inductive_renames = print_args_data_of_inductive_ids (fun r -> - try List.hd (Arguments_renaming.arguments_names r) with Not_found -> []) + try Arguments_renaming.arguments_names r with Not_found -> []) ((!=) Anonymous) print_renames_list diff --git a/stm/stm.ml b/stm/stm.ml index 1850c3020..23d68c4b8 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -746,7 +746,7 @@ module State : sig val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool - val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn + val exn_on : Stateid.t -> valid:Stateid.t -> iexn -> iexn (* to send states across worker/master *) type frozen_state val get_cached : Stateid.t -> frozen_state @@ -854,14 +854,14 @@ end = struct (* {{{ *) VCS.set_state id (Valid s) with VCS.Expired -> () - let exn_on id ?valid (e, info) = + let exn_on id ~valid (e, info) = match Stateid.get info with | Some _ -> (e, info) | None -> let loc = Option.default Loc.ghost (Loc.get_loc info) in let (e, info) = Hooks.(call_process_error_once (e, info)) in Hooks.(call execution_error id loc (iprint (e, info))); - (e, Stateid.add info ?valid id) + (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = let s1 = States.summary_of_state s1 in @@ -2354,7 +2354,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 -let merge_proof_branch ?valid ?id qast keep brname = +let merge_proof_branch ~valid ?id qast keep brname = let brinfo = VCS.get_branch brname in let qed fproof = { qast; keep; brname; brinfo; fproof } in match brinfo with @@ -2377,7 +2377,7 @@ let merge_proof_branch ?valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - iraise (State.exn_on ?valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -2446,9 +2446,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty | VtStm (VtBack oid, true), w -> let id = VCS.new_node ~id:newtip () in let { mine; others } = Backtrack.branches_of oid in + let valid = VCS.get_branch_pos head in List.iter (fun branch -> if not (List.mem_assoc branch (mine::others)) then - ignore(merge_proof_branch x VtDrop branch)) + ignore(merge_proof_branch ~valid x VtDrop branch)) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); let head = VCS.current_branch () in @@ -2543,8 +2544,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty detect_proof_block id cblock; *) Backtrack.record (); if w == VtNow then finish (); `Ok | VtQed keep, w -> - let valid = if tty then Some(VCS.get_branch_pos head) else None in - let rc = merge_proof_branch ?valid ~id:newtip x keep head in + let valid = VCS.get_branch_pos head in + let rc = merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); rc diff --git a/tactics/auto.ml b/tactics/auto.ml index 63f85114e..d4251555d 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -34,6 +34,10 @@ open Hints let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l +let compute_secvars gl = + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + secvars_of_hyps hyps + (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -259,19 +263,19 @@ let pr_info_atom (d,pp) = let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_debug (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function - | (Info,_,_) -> Feedback.msg_debug (str "idtac.") + | (Info,_,_) -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | (Off,_,_) -> () | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") - | (Info,0,_) -> Feedback.msg_debug (str "(* info trivial: *)") - | (Info,_,_) -> Feedback.msg_debug (str "(* info auto: *)") + | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in @@ -294,12 +298,13 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> Hint_db.map_none + | None -> Hint_db.map_none ~secvars | Some hdc -> - if occur_existential concl then Hint_db.map_existential hdc concl - else Hint_db.map_auto hdc concl + if occur_existential concl then + Hint_db.map_existential ~secvars hdc concl + else Hint_db.map_auto ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -324,22 +329,23 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve dbg mod_delta db_list local_db concl))) + (trivial_resolve dbg mod_delta db_list local_db secvars concl))) end } -and my_find_search_nodelta db_list local_db hdc concl = +and my_find_search_nodelta db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta db_list local_db hdc concl = - let f = hintmap_of hdc concl in +and my_find_search_delta db_list local_db secvars hdc concl = + let f = hintmap_of secvars hdc concl in if occur_existential concl then List.map_append (fun db -> @@ -359,11 +365,11 @@ and my_find_search_delta db_list local_db hdc concl = let (ids, csts as st) = Hint_db.transparent_state db in let flags, l = let l = - match hdc with None -> Hint_db.map_none db + match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto hdc concl db - else Hint_db.map_existential hdc concl db + then Hint_db.map_auto ~secvars hdc concl db + else Hint_db.map_existential ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) @@ -396,7 +402,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= in tclLOG dbg pr_hint (run_hint t tactic) -and trivial_resolve dbg mod_delta db_list local_db cl = +and trivial_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -405,7 +411,7 @@ and trivial_resolve dbg mod_delta db_list local_db cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta db_list local_db head cl)) + (my_find_search mod_delta db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -443,7 +449,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve dbg mod_delta db_list local_db cl = +let possible_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -451,7 +457,7 @@ let possible_resolve dbg mod_delta db_list local_db cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta db_list local_db head cl) + (my_find_search mod_delta db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -482,11 +488,12 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve d mod_delta db_list local_db concl)) + (possible_resolve d mod_delta db_list local_db secvars concl)) end })) end [] in diff --git a/tactics/auto.mli b/tactics/auto.mli index 3ee96353f..06048ac1c 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -16,6 +16,8 @@ open Decl_kinds open Hints open Tactypes +val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t + 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 96767e7f6..a4243164e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -282,11 +282,11 @@ let clenv_of_prods poly nprods (c, clenv) gl = let ty = Retyping.get_type_of (Proofview.Goal.env gl) (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in let diff = nb_prod ty - nprods in - if Pervasives.(>=) diff 0 then - (* Was Some clenv... *) - Some (Some diff, - Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) - else None + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Some diff, + Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + else None let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then @@ -341,7 +341,7 @@ let shelve_dependencies gls = shelve_goals gls) (** Hack to properly solve dependent evars that are typeclasses *) -let rec e_trivial_fail_db only_classes db_list local_db = +let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = @@ -352,13 +352,13 @@ let rec e_trivial_fail_db only_classes db_list local_db = let d = pf_last_hyp gl in let hintl = make_resolve_hyp env sigma d in let hints = Hint_db.add_list env sigma hintl local_db in - e_trivial_fail_db only_classes db_list hints + e_trivial_fail_db only_classes db_list hints secvars end } in let trivial_resolve = Proofview.Goal.nf_enter { enter = begin fun gl -> - let tacs = e_trivial_resolve db_list local_db only_classes + let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end} @@ -369,7 +369,7 @@ let rec e_trivial_fail_db only_classes db_list local_db = in tclFIRST (List.map tclCOMPLETE tacl) -and e_my_find_search db_list local_db hdc complete only_classes sigma concl = +and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = let open Proofview.Notations in let prods, concl = decompose_prod_assum concl in let nprods = List.length prods in @@ -386,15 +386,15 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = (fun db -> let tacs = if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto hdc concl db - else Hint_db.map_existential hdc concl db + Hint_db.map_eauto secvars hdc concl db + else Hint_db.map_existential secvars hdc concl db in let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) -> let tac = function | Res_pf (term,cl) -> if get_typeclasses_filtered_unification () then @@ -431,7 +431,7 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = | Res_pf_THEN_trivial_fail (term,cl) -> let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in let snd = if complete then Tacticals.New.tclIDTAC - else e_trivial_fail_db only_classes db_list local_db in + else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.New.tclTHEN fst snd | Unfold_nth c -> let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in @@ -451,15 +451,15 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db only_classes sigma concl = +and e_trivial_resolve db_list local_db secvars only_classes sigma concl = try - e_my_find_search db_list local_db + e_my_find_search db_list local_db secvars (decompose_app_bound concl) true only_classes sigma concl with Bound | Not_found -> [] -let e_possible_resolve db_list local_db only_classes sigma concl = +let e_possible_resolve db_list local_db secvars only_classes sigma concl = try - e_my_find_search db_list local_db + e_my_find_search db_list local_db secvars (decompose_app_bound concl) false only_classes sigma concl with Bound | Not_found -> [] @@ -673,7 +673,8 @@ module V85 = struct let env = Goal.V82.env s gl in let concl = Goal.V82.concl s gl in let tacgl = {it = gl; sigma = s;} in - let poss = e_possible_resolve hints info.hints info.only_classes s concl in + let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in + let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in let unique = is_unique env concl in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> @@ -1004,8 +1005,9 @@ module Search = struct Printer.pr_constr_env (Goal.env gl) s concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); + let secvars = compute_secvars gl in let poss = - e_possible_resolve hints info.search_hints info.search_only_classes s concl in + e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal diff --git a/tactics/eauto.ml b/tactics/eauto.ml index c6b7de32d..10c975b8d 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -119,12 +119,13 @@ let unify_e_resolve poly flags (c,clenv) = (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) end } -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> fun db -> Hint_db.map_none db + | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) + if occur_existential concl then + (fun db -> Hint_db.map_existential ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = @@ -142,16 +143,17 @@ let rec e_trivial_fail_db db_list local_db = e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) end } in Proofview.Goal.enter { enter = begin fun gl -> + let secvars = compute_secvars gl in let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in +and e_my_find_search db_list local_db secvars hdc concl = + let hint_of_db = hintmap_of secvars hdc concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -179,14 +181,15 @@ and e_my_find_search db_list local_db hdc concl = in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db gl = +and e_trivial_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) + try priority (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] -let e_possible_resolve db_list local_db gl = +let e_possible_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) + (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] let find_first_goal gls = @@ -255,9 +258,11 @@ module SearchProblem = struct let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in + let hyps = pf_ids_of_hyps g in + let secvars = secvars_of_hyps (pf_hyps g) in let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in + let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; @@ -283,7 +288,8 @@ module SearchProblem = struct let rec_tacs = let l = 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) + filter_tactics s.tacres + (e_possible_resolve s.dblist (List.hd s.localdb) secvars concl) in List.map (fun (lgls, cost, pp) -> @@ -346,13 +352,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> Feedback.msg_debug (str "idtac.") + | Info -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") - | Info -> Feedback.msg_debug (str "(* info eauto: *)") + | Info -> Feedback.msg_info (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () @@ -363,7 +369,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - Feedback.msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) diff --git a/tactics/hints.ml b/tactics/hints.ml index 3d5be5441..9fa49264f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -69,6 +69,25 @@ let decompose_app_bound t = | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args | _ -> raise Bound +(** Compute the set of section variables that remain in the named context. + Starts from the top to the bottom of the context, stops at the first + different declaration between the named hyps and the section context. *) +let secvars_of_hyps hyps = + let secctx = Global.named_context () in + let open Context.Named.Declaration in + let pred, all = + List.fold_left (fun (pred,all) decl -> + try let _ = Context.Named.lookup (get_id decl) hyps in + (* Approximation, it might be an hypothesis reintroduced with same name and unconvertible types, + we must allow it currently, as comparing the declarations for syntactic equality is too + strong a check (e.g. an unfold in a section variable would make it unusable). *) + (Id.Pred.add (get_id decl) pred, all) + with Not_found -> (pred, false)) + (Id.Pred.empty,true) secctx + in + if all then Id.Pred.full (* If the whole section context is available *) + else pred + (************************************************************************) (* The Type of Constructions Autotactic Hints *) (************************************************************************) @@ -107,12 +126,13 @@ type raw_hint = constr * types * Univ.universe_context_set type hint = (raw_hint * clausenv) hint_ast with_uid type 'a with_metadata = { - pri : int; (* A number lower is higher 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 *) + pri : int; (* A number lower is higher 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 : string option; (** The database from which the hint comes *) - code : 'a; (* the tactic to apply when the concl matches pat *) + secvars : Id.Pred.t; (* The set of section variables the hint depends on *) + code : 'a; (* the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -421,11 +441,14 @@ 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 map_none : secvars:Id.Pred.t -> t -> full_hint list +val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list +val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_eauto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_auto : secvars:Id.Pred.t -> + (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 @@ -474,7 +497,11 @@ struct try Constr_map.find key db.hintdb_map with Not_found -> empty_se - let realize_tac (id,tac) = tac + let realize_tac secvars (id,tac) = + if Id.Pred.subset tac.secvars secvars then Some tac + else + (** Warn about no longer typable hint? *) + None let match_mode m arg = match m with @@ -492,40 +519,40 @@ struct if List.is_empty modes then true else List.exists (matches_mode args) modes - let merge_entry db nopat pat = + let merge_entry secvars db nopat pat = let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in let h = List.merge pri_order_int h nopat in let h = List.merge pri_order_int h pat in - List.map realize_tac h + List.map_filter (realize_tac secvars) h - let map_none db = - merge_entry db [] [] + let map_none ~secvars db = + merge_entry secvars db [] [] - let map_all k db = + let map_all ~secvars k db = let se = find k db in - merge_entry db se.sentry_nopat se.sentry_pat + merge_entry secvars db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) - let map_auto (k,args) concl db = + let map_auto ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat + merge_entry secvars db [] pat - let map_existential (k,args) concl db = + let map_existential ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then - merge_entry db se.sentry_nopat se.sentry_pat - else merge_entry db [] [] + merge_entry secvars db se.sentry_nopat se.sentry_pat + else merge_entry secvars db [] [] (* [c] contains an existential *) - let map_eauto (k,args) concl db = + let map_eauto ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat - else merge_entry db [] [] + merge_entry secvars db [] pat + else merge_entry secvars db [] [] let is_exact = function | Give_exact _ -> true @@ -601,11 +628,11 @@ struct let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in - List.map realize_tac h + List.map snd h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in - f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); Constr_map.iter iter_se db.hintdb_map let fold f db accu = @@ -701,7 +728,20 @@ let try_head_pattern c = let with_uid c = { obj = c; uid = fresh_key () } +let secvars_of_idset s = + Id.Set.fold (fun id p -> + if is_section_variable id then + Id.Pred.add id p + else p) s Id.Pred.empty + +let secvars_of_constr env c = + secvars_of_idset (global_vars_set env c) + +let secvars_of_global env gr = + secvars_of_idset (vars_of_global_reference env gr) + let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = + let secvars = secvars_of_constr env c in let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -717,6 +757,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = pat = Some pat; name = name; db = None; + secvars; code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = @@ -731,6 +772,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in + let secvars = secvars_of_constr env c in if Int.equal nmiss 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); @@ -738,6 +780,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, pat = Some pat; name = name; db = None; + secvars; code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; @@ -750,6 +793,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, pat = Some pat; name = name; db = None; + secvars; code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" @@ -806,7 +850,8 @@ let make_resolves env sigma flags pri poly ?name cr = let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] + [make_exact_entry env sigma pri poly ?name; + make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then user_err ~hdr:"Hint" @@ -818,15 +863,17 @@ let make_resolves env sigma flags pri poly ?name cr = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = let hname = NamedDecl.get_id decl in + let c = mkVar hname in try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, NamedDecl.get_type decl, Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") (* REM : in most cases hintname = id *) + let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, @@ -835,6 +882,7 @@ let make_unfold eref = pat = None; name = PathHints [g]; db = None; + secvars = secvars_of_global (Global.env ()) g; code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = @@ -845,6 +893,7 @@ let make_extern pri pat tacast = pat = pat; name = PathAny; db = None; + secvars = Id.Pred.empty; (* Approximation *) code = with_uid (Extern tacast) }) let make_mode ref m = @@ -869,6 +918,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; db = None; + secvars = secvars_of_constr env c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -1329,7 +1379,7 @@ let pr_hints_db (name,db,hintlist) = let pr_hint_list_for_head c = let dbs = current_db () in let validate (name, db) = - let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in + let hints = List.map (fun v -> 0, v) (Hint_db.map_all Id.Pred.full c db) in (name, db, hints) in let valid_dbs = List.map validate dbs in @@ -1351,9 +1401,9 @@ let pr_hint_term cl = let fn = try let hdc = decompose_app_bound cl in if occur_existential cl then - Hint_db.map_existential hdc cl - else Hint_db.map_auto hdc cl - with Bound -> Hint_db.map_none + Hint_db.map_existential ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl + with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in List.map (fun (name, db) -> (name, db, fn db)) dbs diff --git a/tactics/hints.mli b/tactics/hints.mli index 48351a317..edc65c407 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -28,6 +28,8 @@ val decompose_app_bound : constr -> global_reference * constr array type debug = Debug | Info | Off +val secvars_of_hyps : Context.Named.t -> Id.Pred.t + (** Pre-created hint databases *) type 'a hint_ast = @@ -54,7 +56,8 @@ type 'a with_metadata = private { 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 *) + secvars : Id.Pred.t; (** The section variables this hint depends on, as a predicate *) + code : 'a; (** the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -85,22 +88,28 @@ module Hint_db : 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 + + (** All hints which have no pattern. + * [secvars] represent the set of section variables that + * can be used in the hint. *) + val map_none : secvars:Id.Pred.t -> t -> full_hint list (** All hints associated to the reference *) - val map_all : global_reference -> t -> full_hint list + val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) - val map_existential : (global_reference * constr array) -> constr -> t -> full_hint list + val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) - val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_auto : secvars:Id.Pred.t -> + (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 @@ -163,19 +172,20 @@ val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> env -> evar_map -> open_constr -> hint_term -(** [make_exact_entry pri (c, ctyp)]. +(** [make_exact_entry pri (c, ctyp, ctx, secvars)]. [c] is the term given as an exact proof to solve the goal; - [ctyp] is the type of [c]. *) - + [ctyp] is the type of [c]. + [ctx] is its (refreshable) universe context. *) val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry -(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. +(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty,ctx,secvars)]. [eapply] is true if this hint will be used only with EApply; [hnf] should be true if we should expand the head of cty before searching for products; [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [c]. *) + [cty] is the type of [c]. + [ctx] is its (refreshable) universe context. *) val make_apply_entry : env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index de328e23f..e17bbfcb0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4969,7 +4969,7 @@ module New = struct let reduce_after_refine = reduce (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=false;rDelta=false;rConst=[]}) - {onhyps=Some []; concl_occs=AllOccurrences } + {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = Refine.refine ?unsafe c <*> diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b8c07512f..ba85286dd 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/5127.v b/test-suite/bugs/closed/5127.v new file mode 100644 index 000000000..831e8fb50 --- /dev/null +++ b/test-suite/bugs/closed/5127.v @@ -0,0 +1,15 @@ +Fixpoint arrow (n: nat) := + match n with + | S n => bool -> arrow n + | O => bool + end. + +Fixpoint apply (n : nat) : arrow n -> bool := + match n return arrow n -> bool with + | S n => fun f => apply _ (f true) + | O => fun x => x + end. + +Axiom f : arrow 10000. +Definition v : bool := Eval compute in apply _ f. +Definition w : bool := Eval vm_compute in v. diff --git a/test-suite/bugs/closed/5161.v b/test-suite/bugs/closed/5161.v new file mode 100644 index 000000000..d28303b8a --- /dev/null +++ b/test-suite/bugs/closed/5161.v @@ -0,0 +1,27 @@ +(* Check that the presence of binders with type annotation do not + prevent the recursive binder part to be found *) + +From Coq Require Import Utf8. + +Delimit Scope C_scope with C. +Global Open Scope C_scope. + +Delimit Scope uPred_scope with I. + +Definition FORALL {T : Type} (f : T → Prop) : Prop := ∀ x, f x. + +Notation "∀ x .. y , P" := + (FORALL (λ x, .. (FORALL (λ y, P)) ..)%I) + (at level 200, x binder, y binder, right associativity) : uPred_scope. +Infix "∧" := and : uPred_scope. + +(* The next command fails with + In recursive notation with binders, Φ is expected to come without type. + I would expect this notation to work fine, since the ∀ does support + type annotation. +*) +Notation "'{{{' P } } } e {{{ x .. y ; pat , Q } } }" := + (∀ Φ : _ → _, + (∀ x, .. (∀ y, Q ∧ Φ pat) .. ))%I + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e {{{ x .. y ; pat , Q } } }") : uPred_scope. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 2c7b04c62..a2ee2d4c8 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -101,4 +101,4 @@ Error: Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -Error: Extra argument _. +Error: Extra arguments: _, _. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 1633ad976..9d90de47c 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,20 +1,12 @@ -File "stdin", line 1, characters 0-36: -Warning: Ignoring rename of x into y. Only implicit arguments can be renamed. -[arguments-ignore-rename-nonimpl,vernacular] The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +Error: To rename arguments the "rename" flag must be +specified. Argument A renamed to B. File "stdin", line 2, characters 0-25: -Warning: Ignoring rename of A into T. Only implicit arguments can be renamed. -[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 "stdin", line 4, characters 0-40: -Warning: Ignoring rename of x into y. Only implicit arguments can be renamed. -[arguments-ignore-rename-nonimpl,vernacular] +Warning: This command is just asserting the 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] @eq_refl : forall (B : Type) (y : B), y = y eq_refl @@ -112,18 +104,16 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -Error: All arguments lists must declare the same names. +Error: Arguments lists should agree on names they provide. The command has indeed failed with message: -Error: The following arguments are not declared: x. +Error: Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: Error: Arguments names must be distinct. 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 "stdin", line 53, characters 0-26: -Warning: Ignoring rename of x into s. Only implicit arguments can be renamed. -[arguments-ignore-rename-nonimpl,vernacular] +Error: Extra arguments: y. The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +Error: To rename arguments the "rename" flag must be +specified. Argument A renamed to R. diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v index e42c98336..2d14c94ac 100644 --- a/test-suite/output/Arguments_renaming.v +++ b/test-suite/output/Arguments_renaming.v @@ -1,5 +1,5 @@ Fail Arguments eq_refl {B y}, [B] y. -Arguments identity T _ _. +Arguments identity A _ _. Arguments eq_refl A x : assert. Arguments eq_refl {B y}, [B] y : rename. @@ -46,9 +46,9 @@ About myplus. Check @myplus. Fail Arguments eq_refl {F g}, [H] k. -Fail Arguments eq_refl {F}, [F]. +Fail Arguments eq_refl {F}, [F] : rename. Fail Arguments eq_refl {F F}, [F] F. -Fail Arguments eq {F} x [z]. +Fail Arguments eq {F} x [z] : rename. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index a7bde5ea3..1ff09e3af 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,6 @@ The command has indeed failed with message: -Error: Ltac variable y depends on pattern variable name z which is not bound in current context. +Error: +Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize dependent z diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v index 976bec737..e25510cf0 100644 --- a/test-suite/success/clear.v +++ b/test-suite/success/clear.v @@ -13,3 +13,21 @@ Goal forall y z, (forall x:nat, x=y -> True) -> y=z -> True. reflexivity. Qed. +Class A. + +Section Foo. + + Variable a : A. + + Goal A. + solve [typeclasses eauto]. + Undo 1. + clear a. + try typeclasses eauto. + assert(a:=Build_A). + solve [ typeclasses eauto ]. + Undo 2. + assert(b:=Build_A). + solve [ typeclasses eauto ]. + Qed. +End Foo.
\ No newline at end of file diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index f0f8f1864..e9771cfa4 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,7 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with !Pp_control.err_ft x +let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index f7fafab49..891662b93 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -755,7 +755,7 @@ let pr_constraints printenv env sigma evars cstrs = let evs = prlist (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ - str " : " ++ pr_lconstr_env env' sigma evi.evar_concl) l + str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l in h 0 (pe ++ evs ++ pr_evar_constraints cstrs) else diff --git a/toplevel/record.ml b/toplevel/record.ml index a8f8c9293..c43b32762 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -519,10 +519,6 @@ let add_inductive_class ind = let k = let ctx = oneind.mind_arity_ctxt in let inst = Univ.UContext.instance mind.mind_universes in - let map = function - | LocalDef _ -> None - | LocalAssum (_, t) -> Some (lazy t) - in let ty = Inductive.type_of_inductive (push_rel_context ctx (Global.env ())) ((mind,oneind),inst) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 74adf497e..0f3a90c3e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,7 +143,7 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + Pp.msg_with ~pp_tag:Ppstyle.pp_tag !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; @@ -181,7 +181,7 @@ let pp_cmd_header loc com = and take control of the console. *) let print_cmd_header loc com = - Pp.pp_with !Pp_control.std_ft (pp_cmd_header loc com); + Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 27da3f36c..2c7fd46cf 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -974,182 +974,255 @@ let vernac_declare_implicits locality r l = let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" (fun sr -> - strbrk "This command is just asserting the number and names of arguments of " ++ + strbrk "This command is just asserting the names of arguments of " ++ pr_global sr ++ strbrk". If this is what you want add " ++ strbrk "': assert' to silence the warning. If you want " ++ strbrk "to clear implicit arguments add ': clear implicits'. " ++ strbrk "If you want to clear notation scopes add ': clear scopes'") - -let warn_renaming_nonimplicit = - 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.") - -let vernac_declare_arguments locality r l nargs flags = - let extra_scope_flag = List.mem `ExtraScopes flags in - let names = List.map (List.map (fun { name } -> name)) l in - let names, rest = List.hd names, List.tl names in - let scopes = List.map (List.map (fun { notation_scope = s } -> s)) l in - if List.exists (fun na -> not (List.equal Name.equal na names)) rest then - error "All arguments lists must declare the same names."; - if not (List.distinct_f Name.compare (List.filter ((!=) Anonymous) names)) - then error "Arguments names must be distinct."; - let sr = smart_global r in + +(* [nargs_for_red] is the number of arguments required to trigger reduction, + [args] is the main list of arguments statuses, + [more_implicits] is a list of extra lists of implicit statuses *) +let vernac_arguments locality reference args more_implicits nargs_for_red flags = + let assert_flag = List.mem `Assert flags in + let rename_flag = List.mem `Rename flags in + let clear_scopes_flag = List.mem `ClearScopes flags in + let extra_scopes_flag = List.mem `ExtraScopes flags in + let clear_implicits_flag = List.mem `ClearImplicits flags in + let default_implicits_flag = List.mem `DefaultImplicits flags in + let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + + let err_incompat x y = + error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in + + if assert_flag && rename_flag then + err_incompat "assert" "rename"; + if Option.has_some nargs_for_red && never_unfold_flag then + err_incompat "simpl never" "/"; + if never_unfold_flag && List.mem `ReductionDontExposeCase flags then + err_incompat "simpl never" "simpl nomatch"; + if clear_scopes_flag && extra_scopes_flag then + err_incompat "clear scopes" "extra scopes"; + if clear_implicits_flag && default_implicits_flag then + err_incompat "clear implicits" "default implicits"; + + let sr = smart_global reference in let inf_names = let ty = Global.type_of_global_unsafe sr in - Impargs.compute_implicits_names (Global.env ()) ty in - let rec check li ld ls = match li, ld, ls with - | [], [], [] -> () - | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls - | [], _::_, (Some _)::ls when extra_scope_flag -> - error "Extra notation scopes can be set on anonymous arguments only" - | [], x::_, _ -> user_err ~hdr:"vernac_declare_arguments" - (str "Extra argument " ++ pr_name x ++ str ".") - | l, [], _ -> user_err ~hdr:"vernac_declare_arguments" - (str "The following arguments are not declared: " ++ - prlist_with_sep pr_comma pr_name l ++ str ".") - | _::li, _::ld, _::ls -> check li ld ls - | _ -> assert false in - let () = match l with - | [[]] 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 + Impargs.compute_implicits_names (Global.env ()) ty in - (* we take extra scopes apart, and we check they are consistent *) - let l, scopes = - let scopes, rest = List.hd scopes, List.tl scopes in - if List.exists (List.exists ((!=) None)) rest then - error "Notation scopes can be given only once"; - if not extra_scope_flag then l, scopes else - let l, _ = List.split (List.map (List.chop (List.length inf_names)) l) in - l, scopes in - (* we interpret _ as the inferred names *) - let l = match l with - | [[]] -> l - | _ -> - let name_anons = function - | { name = Anonymous } as x, Name id -> { x with name = Name id } - | x, _ -> x in - List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in - let names_decl = List.map (List.map (fun { name } -> name)) l in - let renamed_arg = ref None in - let set_renamed a b = - if Option.is_empty !renamed_arg && not (Id.equal a b) then - renamed_arg := Some(b,a) + let prev_names = + try Arguments_renaming.arguments_names sr with Not_found -> inf_names in - let some_renaming_specified = - try - let names = Arguments_renaming.arguments_names sr in - not (List.equal (List.equal Name.equal) names names_decl) - with Not_found -> false in - let some_renaming_specified, implicits = - match l with - | [[]] -> false, [[]] + let num_args = List.length inf_names in + assert (Int.equal num_args (List.length prev_names)); + + let names_of args = List.map (fun a -> a.name) args in + + (* Checks *) + + let err_extra_args names = + user_err ~hdr:"vernac_declare_arguments" + (strbrk "Extra arguments: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + let err_missing_args names = + user_err ~hdr:"vernac_declare_arguments" + (strbrk "The following arguments are not declared: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + + let rec check_extra_args extra_args = + match extra_args with + | [] -> () + | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) + | { name = Anonymous; notation_scope = Some _ } :: args -> + check_extra_args args | _ -> - let some_renaming = ref some_renaming_specified in - let rec aux il = - match il with - | [] -> [] - | il :: ils -> aux_single il inf_names :: aux ils - and aux_single impl inf_names = - match impl, inf_names with - | [], _ -> [] - | { name = Anonymous; - implicit_status = (`Implicit|`MaximallyImplicit)} :: _, - Name id :: _ -> - assert false - | { name = Name x; - implicit_status = (`Implicit|`MaximallyImplicit)} :: _, - Anonymous :: _ -> - user_err ~hdr:"vernac_declare_arguments" - (str"Argument "++ pr_id x ++str " cannot be declared implicit.") - | { name = Name iid; - implicit_status = (`Implicit|`MaximallyImplicit as i)} :: impl, - Name id :: inf_names -> - let max = i = `MaximallyImplicit in - set_renamed iid id; - some_renaming := !some_renaming || not (Id.equal iid id); - (ExplByName id,max,false) :: aux_single impl inf_names - | { name = Name iid } :: impl, - Name id :: inf_names when not (Id.equal iid id) -> - warn_renaming_nonimplicit (id, iid); - aux_single impl inf_names - | { name = Name iid } :: impl, Name id :: inf_names - when not (Id.equal iid id) -> - aux_single impl inf_names - | { name = Name iid } :: impl, Name id :: inf_names -> - set_renamed iid id; - some_renaming := !some_renaming || not (Id.equal iid id); - aux_single impl inf_names - | _ :: impl, _ :: inf_names -> - (* no rename, no implicit status *) aux_single impl inf_names - | _ :: _, [] -> assert false (* checked before in check() *) - in - !some_renaming, aux l in - (* We check if renamed arguments do match previously declared imp args, - * since the system has this invariant *) - let some_implicits_specified = - match implicits with [[]] -> false | _ -> true in - if some_renaming_specified then - if not (List.mem `Rename flags) then - user_err ~hdr:"vernac_declare_arguments" - (str "To rename arguments the \"rename\" flag must be specified." ++ - match !renamed_arg with - | None -> mt () - | Some (o,n) -> - str "\nArgument " ++ pr_id o ++ - str " renamed to " ++ pr_id n ++ str ".") - else - Arguments_renaming.rename_arguments - (make_section_locality locality) sr names_decl; - (* All other infos are in the first item of l *) - let l = List.hd l in - let scopes = List.map (function - | None -> None - | Some (o, k) -> - try ignore (Notation.find_scope k); Some k - with UserError _ -> - Some (Notation.find_delimiters_scope o k)) scopes + error "Extra notation scopes can be set on anonymous and explicit arguments only." + in + + let args, scopes = + let scopes = List.map (fun { notation_scope = s } -> s) args in + if List.length args > num_args then + let args, extra_args = List.chop num_args args in + if extra_scopes_flag then + (check_extra_args extra_args; (args, scopes)) + else err_extra_args (names_of extra_args) + else args, scopes + in + + if Option.cata (fun n -> n > num_args) false nargs_for_red then + error "The \"/\" modifier should be put before any extra scope."; + + let scopes_specified = List.exists Option.has_some scopes in + + if scopes_specified && clear_scopes_flag then + error "The \"clear scopes\" flag is incompatible with scope annotations."; + + let names = List.map (fun { name } -> name) args in + let names = names :: List.map (List.map fst) more_implicits in + + let rename_flag_required = ref false in + let example_renaming = ref None in + let save_example_renaming renaming = + rename_flag_required := !rename_flag_required + || not (Name.equal (fst renaming) Anonymous); + if Option.is_empty !example_renaming then + example_renaming := Some renaming + in + + let rec names_union names1 names2 = + match names1, names2 with + | [], [] -> [] + | _ :: _, [] -> names1 + | [], _ :: _ -> names2 + | (Name _ as name) :: names1, Anonymous :: names2 + | Anonymous :: names1, (Name _ as name) :: names2 -> + name :: names_union names1 names2 + | name1 :: names1, name2 :: names2 -> + if Name.equal name1 name2 then + name1 :: names_union names1 names2 + else error "Arguments lists should agree on names they provide." + in + + let initial = List.make num_args Anonymous in + let names = List.fold_left names_union initial names in + + let rec rename prev_names names = + match prev_names, names with + | [], [] -> [] + | [], _ :: _ -> err_extra_args names + | _ :: _, [] when assert_flag -> + (* Error messages are expressed in terms of original names, not + renamed ones. *) + err_missing_args (List.lastn (List.length prev_names) inf_names) + | _ :: _, [] -> prev_names + | prev :: prev_names, Anonymous :: names -> + prev :: rename prev_names names + | prev :: prev_names, (Name id as name) :: names -> + if not (Name.equal prev name) then save_example_renaming (prev,name); + name :: rename prev_names names + in + + let names = rename prev_names names in + let renaming_specified = Option.has_some !example_renaming in + + if not (List.distinct_f Name.compare (List.filter ((!=) Anonymous) names)) then + error "Arguments names must be distinct."; + + if !rename_flag_required && not rename_flag then + user_err ~hdr:"vernac_declare_arguments" + (strbrk "To rename arguments the \"rename\" flag must be specified." + ++ + match !example_renaming with + | None -> mt () + | Some (o,n) -> + str "\nArgument " ++ pr_name o ++ + str " renamed to " ++ pr_name n ++ str "."); + + + (* Parts of this code are overly complicated because the implicit arguments + API is completely crazy: positions (ExplByPos) are elaborated to + names. This is broken by design, since not all arguments have names. So + eventhough we eventually want to map only positions to implicit statuses, + we have to check whether the corresponding arguments have names, not to + trigger an error in the impargs code. Even better, the names we have to + check are not the current ones (after previous renamings), but the original + ones (inferred from the type). *) + + let implicits = + List.map (fun { name; implicit_status = i } -> (name,i)) args + in + let implicits = implicits :: more_implicits in + + let open Vernacexpr in + let rec build_implicits inf_names implicits = + match inf_names, implicits with + | _, [] -> [] + | _ :: inf_names, (_, NotImplicit) :: implicits -> + build_implicits inf_names implicits + + (* With the current impargs API, it is impossible to make an originally + anonymous argument implicit *) + | Anonymous :: _, (name, _) :: _ -> + user_err ~hdr:"vernac_declare_arguments" + (strbrk"Argument "++ pr_name name ++ + strbrk " cannot be declared implicit.") + + | Name id :: inf_names, (name, impl) :: implicits -> + let max = impl = MaximallyImplicit in + (ExplByName id,max,false) :: build_implicits inf_names implicits + + | _ -> assert false (* already checked in [names_union] *) in - let some_scopes_specified = List.exists ((!=) None) scopes in + + let implicits = List.map (build_implicits inf_names) implicits in + let implicits_specified = match implicits with [[]] -> false | _ -> true in + + if implicits_specified && clear_implicits_flag then + error "The \"clear implicits\" flag is incompatible with implicit annotations"; + + if implicits_specified && default_implicits_flag then + error "The \"default implicits\" flag is incompatible with implicit annotations"; + let rargs = Util.List.map_filter (function (n, true) -> Some n | _ -> None) - (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 l) in - if some_scopes_specified || List.mem `ClearScopes flags then - vernac_arguments_scope locality r scopes; - if not some_implicits_specified && List.mem `DefaultImplicits flags then - vernac_declare_implicits locality r [] - else if some_implicits_specified || List.mem `ClearImplicits flags then - vernac_declare_implicits locality r implicits; - if nargs >= 0 && nargs <= List.fold_left max ~-1 rargs then - error "The \"/\" option must be placed after the last \"!\"."; - let no_flags = List.is_empty flags in + (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) + in + let rec narrow = function | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl in - let flags = narrow flags in - let some_simpl_flags_specified = - not (List.is_empty rargs) || nargs >= 0 || not (List.is_empty flags) in - if some_simpl_flags_specified then begin + | [] -> [] | _ :: tl -> narrow tl + in + let red_flags = narrow flags in + let red_modifiers_specified = + not (List.is_empty rargs) || Option.has_some nargs_for_red + || not (List.is_empty red_flags) + in + + if not (List.is_empty rargs) && never_unfold_flag then + err_incompat "simpl never" "!"; + + + (* Actions *) + + if renaming_specified then begin + let local = make_section_locality locality in + Arguments_renaming.rename_arguments local sr names + end; + + if scopes_specified || clear_scopes_flag then begin + let scopes = List.map (Option.map (fun (o,k) -> + try ignore (Notation.find_scope k); k + with UserError _ -> + Notation.find_delimiters_scope o k)) scopes + in + vernac_arguments_scope locality reference scopes + end; + + if implicits_specified || clear_implicits_flag then + vernac_declare_implicits locality reference implicits; + + if default_implicits_flag then + vernac_declare_implicits locality reference []; + + if red_modifiers_specified then begin match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - (make_section_locality locality) c (rargs, nargs, flags) + (make_section_locality locality) c + (rargs, Option.default ~-1 nargs_for_red, red_flags) | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") end; - if not (some_renaming_specified || - some_implicits_specified || - some_scopes_specified || - some_simpl_flags_specified) && - no_flags then - warn_arguments_assert sr + if not (renaming_specified || + implicits_specified || + scopes_specified || + red_modifiers_specified) && (List.is_empty flags) then + warn_arguments_assert sr let default_env () = { Notation_term.ninterp_var_type = Id.Map.empty; @@ -1952,8 +2025,8 @@ let interp ?proof ~loc locality poly c = vernac_syntactic_definition locality id c local b | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits locality qid l - | VernacArguments (qid, l, narg, flags) -> - vernac_declare_arguments locality qid l narg flags + | VernacArguments (qid, args, more_implicits, nargs, flags) -> + vernac_arguments locality qid args more_implicits nargs flags | VernacReserve bl -> vernac_reserve bl | VernacGeneralizable gen -> vernac_generalizable locality gen | VernacSetOpacity qidl -> vernac_set_opacity locality qidl |