diff options
185 files changed, 2556 insertions, 1516 deletions
diff --git a/.gitignore b/.gitignore index 709e87cc9c..f9e43a0eb7 100644 --- a/.gitignore +++ b/.gitignore @@ -139,7 +139,7 @@ plugins/ltac/coretactics.ml plugins/ltac/extratactics.ml plugins/ltac/extraargs.ml plugins/ltac/profile_ltac_tactics.ml -ide/coqide_main.ml +ide/coqide_os_specific.ml plugins/ssrmatching/ssrmatching.ml plugins/ssr/ssrparser.ml plugins/ssr/ssrvernac.ml diff --git a/CHANGES.md b/CHANGES.md index 21d9c41073..faf11b9a9e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -24,6 +24,20 @@ Tactics Simplex-based proof engine. In case of regression, 'Unset Simplex' to get the venerable Fourier-based engine. +Tools + +- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: + - `no` disables native_compute + - `yes` enables native_compute and precompiles `.v` files to native code + - `ondemand` enables native_compute but compiles code only when `native_compute` is called + + The default value is `ondemand`. + + Note that this flag now has priority over the configure flag of the same name. + +- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether + conversion can use the VM. The default value is `yes`. + Standard Library - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about @@ -78,7 +78,6 @@ LEXFILES := $(call find, '*.mll') YACCFILES := $(call find, '*.mly') export MLLIBFILES := $(call find, '*.mllib') export MLPACKFILES := $(call find, '*.mlpack') -export ML4FILES := $(call find, '*.ml4') export MLGFILES := $(call find, '*.mlg') export CFILES := $(call findindir, 'kernel/byterun', '*.c') @@ -94,19 +93,14 @@ EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated -GENML4FILES:= $(ML4FILES:.ml4=.ml) GENMLGFILES:= $(MLGFILES:.mlg=.ml) -export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) kernel/copcodes.ml +export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) -# NB: all files in $(GENFILES) can be created initially, while -# .ml files in $(GENML4FILES) might need some intermediate building. -# That's why we keep $(GENML4FILES) out of $(GENFILES) - ## More complex file lists -export MLSTATICFILES := $(filter-out $(GENMLFILES) $(GENML4FILES) $(GENMLGFILES), $(EXISTINGML)) +export MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) include Makefile.common @@ -194,7 +188,7 @@ META.coq: META.coq.in # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean alienclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean clean: objclean cruftclean depclean docclean camldevfilesclean @@ -202,7 +196,7 @@ cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean objclean: archclean indepclean -cruftclean: ml4clean +cruftclean: mlgclean find . \( -name '*~' -o -name '*.annot' \) -exec rm -f {} + rm -f gmon.out core @@ -252,8 +246,8 @@ clean-ide: rm -f ide/utf8_convert.ml rm -rf $(COQIDEAPP) -ml4clean: - rm -f $(GENML4FILES) $(GENMLGFILES) +mlgclean: + rm -f $(GENMLGFILES) depclean: find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + @@ -286,7 +280,7 @@ KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') -KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ +KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(MLPACKFILES:.mlpack=.ml) \ $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ $(MLIFILES:.mli=.cmi) \ @@ -308,7 +302,7 @@ include Makefile.ci .PHONY: tags printenv tags: - echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ + echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ etags --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ @@ -317,12 +311,12 @@ tags: "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/module[ \t]+\([^ \t]+\)/\1/" - echo $(ML4FILES) | sort -r | xargs \ + echo $(MLGFILES) | sort -r | xargs \ etags --append --language=none\ "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" checker-tags: - echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ + echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ etags --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ @@ -331,7 +325,7 @@ checker-tags: "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/module[ \t]+\([^ \t]+\)/\1/" - echo $(ML4FILES) | sort -r | xargs \ + echo $(MLGFILES) | sort -r | xargs \ etags --append --language=none\ "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" diff --git a/Makefile.build b/Makefile.build index 08863014ea..fb84a131c7 100644 --- a/Makefile.build +++ b/Makefile.build @@ -86,7 +86,7 @@ byte: coqbyte coqide-byte pluginsbyte printers # This list of ml files used to be in the main Makefile, we moved it here # to avoid exhausting the variable env in Win32 -MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) +MLFILES := $(MLSTATICFILES) $(GENMLFILES) include Makefile.common include Makefile.vofiles @@ -148,7 +148,7 @@ endif # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like -# coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). +# coqdep_boot (for the .v.d files) or coqpp (for .mlg -> .ml -> .ml.d). VDFILE := .vfiles MLDFILE := .mlfiles @@ -166,7 +166,7 @@ DEPENDENCIES := \ # of include, and they will then be automatically deleted, leading to an # infinite loop. -.SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml) +.SECONDARY: $(DEPENDENCIES) $(GENFILES) $(MLGFILES:.mlg=.ml) ########################################################################### # Compilation options @@ -259,6 +259,7 @@ CAMLP5DEPS:=grammar/grammar.cma CAMLP5USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) +# XXX unused but should be used for mlp files # Main packages linked by Coq. SYSMOD:=-package num,str,unix,dynlink,threads @@ -768,11 +769,6 @@ kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 $(SHOW)'OCAMLYACC $<' $(HIDE)$(OCAMLYACC) --strict "$*.mly" -%.ml: %.ml4 $(CAMLP5DEPS) $(COQPP) - $(SHOW)'CAMLP5O $<' - $(HIDE)$(CAMLP5O) -I $(MYCAMLP5LIB) $(PR_O) \ - $(CAMLP5DEPS) $(CAMLP5USE) $(CAMLP5COMPAT) -impl $< -o $@ - %.ml: %.mlg $(COQPP) $(SHOW)'COQPP $<' $(HIDE)$(COQPP) $< @@ -782,7 +778,7 @@ kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 ########################################################################### # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) -OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack +OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .mlpack MAINMLFILES := $(filter-out checker/% plugins/%, $(MLFILES) $(MLIFILES)) MAINMLLIBFILES := $(filter-out checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) diff --git a/Makefile.ide b/Makefile.ide index 6c069a1e50..39af1f8545 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -49,8 +49,8 @@ IDETOPEXE=bin/coqidetop$(EXE) IDETOP=bin/coqidetop.opt$(EXE) IDETOPBYTE=bin/coqidetop.byte$(EXE) -LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.mli ide/coqide_main.ml -LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.mli ide/coqide_main.ml +LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_os_specific.cmo ide/coqide_main.mli ide/coqide_main.ml +LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_os_specific.cmx ide/coqide_main.mli ide/coqide_main.ml IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map @@ -110,10 +110,10 @@ $(COQIDEBYTE): $(LINKIDE) $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ -ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp5deps here - $(SHOW)'CAMLP5O $<' - $(HIDE)$(CAMLP5O) -I $(MYCAMLP5LIB) $(PR_O) $(CAMLP5USE) -D$(IDEINT) -impl $< -o $@ - +ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile + @rm -f $@ + cp $< $@ + @chmod -w $@ ide/%.cmi: ide/%.mli $(SHOW)'OCAMLC $<' diff --git a/checker/cic.mli b/checker/cic.mli index 4162903b04..754cc2a096 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -221,6 +221,8 @@ type typing_flags = { check_universes : bool; (** If [false] universe constraints are not checked *) conv_oracle : oracle; (** Unfolding strategies for conversion *) share_reduction : bool; (** Use by-need reduction algorithm *) + enable_VM : bool; (** If [false], all VM conversions fall back to interpreted ones *) + enable_native_compiler : bool; (** If [false], all native conversions fall back to VM ones *) } type constant_body = { diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 50e65ef587..f6c510ee1c 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -531,10 +531,11 @@ let check_positivity env_ar mind params nrecp inds = Array.mapi (fun j t -> (Mrec(mind,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = List.rev (Array.to_list rc) in let lparams = rel_context_length params in + let ra_env = + List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in + let env_ar_par = push_rel_context params env_ar in let check_one i mip = - let ra_env = - List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in - let ienv = (env_ar, 1+lparams, ntypes, ra_env) in + let ienv = (env_ar_par, 1+lparams, ntypes, ra_env) in check_positivity_one ienv params nrecp (mind,i) mip.mind_nf_lc in let irecargs = Array.mapi check_one inds in diff --git a/checker/inductive.ml b/checker/inductive.ml index 5e34f04f51..269a98cb0e 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -388,7 +388,7 @@ let type_case_branches env (pind,largs) (p,pj) c = let check_case_info env indsp ci = let mib, mip as spec = lookup_mind_specif env indsp in if - not (eq_ind_chk indsp ci.ci_ind) || + not (mind_equiv env indsp ci.ci_ind) || (mib.mind_nparams <> ci.ci_npar) || (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) || (mip.mind_consnrealargs <> ci.ci_cstr_nargs) || diff --git a/checker/reduction.ml b/checker/reduction.ml index 58a3f4e410..1158152f63 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -192,10 +192,7 @@ let convert_constructors | Monomorphic_ind _ | Polymorphic_ind _ -> convert_universes univs u1 u2 | Cumulative_ind cumi -> let num_cnstr_args = - let nparamsctxt = - mind.mind_nparams + mind.mind_packets.(ind).mind_nrealargs - in - nparamsctxt + mind.mind_packets.(ind).mind_consnrealargs.(cns - 1) + mind.mind_nparams + mind.mind_packets.(ind).mind_consnrealargs.(cns - 1) in if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then convert_universes univs u1 u2 diff --git a/checker/values.ml b/checker/values.ml index 24f10b7a87..8f6b24ec26 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -15,7 +15,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 a127e0c2322c7846914bbca9921309c7 checker/cic.mli +MD5 b8f0139f14e3370cd0a45d4cf69882ea checker/cic.mli *) @@ -230,7 +230,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool|] let v_const_univs = v_sum "constant_universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] diff --git a/clib/cArray.ml b/clib/cArray.ml index 9644834381..c3a693ff16 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -35,6 +35,8 @@ sig val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + val fold_right3 : + ('a -> 'b -> 'c -> 'd -> 'd) -> 'a array -> 'b array -> 'c array -> 'd -> 'd val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a val fold_left3 : @@ -252,6 +254,16 @@ let fold_left2_i f a v1 v2 = if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2_i"; fold a 0 +let fold_right3 f v1 v2 v3 a = + let lv1 = Array.length v1 in + let rec fold a n = + if n=0 then a + else + let k = n-1 in + fold (f (uget v1 k) (uget v2 k) (uget v3 k) a) k in + if Array.length v2 <> lv1 || Array.length v3 <> lv1 then invalid_arg "Array.fold_right3"; + fold a lv1 + let fold_left3 f a v1 v2 v3 = let lv1 = Array.length v1 in let rec fold a n = diff --git a/clib/cArray.mli b/clib/cArray.mli index e65a56d15e..21479d2b45 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -58,6 +58,8 @@ sig val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + val fold_right3 : + ('a -> 'b -> 'c -> 'd -> 'd) -> 'a array -> 'b array -> 'c array -> 'd -> 'd val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a val fold_left3 : diff --git a/clib/cMap.ml b/clib/cMap.ml index 040dede0a2..e4ce6c7c02 100644 --- a/clib/cMap.ml +++ b/clib/cMap.ml @@ -35,6 +35,7 @@ sig val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val height : 'a t -> int + val filter_range : (key -> int) -> 'a t -> 'a t module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t @@ -62,6 +63,7 @@ sig val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val height : 'a map -> int + val filter_range : (M.t -> int) -> 'a map -> 'a map module Smart : sig val map : ('a -> 'a) -> 'a map -> 'a map @@ -85,8 +87,11 @@ struct if this happens, we can still implement a less clever version of [domain]. *) - type 'a map = 'a Map.Make(M).t - type set = Set.Make(M).t + module F = Map.Make(M) + type 'a map = 'a F.t + + module S = Set.Make(M) + type set = S.t type 'a _map = | MEmpty @@ -164,6 +169,23 @@ struct | MEmpty -> 0 | MNode (_, _, _, _, h) -> h + (* Filter based on a range *) + let filter_range in_range m = + let rec aux m = function + | MEmpty -> m + | MNode (l, k, v, r, _) -> + let vr = in_range k in + (* the range is below the current value *) + if vr < 0 then aux m (map_prj l) + (* the range is above the current value *) + else if vr > 0 then aux m (map_prj r) + (* The current value is in the range *) + else + let m = aux m (map_prj l) in + let m = aux m (map_prj r) in + F.add k v m + in aux F.empty (map_prj m) + module Smart = struct diff --git a/clib/cMap.mli b/clib/cMap.mli index f5496239f6..ca6ddb2f4e 100644 --- a/clib/cMap.mli +++ b/clib/cMap.mli @@ -60,6 +60,12 @@ sig val height : 'a t -> int (** An indication of the logarithmic size of a map *) + val filter_range : (key -> int) -> 'a t -> 'a t + (** [find_range in_range m] Given a comparison function [in_range x], + that tests if [x] is below, above, or inside a given range + [filter_range] returns the submap of [m] whose keys are in + range. Note that [in_range] has to define a continouous range. *) + module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t diff --git a/clib/hMap.ml b/clib/hMap.ml index 33cb6d0131..9c80398e4d 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -398,6 +398,10 @@ struct let height s = Int.Map.height s + (* Not as efficient as the original version *) + let filter_range f s = + filter (fun x _ -> f x = 0) s + module Unsafe = struct let map f s = diff --git a/configure.ml b/configure.ml index f884a7de5c..39c65683ff 100644 --- a/configure.ml +++ b/configure.ml @@ -1332,7 +1332,7 @@ let write_makefile f = pr "# Option to control compilation and installation of the documentation\n"; pr "WITHDOC=%s\n\n" (if !prefs.withdoc then "all" else "no"); pr "# Option to produce precompiled files for native_compute\n"; - pr "NATIVECOMPUTE=%s\n" (if !prefs.nativecompiler then "-native-compiler" else ""); + pr "NATIVECOMPUTE=%s\n" (if !prefs.nativecompiler then "-native-compiler yes" else ""); pr "COQWARNERROR=%s\n" (if !prefs.warn_error then "-w +default" else ""); close_out o; Unix.chmod f 0o444 diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 93a07cff9d..8e10ec49ce 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -102,6 +102,7 @@ type classification = | ClassifName of string type vernac_rule = { + vernac_atts : (string * string) list option; vernac_toks : ext_token list; vernac_class : code option; vernac_depr : bool; diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index cdea4b99ef..c38755943a 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -130,6 +130,7 @@ rule extend = parse | space { extend lexbuf } | '\"' { string lexbuf } | '\n' { newline lexbuf; extend lexbuf } +| "#[" { HASHBRACKET } | '[' { LBRACKET } | ']' { RBRACKET } | '|' { PIPE } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 5314806c24..7cecff9d75 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -309,9 +309,52 @@ let print_rule_classifier fmt r = match r.vernac_class with else fprintf fmt "Some @[(fun %a-> %a)@]" print_binders r.vernac_toks print_code f +(* let print_atts fmt = function *) +(* | None -> fprintf fmt "@[let () = Attributes.unsupported_attributes atts in@] " *) +(* | Some atts -> *) +(* let rec print_left fmt = function *) +(* | [] -> assert false *) +(* | [x,_] -> fprintf fmt "%s" x *) +(* | (x,_) :: rem -> fprintf fmt "(%s, %a)" x print_left rem *) +(* in *) +(* let rec print_right fmt = function *) +(* | [] -> assert false *) +(* | [_,y] -> fprintf fmt "%s" y *) +(* | (_,y) :: rem -> fprintf fmt "(%s ++ %a)" y print_right rem *) +(* in *) +(* let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in *) +(* fprintf fmt "@[let %a = Attributes.parse %s(%a) atts in@] " *) +(* print_left atts nota print_right atts *) + +let print_atts_left fmt = function + | None -> fprintf fmt "()" + | Some atts -> + let rec aux fmt = function + | [] -> assert false + | [x,_] -> fprintf fmt "%s" x + | (x,_) :: rem -> fprintf fmt "(%s, %a)" x aux rem + in + aux fmt atts + +let print_atts_right fmt = function + | None -> fprintf fmt "(Attributes.unsupported_attributes atts)" + | Some atts -> + let rec aux fmt = function + | [] -> assert false + | [_,y] -> fprintf fmt "%s" y + | (_,y) :: rem -> fprintf fmt "(%s ++ %a)" y aux rem + in + let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in + fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts + +let print_body_fun fmt r = + fprintf fmt "let coqpp_body %a%a ~st = let () = %a in st in " + print_binders r.vernac_toks print_atts_left r.vernac_atts print_code r.vernac_body + let print_body fmt r = - fprintf fmt "@[(fun %a~atts@ ~st@ -> let () = %a in st)@]" - print_binders r.vernac_toks print_code r.vernac_body + fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" + print_body_fun r print_binders r.vernac_toks + print_binders r.vernac_toks print_atts_right r.vernac_atts let rec print_sig fmt = function | [] -> fprintf fmt "@[Vernacentries.TyNil@]" diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index 1fb5461b21..abe52ab46b 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -65,7 +65,7 @@ let parse_user_entry s sep = %token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED ARGUMENT %token RAW_PRINTED GLOB_PRINTED %token COMMAND CLASSIFIED PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS -%token LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR +%token HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR %token LPAREN RPAREN COLON SEMICOLON %token GLOBAL FIRST LAST BEFORE AFTER LEVEL LEFTA RIGHTA NONA %token EOF @@ -209,15 +209,32 @@ vernac_rules: ; vernac_rule: -| PIPE LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE +| PIPE vernac_attributes_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE { { - vernac_toks = $3; - vernac_depr = $5; - vernac_class= $6; - vernac_body = $8; + vernac_atts = $2; + vernac_toks = $4; + vernac_depr = $6; + vernac_class= $7; + vernac_body = $9; } } ; +vernac_attributes_opt: +| { None } +| HASHBRACKET vernac_attributes RBRACKET { Some $2 } +; + +vernac_attributes: +| vernac_attribute { [$1] } +| vernac_attribute SEMICOLON { [$1] } +| vernac_attribute SEMICOLON vernac_attributes { $1 :: $3 } +; + +vernac_attribute: +| qualid_or_ident EQUAL qualid_or_ident { ($1, $3) } +| qualid_or_ident { ($1, $1) } +; + rule_deprecation: | { false } | DEPRECATED { true } diff --git a/default.nix b/default.nix index 9a7afbe89e..7c8113c9ab 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/06613c189eebf4d6167d2d010a59cf38b43b6ff4.tar.gz"; - sha256 = "13grhy3cvdwr7wql1rm5d7zsfpvp44cyjhiain4zs70r90q3swdg"; + url = "https://github.com/NixOS/nixpkgs/archive/69522a0acf8e840e8b6ac0a9752a034ab74eb3c0.tar.gz"; + sha256 = "12k80gd4lkw9h9y1szvmh0jmh055g3b6wnphmx4ab1qdwlfaylnx"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true @@ -33,6 +33,7 @@ , shell ? false # We don't use lib.inNixShell because that would also apply # when in a nix-shell of some package depending on this one. +, coq-version ? "8.10-git" }: with pkgs; @@ -101,7 +102,20 @@ stdenv.mkDerivation rec { installCheckTarget = [ "check" ]; - passthru = { inherit ocamlPackages; }; + passthru = { + inherit coq-version ocamlPackages; + dontFilter = true; # Useful to use mkCoqPackages from <nixpkgs> + }; + + setupHook = writeText "setupHook.sh" " + addCoqPath () { + if test -d \"$1/lib/coq/${coq-version}/user-contrib\"; then + export COQPATH=\"$COQPATH\${COQPATH:+:}$1/lib/coq/${coq-version}/user-contrib/\" + fi + } + + addEnvHooks \"$targetOffset\" addCoqPath + "; meta = { description = "Coq proof assistant"; @@ -113,6 +127,7 @@ stdenv.mkDerivation rec { ''; homepage = http://coq.inria.fr; license = licenses.lgpl21; + platforms = platforms.unix; }; } diff --git a/dev/ci/README.md b/dev/ci/README.md index 7853866f62..4709247549 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -26,7 +26,8 @@ our CI. This means that: On the condition that: -- At the time of the submission, your development works with Coq master branch. +- At the time of the submission, your development works with Coq's + `master` branch. - Your development is publicly available in a git repository and we can easily send patches to you (e.g. through pull / merge requests). @@ -60,6 +61,19 @@ performance benchmark. Currently this is done by providing an OPAM package in https://github.com/coq/opam-coq-archive and opening an issue at https://github.com/coq/coq-bench/issues. +### Recommended branching policy. + +It is sometimes the case that you will need to maintain a branch of +your development for particular Coq versions. This is in fact very +likely if your development includes a Coq ML plugin. + +We thus recommend a branching convention that mirrors Coq's branching +policy. Then, you would have a `master` branch that follows Coq's +`master`, a `v8.8` branch that works with Coq's `v8.8` branch and so +on. + +This convention will be supported by tools in the future to make some +developer commands work more seamlessly. Information for developers -------------------------- diff --git a/dev/ci/user-overlays/08515-command-atts.sh b/dev/ci/user-overlays/08515-command-atts.sh new file mode 100755 index 0000000000..4605255d5e --- /dev/null +++ b/dev/ci/user-overlays/08515-command-atts.sh @@ -0,0 +1,12 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8515" ] || [ "$CI_BRANCH" = "command-atts" ]; then + ltac2_CI_REF=command-atts + ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 + + Equations_CI_REF=command-atts + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + plugin_tutorial_CI_REF=command-atts + plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials +fi diff --git a/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh b/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh new file mode 100644 index 0000000000..81ed91f52b --- /dev/null +++ b/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "8688" ] || [ "$CI_BRANCH" = "master+generalizing-evar-map-printer-over-env" ]; then + + Elpi_CI_REF=master+generalized-evar-printers-pr8688 + Elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi diff --git a/dev/ci/user-overlays/08844-split-tactics.sh b/dev/ci/user-overlays/08844-split-tactics.sh new file mode 100644 index 0000000000..8ad8cba243 --- /dev/null +++ b/dev/ci/user-overlays/08844-split-tactics.sh @@ -0,0 +1,12 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8844" ] || [ "$CI_BRANCH" = "split-tactics" ]; then + Equations_CI_REF=split-tactics + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + ltac2_CI_REF=split-tactics + ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 + + fiat_parsers_CI_REF=split-tactics + fiat_parsers_CI_GITURL=https://github.com/SkySkimmer/fiat +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 68afe7ee4a..7fb73e447d 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -33,3 +33,11 @@ fi ``` (`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](../ci-common.sh)) + +### Branching conventions + +We suggest you use the convention of identical branch names for the +Coq branch and the CI project branch used in the overlay. For example, +if your Coq PR is coming from the branch `more_efficient_tc`, and that +breaks `ltac2`, we suggest you create a `ltac2` overlay with a branch +named `more_efficient_tc`. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index eb5b9ee1d3..b1fdfafd3a 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -32,6 +32,12 @@ Macros: - The RAW_TYPED AS and GLOB_TYPED AS stanzas of the ARGUMENT EXTEND macro are deprecated. Use TYPED AS instead. +- coqpp (.mlg) based VERNAC EXTEND accesses attributes through a `#[ x + = att ]` syntax, where `att : 'a Attributes.attribute` and `x` will + be bound with type `'a` in the expression, unlike the old system + where `atts : Vernacexpr.vernac_flags` was bound in the expression + and had to be manually parsed. + ## Changes between Coq 8.8 and Coq 8.9 ### ML API diff --git a/dev/doc/proof-engine.md b/dev/doc/proof-engine.md index 8f96ac223f..774552237a 100644 --- a/dev/doc/proof-engine.md +++ b/dev/doc/proof-engine.md @@ -42,8 +42,8 @@ goal holes thanks to the `Refine` module, and in particular to the `Refine.refine` primitive. ```ocaml -val refine : typecheck:bool -> Constr.t Sigma.run -> unit tactic -(** In [refine typecheck t], [t] is a term with holes under some +val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic +(** In [refine ~typecheck t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the new holes created by [t] become the new subgoals. Exceptions @@ -51,12 +51,11 @@ val refine : typecheck:bool -> Constr.t Sigma.run -> unit tactic tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) ``` -In a first approximation, we can think of `'a Sigma.run` as -`evar_map -> 'a * evar_map`. What the function does is first evaluate the -`Constr.t Sigma.run` argument in the current proof state, and then use the -resulting term as a filler for the proof under focus. All evars that have been -created by the invocation of this thunk are then turned into new goals added in -the order of their creation. +What the function does is first evaluate the `t` argument in the +current proof state, and then use the resulting term as a filler for +the proof under focus. All evars that have been created by the +invocation of this thunk are then turned into new goals added in the +order of their creation. To see how we can use it, let us have a look at an idealized example, the `cut` tactic. Assuming `X` is a type, `cut X` fills the current goal `[Γ ⊢ _ : A]` @@ -66,8 +65,7 @@ two new holes `[e1, e2]` are added to the goal state in this order. ```ocaml let cut c = - let open Sigma in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (** In this block, we focus on one goal at a time indicated by gl *) let env = Proofview.Goal.env gl in (** Get the context of the goal, essentially [Γ] *) @@ -80,25 +78,22 @@ let cut c = let t = mkArrow c (Vars.lift 1 concl) in (** Build [X -> A]. Note the lifting of [A] due to being on the right hand side of the arrow. *) - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> (** All evars generated by this block will be added as goals *) - let Sigma (f, sigma, p) = Evarutil.new_evar env sigma t in + let sigma, f = Evarutil.new_evar env sigma t in (** Generate ?e1 : [Γ ⊢ _ : X -> A], add it to sigma, and return the term [f := Γ ⊢ ?e1{Γ} : X -> A] with the updated sigma. The identity substitution for [Γ] is extracted from the [env] argument, so that one must be careful to pass the correct context here in order for the resulting term to be well-typed. The [p] return value is a proof term used to enforce sigma monotonicity. *) - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c in + let sigma, x = Evarutil.new_evar env sigma c in (** Generate ?e2 : [Γ ⊢ _ : X] in sigma and return [x := Γ ⊢ ?e2{Γ} : X]. *) let r = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 r, [|mkRel 1|])) in (** Build [r := Γ ⊢ let id : X := ?e2{Γ} in ?e1{Γ} id : A] *) - Sigma (r, sigma, p +> q) - (** Fills the current hole with [r]. The [p +> q] thingy ensures - monotonicity of sigma. *) - end } - end } + end + end ``` The `Evarutil.new_evar` function is the preferred way to generate evars in diff --git a/dev/tools/change-header b/dev/tools/change-header index 61cc866602..687c02f4f1 100755 --- a/dev/tools/change-header +++ b/dev/tools/change-header @@ -22,7 +22,7 @@ lineb='(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)' modified=0 kept=0 -for i in `find . -name \*.mli -o -name \*.ml -o -name \*.ml4 -o -name \*.mll -o -name \*.mly -o -name \*.mlp -o -name \*.v`; do +for i in `find . -name \*.mli -o -name \*.ml -o -name \*.mlg -o -name \*.mll -o -name \*.mly -o -name \*.mlp -o -name \*.v`; do headline=`head -n 1 $i` if `echo $headline | grep "(\* -\*- .* \*)" > /dev/null`; then # Has emacs header diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 44d44ccc4b..fd08f9ffe8 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -168,8 +168,8 @@ let pp_state_t n = pp (Reductionops.pr_state Global.(env()) Evd.empty n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) let ppmetas metas = pp(Termops.pr_metaset metas) -let ppevm evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes (Some 2) evd) -let ppevmall evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes None evd) +let ppevm evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes (Some 2) (Global.env ()) evd) +let ppevmall evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes None (Global.env ()) evd) let pr_existentialset evars = prlist_with_sep spc pr_evar (Evar.Set.elements evars) let ppexistentialset evars = @@ -180,14 +180,14 @@ let ppexistentialfilter filter = match Evd.Filter.repr filter with let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) -let ppgoalsigma g = pp(Printer.pr_goal g ++ Termops.pr_evar_map None (Refiner.project g)) +let ppgoalsigma g = pp(Printer.pr_goal g ++ Termops.pr_evar_map None (Global.env ()) (Refiner.project g)) let pphintdb db = pp(envpp Hints.pr_hint_db_env db) let ppproofview p = let gls,sigma = Proofview.proofview p in - pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) sigma) + pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) (Global.env ()) sigma) let ppopenconstr (x : Evd.open_constr) = - let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_econstr_env c) + let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) (Global.env ()) evd ++ envpp pr_econstr_env c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst index 57f1174d59..4f5064839b 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits.rst @@ -1404,3 +1404,150 @@ The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. | Santiago de Chile, March 2018, | Matthieu Sozeau for the |Coq| development team | + +Credits: version 8.9 +-------------------- + +|Coq| version 8.9 contains the result of refinements and stabilization +of features and deprecations or removals of deprecated features, +cleanups of the internals of the system and API along with a few new +features. This release includes many user-visible changes, including +deprecations that are documented in ``CHANGES.md`` and new features that +are documented in the reference manual. Here are the most important +changes: + +- Kernel: mutually recursive records are now supported, by Pierre-Marie + Pédrot. + +- Notations: + + - Support for autonomous grammars of terms called "custom entries", by + Hugo Herbelin (see section :ref:`custom-entries` of the reference + manual). + + - Deprecated notations of the standard library will be removed in the + next version of |Coq|, see the ``CHANGES.md`` file for a script to + ease porting, by Jason Gross and Jean-Christophe Léchenet. + + - Added the :cmd:`Numeral Notation` command for registering decimal + numeral notations for custom types, by Daniel de Rauglaudre, Pierre + Letouzey and Jason Gross. + +- Tactics: Introduction tactics :tacn:`intro`/:tacn:`intros` on a goal that is an + existential variable now force a refinement of the goal into a + dependent product rather than failing, by Hugo Herbelin. + +- Decision procedures: deprecation of tactic ``romega`` in favor of + :tacn:`lia` and removal of ``fourier``, replaced by :tacn:`lra` which + subsumes it, by Frédéric Besson, Maxime Dénès, Vincent Laporte and + Laurent Théry. + +- Proof language: focusing bracket ``{`` now supports named + :ref:`goals <curly-braces>`, e.g. ``[x]:{`` will focus + on a goal (existential variable) named ``x``, by Théo Zimmermann. + +- SSReflect: the implementation of delayed clear was simplified by + Enrico Tassi: the variables are always renamed using inaccessible + names when the clear switch is processed and finally cleared at the + end of the intro pattern. In addition to that the use-and-discard flag + `{}` typical of rewrite rules can now be also applied to views, + e.g. `=> {}/v` applies `v` and then clears `v`. See section + :ref:`introduction_ssr`. + +- Vernacular: + + - Experimental support for :ref:`attributes <gallina-attributes>` on + commands, by Vincent Laporte, as in ``#[local] Lemma foo : bar.`` + Tactics and tactic notations now support the ``deprecated`` + attribute. + + - Removed deprecated commands ``Arguments Scope`` and ``Implicit + Arguments`` in favor of :cmd:`Arguments`, with the help of Jasper + Hugunin. + + - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to + avoid repeating uniform parameters in constructor declarations. + + - New commands :cmd:`Hint Variables` and :cmd:`Hint Constants`, by + Matthieu Sozeau, for controlling the opacity status of variables and + constants in hint databases. It is recommended to always use these + commands after creating a hint databse with :cmd:`Create HintDb`. + + - Multiple sections with the same name are now allowed, by Jasper + Hugunin. + +- Library: additions and changes in the ``VectorDef``, ``Ascii`` and + ``String`` library. Syntax notations are now available only when using + ``Import`` of libraries and not merely ``Require``, by various + contributors (source of incompatibility, see `CHANGES.md` for details). + +- Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof + steps in color, using the :opt:`Diffs` option, by Jim Fehrle. + +- Documentation: we integrated a large number of fixes to the new Sphinx + documentation by various contributors, coordinated by Clément + Pit-Claudel and Théo Zimmermann. + +- Tools: removed the ``gallina`` utility and the homebrewed ``Emacs`` mode. + +- Packaging: as in |Coq| 8.8.2, the Windows installer now includes many + more external packages that can be individually selected for + installation, by Michael Soegtrop. + +Version 8.9 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system. Most +important ones are documented in the ``CHANGES.md`` file. + +On the implementation side, the ``dev/doc/changes.md`` file documents +the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version and a plugin development tutorial kept in sync with Coq was +introduced by Yves Bertot http://github.com/ybertot/plugin_tutorials. +The new ``dev/doc/critical-bugs`` file documents the known critical bugs +of |Coq| and affected releases. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many +users. A list of packages is available at https://coq.inria.fr/opam/www. + +The 54 contributors for this version are Léo Andrès, Rin Arakaki, +Benjamin Barenblat, Langston Barrett, Siddharth Bhat, Martin Bodin, +Simon Boulier, Timothy Bourke, Joachim Breitner, Tej Chajed, Arthur +Charguéraud, Pierre Courtieu, Maxime Dénès, Andres Erbsen, Jim Fehrle, +Julien Forest, Emilio Jesus Gallego Arias, Gaëtan Gilbert, Matěj +Grabovský, Jason Gross, Samuel Gruetter, Armaël Guéneau, Hugo Herbelin, +Jasper Hugunin, Ralf Jung, Sam Pablo Kuper, Ambroise Lafont, Leonidas +Lampropoulos, Vincent Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, +Jean-Christophe Léchenet, Nick Lewycky, Yishuai Li, Sven M. Hallberg, +Assia Mahboubi, Cyprien Mangin, Guillaume Melquiond, Perry E. Metzger, +Clément Pit-Claudel, Pierre-Marie Pédrot, Daniel R. Grayson, Kazuhiko +Sakaguchi, Michael Soegtrop, Matthieu Sozeau, Paul Steckler, Enrico +Tassi, Laurent Théry, Anton Trunov, whitequark, Théo Winterhalter, +Zeimer, Beta Ziliani, Théo Zimmermann. + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list or +the coq-club@inria.fr mailing list. It would be impossible to mention +exhaustively the names of everybody who to some extent influenced the +development. + +Version 8.9 is the fourth release of |Coq| developed on a time-based +development cycle. Its development spanned 7 months from the release of +|Coq| 8.8. The development moved to a decentralized merging process +during this cycle. Guillaume Melquiond was in charge of the release +process and is the maintainer of this release. This release is the +result of ~2,000 commits and ~500 PRs merged, closing 75+ issues. + +The |Coq| development team welcomed Vincent Laporte, a new |Coq| +engineer working with Maxime Dénès in the |Coq| consortium. + +| Paris, October 2018, +| Matthieu Sozeau for the |Coq| development team +| diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 835d6dcaa6..cc5d9d6205 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -678,7 +678,7 @@ form*. There are several ways (or strategies) to apply the reduction rules. Among them, we have to mention the *head reduction* which will play an important role (see Chapter :ref:`tactics`). Any term :math:`t` can be written as :math:`λ x_1 :T_1 . … λ x_k :T_k . (t_0~t_1 … t_n )` where :math:`t_0` is not an -application. We say then that :math:`t~0` is the *head of* :math:`t`. If we assume +application. We say then that :math:`t_0` is the *head of* :math:`t`. If we assume that :math:`t_0` is :math:`λ x:T. u_0` then one step of β-head reduction of :math:`t` is: .. math:: @@ -771,8 +771,8 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is \odd&:&\nat → \Prop \end{array}\right]} {\left[\begin{array}{rcl} \evenO &:& \even~0\\ - \evenS &:& \forall n, \odd~n -> \even~(\kw{S}~n)\\ - \oddS &:& \forall n, \even~n -> \odd~(\kw{S}~n) + \evenS &:& \forall n, \odd~n → \even~(\kw{S}~n)\\ + \oddS &:& \forall n, \even~n → \odd~(\kw{S}~n) \end{array}\right]} which corresponds to the result of the |Coq| declaration: diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 705d67e6c6..2214cbfb34 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -692,6 +692,8 @@ side. E.g.: Notation "'apply_id' f a1 .. an" := (.. (f a1) .. an) (at level 10, f ident, a1, an at level 9). +.. _custom-entries: + Custom entries ~~~~~~~~~~~~~~ @@ -1372,11 +1374,11 @@ Abbreviations denoted expression is performed at definition time. Type checking is done only at the time of use of the abbreviation. - Numeral notations ----------------- .. cmd:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope. + :name: Numeral Notation This command allows the user to customize the way numeral literals are parsed and printed. diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 3385b78958..cfc4bea85f 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -99,6 +99,14 @@ let isFix sigma c = match kind sigma c with Fix _ -> true | _ -> false let isCoFix sigma c = match kind sigma c with CoFix _ -> true | _ -> false let isCase sigma c = match kind sigma c with Case _ -> true | _ -> false let isProj sigma c = match kind sigma c with Proj _ -> true | _ -> false + +let rec isType sigma c = match kind sigma c with + | Sort s -> (match ESorts.kind sigma s with + | Sorts.Type _ -> true + | _ -> false ) + | Cast (c,_,_) -> isType sigma c + | _ -> false + let isVarId sigma id c = match kind sigma c with Var id' -> Id.equal id id' | _ -> false let isRelN sigma n c = diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 1edc0ee12b..6532e08e9d 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -157,6 +157,8 @@ val isCoFix : Evd.evar_map -> t -> bool val isCase : Evd.evar_map -> t -> bool val isProj : Evd.evar_map -> t -> bool +val isType : Evd.evar_map -> constr -> bool + type arity = rel_context * ESorts.t val destArity : Evd.evar_map -> types -> arity val isArity : Evd.evar_map -> t -> bool diff --git a/engine/evd.ml b/engine/evd.ml index 3a77a2b440..b3848e1b5b 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -483,6 +483,8 @@ let is_typeclass_evar evd evk = let flags = evd.evar_flags in Evar.Set.mem evk flags.typeclass_evars +let get_obligation_evars evd = evd.evar_flags.obligation_evars + let set_obligation_evar evd evk = let flags = evd.evar_flags in let evar_flags = { flags with obligation_evars = Evar.Set.add evk flags.obligation_evars } in diff --git a/engine/evd.mli b/engine/evd.mli index b0e3c2b869..be54bebcd7 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -262,6 +262,9 @@ val get_typeclass_evars : evar_map -> Evar.Set.t val is_typeclass_evar : evar_map -> Evar.t -> bool (** Is the evar declared resolvable for typeclass resolution *) +val get_obligation_evars : evar_map -> Evar.Set.t +(** The set of obligation evars *) + val set_obligation_evar : evar_map -> Evar.t -> evar_map (** Declare an evar as an obligation *) diff --git a/engine/termops.ml b/engine/termops.ml index 5e220fd8f1..52880846f8 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -104,12 +104,7 @@ let debug_print_constr c = pr_constr EConstr.Unsafe.(to_constr c) let debug_print_constr_env env sigma c = pr_constr EConstr.(to_constr sigma c) let term_printer = ref debug_print_constr_env -let print_constr_env env sigma t = !term_printer env sigma t -let print_constr t = - let env = Global.env () in - let evd = Evd.from_env env in - !term_printer env evd t - +let print_constr_env env sigma t = !term_printer (env:env) sigma (t:Evd.econstr) let set_print_constr f = term_printer := f module EvMap = Evar.Map @@ -164,10 +159,10 @@ let protect f x = try f x with e -> str "EXCEPTION: " ++ str (Printexc.to_string e) -let print_kconstr a = - protect (fun c -> print_constr c) a +let print_kconstr env sigma a = + protect (fun c -> print_constr_env env sigma c) a -let pr_meta_map evd = +let pr_meta_map env sigma = let open Evd in let print_constr = print_kconstr in let pr_name = function @@ -177,25 +172,25 @@ let pr_meta_map evd = | (mv,Cltyp (na,b)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ - print_constr b.rebus ++ fnl ()) + print_constr env sigma b.rebus ++ fnl ()) | (mv,Clval(na,(b,s),t)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ - print_constr b.rebus ++ - str " : " ++ print_constr t.rebus ++ + print_constr env sigma b.rebus ++ + str " : " ++ print_constr env sigma t.rebus ++ spc () ++ pr_instance_status s ++ fnl ()) in - prlist pr_meta_binding (meta_list evd) + prlist pr_meta_binding (meta_list sigma) -let pr_decl (decl,ok) = +let pr_decl env sigma (decl,ok) = let open NamedDecl in let print_constr = print_kconstr in match decl with | LocalAssum (id,_) -> if ok then Id.print id else (str "{" ++ Id.print id ++ str "}") | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ Id.print id ++ str ":=" ++ - print_constr c ++ str (if ok then ")" else "}") + print_constr env sigma c ++ str (if ok then ")" else "}") -let pr_evar_source = function +let pr_evar_source env sigma = function | Evar_kinds.NamedHole id -> Id.print id | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" @@ -208,11 +203,11 @@ let pr_evar_source = function let print_constr = print_kconstr in let id = Option.get ido in str "parameter " ++ Id.print id ++ spc () ++ str "of" ++ - spc () ++ print_constr (EConstr.of_constr @@ printable_constr_of_global c) + spc () ++ print_constr env sigma (EConstr.of_constr @@ printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> let print_constr = print_kconstr in - pr_nth n ++ str " argument of type " ++ print_constr (EConstr.mkInd ind) + pr_nth n ++ str " argument of type " ++ print_constr env sigma (EConstr.mkInd ind) | Evar_kinds.GoalEvar -> str "goal evar" | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause" | Evar_kinds.MatchingVar _ -> str "matching variable" @@ -224,7 +219,7 @@ let pr_evar_source = function | Some Evar_kinds.Domain -> str "domain of " | Some Evar_kinds.Codomain -> str "codomain of ") ++ Evar.print evk -let pr_evar_info evi = +let pr_evar_info env sigma evi = let open Evd in let print_constr = print_kconstr in let phyps = @@ -233,23 +228,23 @@ let pr_evar_info evi = | None -> List.map (fun c -> (c, true)) (evar_context evi) | Some filter -> List.combine (evar_context evi) filter in - prlist_with_sep spc pr_decl (List.rev decls) + prlist_with_sep spc (pr_decl env sigma) (List.rev decls) with Invalid_argument _ -> str "Ill-formed filtered context" in - let pty = print_constr evi.evar_concl in + let pty = print_constr env sigma evi.evar_concl in let pb = match evi.evar_body with | Evar_empty -> mt () - | Evar_defined c -> spc() ++ str"=> " ++ print_constr c + | Evar_defined c -> spc() ++ str"=> " ++ print_constr env sigma c in let candidates = match evi.evar_body, evi.evar_candidates with | Evar_empty, Some l -> spc () ++ str "{" ++ - prlist_with_sep (fun () -> str "|") print_constr l ++ str "}" + prlist_with_sep (fun () -> str "|") (print_constr env sigma) l ++ str "}" | _ -> mt () in - let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in + let src = str "(" ++ pr_evar_source env sigma (snd evi.evar_source) ++ str ")" in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++ candidates ++ spc() ++ src) @@ -304,8 +299,8 @@ let has_no_evar sigma = try let () = Evd.fold (fun _ _ () -> raise Exit) sigma () in true with Exit -> false -let pr_evd_level evd = UState.pr_uctx_level (Evd.evar_universe_context evd) -let reference_of_level evd l = UState.qualid_of_level (Evd.evar_universe_context evd) l +let pr_evd_level sigma = UState.pr_uctx_level (Evd.evar_universe_context sigma) +let reference_of_level sigma l = UState.qualid_of_level (Evd.evar_universe_context sigma) l let pr_evar_universe_context ctx = let open UState in @@ -321,12 +316,12 @@ let pr_evar_universe_context ctx = str "WEAK CONSTRAINTS:"++brk(0,1)++ h 0 (UState.pr_weak prl ctx) ++ fnl ()) -let print_env_short env = +let print_env_short env sigma = let print_constr = print_kconstr in let pr_rel_decl = function | RelDecl.LocalAssum (n,_) -> Name.print n | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n ++ str " := " - ++ print_constr (EConstr.of_constr b) ++ str ")" + ++ print_constr env sigma (EConstr.of_constr b) ++ str ")" in let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in let nc = List.rev (named_context env) in @@ -346,7 +341,7 @@ let pr_evar_constraints sigma pbs = naming/renaming. *) Namegen.make_all_name_different env sigma in - print_env_short env ++ spc () ++ str "|-" ++ spc () ++ + print_env_short env sigma ++ spc () ++ str "|-" ++ spc () ++ protect (print_constr_env env sigma) t1 ++ spc () ++ str (match pbty with | Reduction.CONV -> "==" @@ -355,7 +350,7 @@ let pr_evar_constraints sigma pbs = in prlist_with_sep fnl pr_evconstr pbs -let pr_evar_map_gen with_univs pr_evars sigma = +let pr_evar_map_gen with_univs pr_evars env sigma = let uvs = Evd.evar_universe_context sigma in let (_, conv_pbs) = Evd.extract_all_conv_pbs sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma ++ fnl () @@ -371,18 +366,24 @@ let pr_evar_map_gen with_univs pr_evars sigma = else str "TYPECLASSES:" ++ brk (0, 1) ++ prlist_with_sep spc Evar.print (Evar.Set.elements evars) ++ fnl () + and obligations = + let evars = Evd.get_obligation_evars sigma in + if Evar.Set.is_empty evars then mt () + else + str "OBLIGATIONS:" ++ brk (0, 1) ++ + prlist_with_sep spc Evar.print (Evar.Set.elements evars) ++ fnl () and metas = if List.is_empty (Evd.meta_list sigma) then mt () else - str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma + str "METAS:" ++ brk (0, 1) ++ pr_meta_map env sigma in - evs ++ svs ++ cstrs ++ typeclasses ++ metas + evs ++ svs ++ cstrs ++ typeclasses ++ obligations ++ metas -let pr_evar_list sigma l = +let pr_evar_list env sigma l = let open Evd in let pr (ev, evi) = h 0 (Evar.print ev ++ - str "==" ++ pr_evar_info evi ++ + str "==" ++ pr_evar_info env sigma evi ++ (if evi.evar_body == Evar_empty then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) @@ -405,18 +406,18 @@ let to_list d = Evd.fold fold_undef d (); !l -let pr_evar_by_depth depth sigma = match depth with +let pr_evar_by_depth depth env sigma = match depth with | None -> (* Print all evars *) - str"EVARS:" ++ brk(0,1) ++ pr_evar_list sigma (to_list sigma) ++ fnl() + str"EVARS:" ++ brk(0,1) ++ pr_evar_list env sigma (to_list sigma) ++ fnl() | Some n -> (* Print closure of undefined evars *) str"UNDEFINED EVARS:"++ (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++ brk(0,1)++ - pr_evar_list sigma (evar_dependency_closure n sigma) ++ fnl() + pr_evar_list env sigma (evar_dependency_closure n sigma) ++ fnl() -let pr_evar_by_filter filter sigma = +let pr_evar_by_filter filter env sigma = let open Evd in let elts = Evd.fold (fun evk evi accu -> (evk, evi) :: accu) sigma [] in let elts = List.rev elts in @@ -431,49 +432,49 @@ let pr_evar_by_filter filter sigma = let prdef = if List.is_empty defined then mt () else str "DEFINED EVARS:" ++ brk (0, 1) ++ - pr_evar_list sigma defined + pr_evar_list env sigma defined in let prundef = if List.is_empty undefined then mt () else str "UNDEFINED EVARS:" ++ brk (0, 1) ++ - pr_evar_list sigma undefined + pr_evar_list env sigma undefined in prdef ++ prundef -let pr_evar_map ?(with_univs=true) depth sigma = - pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth sigma) sigma +let pr_evar_map ?(with_univs=true) depth env sigma = + pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth env sigma) env sigma -let pr_evar_map_filter ?(with_univs=true) filter sigma = - pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter sigma) sigma +let pr_evar_map_filter ?(with_univs=true) filter env sigma = + pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter env sigma) env sigma let pr_metaset metas = str "[" ++ pr_sequence pr_meta (Evd.Metaset.elements metas) ++ str "]" let pr_var_decl env decl = let open NamedDecl in - let evd = Evd.from_env env in + let sigma = Evd.from_env env in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let c = EConstr.of_constr c in - let pb = print_constr_env env evd c in + let pb = print_constr_env env sigma c in (str" := " ++ pb ++ cut () ) in - let pt = print_constr_env env evd (EConstr.of_constr (get_type decl)) in + let pt = print_constr_env env sigma (EConstr.of_constr (get_type decl)) in let ptyp = (str" : " ++ pt) in (Id.print (get_id decl) ++ hov 0 (pbody ++ ptyp)) let pr_rel_decl env decl = let open RelDecl in - let evd = Evd.from_env env in + let sigma = Evd.from_env env in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let c = EConstr.of_constr c in - let pb = print_constr_env env evd c in + let pb = print_constr_env env sigma c in (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = print_constr_env env evd (EConstr.of_constr (get_type decl)) in + let ptyp = print_constr_env env sigma (EConstr.of_constr (get_type decl)) in match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (Id.print id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -1178,7 +1179,7 @@ let isGlobalRef sigma c = | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false -let is_template_polymorphic env sigma f = +let is_template_polymorphic_ind env sigma f = match EConstr.kind sigma f with | Ind (ind, u) -> if not (EConstr.EInstance.is_empty u) then false diff --git a/engine/termops.mli b/engine/termops.mli index f7b9469ae8..07c9541f25 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -282,7 +282,7 @@ val is_global : Evd.evar_map -> GlobRef.t -> constr -> bool val isGlobalRef : Evd.evar_map -> constr -> bool -val is_template_polymorphic : env -> Evd.evar_map -> constr -> bool +val is_template_polymorphic_ind : env -> Evd.evar_map -> constr -> bool val is_Prop : Evd.evar_map -> constr -> bool val is_Set : Evd.evar_map -> constr -> bool @@ -304,11 +304,11 @@ val pr_existential_key : evar_map -> Evar.t -> Pp.t val pr_evar_suggested_name : Evar.t -> evar_map -> Id.t -val pr_evar_info : evar_info -> Pp.t +val pr_evar_info : env -> evar_map -> evar_info -> Pp.t val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.t -val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.t +val pr_evar_map : ?with_univs:bool -> int option -> env -> evar_map -> Pp.t val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) -> - evar_map -> Pp.t + env -> evar_map -> Pp.t val pr_metaset : Metaset.t -> Pp.t val pr_evar_universe_context : UState.t -> Pp.t val pr_evd_level : evar_map -> Univ.Level.t -> Pp.t diff --git a/ide/coqide_QUARTZ.ml.in b/ide/coqide_QUARTZ.ml.in new file mode 100644 index 0000000000..a08bac5772 --- /dev/null +++ b/ide/coqide_QUARTZ.ml.in @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let osx = GosxApplication.osxapplication () + +let () = + let _ = osx#connect#ns_application_open_file + ~callback:(fun x -> Coqide.do_load x; true) + in + let _ = osx#connect#ns_application_block_termination + ~callback:Coqide.forbid_quit + in + let _ = osx#connect#ns_application_will_terminate + ~callback:Coqide.close_and_quit + in () + +let init () = + let () = GtkosxApplication.Application.set_menu_bar osx#as_osxapplication + (GtkMenu.MenuShell.cast + (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) + in + let () = GtkosxApplication.Application.insert_app_menu_item + osx#as_osxapplication + (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 + in + let () = GtkosxApplication.Application.set_help_menu osx#as_osxapplication + (Some (GtkMenu.MenuItem.cast + (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) + in + osx#ready () diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in new file mode 100644 index 0000000000..8c4649fc39 --- /dev/null +++ b/ide/coqide_WIN32.ml.in @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* On win32, we add the directory of coqide to the PATH at launch-time + (this used to be done in a .bat script). *) + +let set_win32_path () = + Unix.putenv "PATH" + (Filename.dirname Sys.executable_name ^ ";" ^ + (try Sys.getenv "PATH" with _ -> "")) + +(* On win32, since coqide is now console-free, we re-route stdout/stderr + to avoid Sys_error if someone writes to them. We write to a pipe which + is never read (by default) or to a temp log file (when in debug mode). +*) + +let reroute_stdout_stderr () = + (* We anticipate a bit the argument parsing and look for -debug *) + let debug = List.mem "-debug" (Array.to_list Sys.argv) in + Minilib.debug := debug; + let out_descr = + if debug then + let (name,chan) = Filename.open_temp_file "coqide_" ".log" in + Coqide.logfile := Some name; + Unix.descr_of_out_channel chan + else + snd (Unix.pipe ()) + in + Unix.set_close_on_exec out_descr; + Unix.dup2 out_descr Unix.stdout; + Unix.dup2 out_descr Unix.stderr + +(* We also provide specific kill and interrupt functions. *) + +external win32_kill : int -> unit = "win32_kill" +external win32_interrupt : int -> unit = "win32_interrupt" +let () = + Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; + set_win32_path (); + Coq.interrupter := win32_interrupt; + reroute_stdout_stderr () + +let init () = () diff --git a/ide/coqide_X11.ml.in b/ide/coqide_X11.ml.in new file mode 100644 index 0000000000..6a5784eac3 --- /dev/null +++ b/ide/coqide_X11.ml.in @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let init () = () diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml index 3a92e1bc91..91e8be875a 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml @@ -49,88 +49,6 @@ let catch_gtk_messages () = let () = catch_gtk_messages () - - -(** System-dependent settings *) - -let os_specific_init () = () - -(** Win32 *) - -IFDEF WIN32 THEN - -(* On win32, we add the directory of coqide to the PATH at launch-time - (this used to be done in a .bat script). *) - -let set_win32_path () = - Unix.putenv "PATH" - (Filename.dirname Sys.executable_name ^ ";" ^ - (try Sys.getenv "PATH" with _ -> "")) - -(* On win32, since coqide is now console-free, we re-route stdout/stderr - to avoid Sys_error if someone writes to them. We write to a pipe which - is never read (by default) or to a temp log file (when in debug mode). -*) - -let reroute_stdout_stderr () = - (* We anticipate a bit the argument parsing and look for -debug *) - let debug = List.mem "-debug" (Array.to_list Sys.argv) in - Minilib.debug := debug; - let out_descr = - if debug then - let (name,chan) = Filename.open_temp_file "coqide_" ".log" in - Coqide.logfile := Some name; - Unix.descr_of_out_channel chan - else - snd (Unix.pipe ()) - in - Unix.set_close_on_exec out_descr; - Unix.dup2 out_descr Unix.stdout; - Unix.dup2 out_descr Unix.stderr - -(* We also provide specific kill and interrupt functions. *) - -external win32_kill : int -> unit = "win32_kill" -external win32_interrupt : int -> unit = "win32_interrupt" -let () = - Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; - set_win32_path (); - Coq.interrupter := win32_interrupt; - reroute_stdout_stderr () -END - -(** MacOSX *) - -IFDEF QUARTZ THEN -let osx = GosxApplication.osxapplication () - -let () = - let _ = osx#connect#ns_application_open_file - ~callback:(fun x -> Coqide.do_load x; true) - in - let _ = osx#connect#ns_application_block_termination - ~callback:Coqide.forbid_quit - in - let _ = osx#connect#ns_application_will_terminate - ~callback:Coqide.close_and_quit - in () - -let os_specific_init () = - let () = GtkosxApplication.Application.set_menu_bar osx#as_osxapplication - (GtkMenu.MenuShell.cast - (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) - in - let () = GtkosxApplication.Application.insert_app_menu_item - osx#as_osxapplication - (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 - in - let () = GtkosxApplication.Application.set_help_menu osx#as_osxapplication - (Some (GtkMenu.MenuItem.cast - (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) - in - osx#ready () -END - let load_prefs () = try Preferences.load_pref () with e -> Ideutils.flash_info @@ -145,7 +63,7 @@ let () = Coq.check_connection args; Coqide.sup_args := args; Coqide.main files; - os_specific_init (); + Coqide_os_specific.init (); try GMain.main (); failwith "Gtk loop ended" diff --git a/ide/coqide_os_specific.mli b/ide/coqide_os_specific.mli new file mode 100644 index 0000000000..ebd09099f0 --- /dev/null +++ b/ide/coqide_os_specific.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val init : unit -> unit @@ -33,9 +33,9 @@ (libraries coqide-server.protocol coqide-server.core lablgtk2.sourceview2)) (rule - (targets coqide_main.ml) - (deps (:ml4-file coqide_main.ml4)) - (action (run coqmlp5 -loc loc -impl %{ml4-file} -o %{targets}))) + (targets coqide_os_specific.ml) + (deps (:in-file coqide_X11.ml.in)) ; TODO support others + (action (run cp %{in-file} %{targets}))) (executable (name coqide_main) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 601099c6ff..838ef40545 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -480,6 +480,9 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) (make_pat_notation ?loc ntn (l,ll) l2') key) end | SynDefRule kn -> + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> let qid = Nametab.shortest_qualid_of_syndef ?loc vars kn in let l1 = List.rev_map (fun (c,(subentry,(scopt,scl))) -> @@ -493,7 +496,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) |None -> raise No_match in assert (List.is_empty substlist); - mkPat ?loc qid (List.rev_append l1 l2') + insert_pat_coercion ?loc coercion (mkPat ?loc qid (List.rev_append l1 l2')) and extern_notation_pattern allscopes vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> @@ -1131,12 +1134,15 @@ and extern_notation (custom,scopes as allscopes) vars t = function binderlists in insert_coercion coercion (insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key)) | SynDefRule kn -> + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c, None) terms in let a = CRef (Nametab.shortest_qualid_of_syndef ?loc vars kn,None) in - CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l) in + insert_coercion coercion (CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l)) in if List.is_empty args then e else let args = fill_arg_scopes args argsscopes allscopes in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c03a5fee90..02db8f6aab 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -737,7 +737,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in try let gc = intern nenv c in - Id.Map.add id (gc, Some c) map + Id.Map.add id (gc, None) map with Nametab.GlobalizationError _ -> map in let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = @@ -2051,15 +2051,22 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (ltacvars, ntnvars) = lvar in (* Preventively declare notation variables in ltac as non-bindings *) Id.Map.iter (fun x (used_as_binder,_,_) -> used_as_binder := false) ntnvars; - let ntnvars = Id.Map.domain ntnvars in let extra = ltacvars.ltac_extra in + (* We inform ltac that the interning vars and the notation vars are bound *) + (* but we could instead rely on the "intern_sign" *) let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in - let lvars = Id.Set.union lvars ntnvars in + let lvars = Id.Set.union lvars (Id.Map.domain ntnvars) in let ltacvars = Id.Set.union lvars env.ids in + (* Propagating enough information for mutual interning with tac-in-term *) + let intern_sign = { + Genintern.intern_ids = env.ids; + Genintern.notation_variable_status = ntnvars + } in let ist = { Genintern.genv = globalenv; ltacvars; extra; + intern_sign; } in let (_, glb) = Genintern.generic_intern ist gen in Some glb @@ -2344,16 +2351,23 @@ let intern_constr_pattern env sigma ?(as_type=false) ?(ltacvars=empty_ltac_sign) ~pattern_mode:true ~ltacvars env sigma c in pattern_of_glob_constr c +let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) + { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = + let tmp_scope = scope_of_type_kind sigma kind in + let impls = empty_internalization_env in + internalize env {ids; unb = false; tmp_scope; scopes = []; impls} + pattern_mode (ltacvars, vl) c + let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = + let ids = extract_ids env in (* [vl] is intended to remember the scope of the free variables of [a] *) let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in - let c = internalize (Global.env()) {ids = extract_ids env; unb = false; - tmp_scope = None; scopes = []; impls = impls} + let c = internalize env {ids; unb = false; tmp_scope = None; scopes = []; impls} false (empty_ltac_sign, vl) a in + (* Splits variables into those that are binding, bound, or both *) (* Translate and check that [c] has all its free variables bound in [vars] *) let a, reversible = notation_constr_of_glob_constr nenv c in - (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in let unused = match reversible with NonInjective ids -> ids | _ -> [] in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index dd0944cc48..147a903fe2 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -185,6 +185,13 @@ val interp_notation_constr : env -> ?impls:internalization_env -> notation_interp_env -> constr_expr -> (bool * subscopes) Id.Map.t * notation_constr * reversibility_status +(** Idem but to glob_constr (weaker check of binders) *) + +val intern_core : typing_constraint -> + env -> evar_map -> ?pattern_mode:bool -> ?ltacvars:ltac_sign -> + Genintern.intern_variable_status -> constr_expr -> + glob_constr + (** Globalization options *) val parsing_explicit : bool ref diff --git a/interp/declare.mli b/interp/declare.mli index 02e73cd66c..468e056909 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Libnames open Constr open Entries open Decl_kinds @@ -29,7 +28,7 @@ type section_variable_entry = type variable_declaration = DirPath.t * section_variable_entry * logical_kind -val declare_variable : variable -> variable_declaration -> object_name +val declare_variable : variable -> variable_declaration -> Libobject.object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) @@ -69,7 +68,7 @@ val set_declare_scheme : (** [declare_mind me] declares a block of inductive types with their constructors in the current section; it returns the path of the whole block and a boolean indicating if it is a primitive record. *) -val declare_mind : mutual_inductive_entry -> object_name * bool +val declare_mind : mutual_inductive_entry -> Libobject.object_name * bool (** Declaration messages *) diff --git a/interp/genintern.ml b/interp/genintern.ml index d9a0db040a..1b736b7977 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -14,16 +14,31 @@ open Genarg module Store = Store.Make () +type intern_variable_status = { + intern_ids : Id.Set.t; + notation_variable_status : + (bool ref * Notation_term.subscopes option ref * + Notation_term.notation_var_internalization_type) + Id.Map.t +} + type glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Store.t; + intern_sign : intern_variable_status; +} + +let empty_intern_sign = { + intern_ids = Id.Set.empty; + notation_variable_status = Id.Map.empty; } let empty_glob_sign env = { ltacvars = Id.Set.empty; genv = env; extra = Store.empty; + intern_sign = empty_intern_sign; } (** In globalize tactics, we need to keep the initial [constr_expr] to recompute diff --git a/interp/genintern.mli b/interp/genintern.mli index f4f064bcac..4100f39029 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -14,10 +14,19 @@ open Genarg module Store : Store.S +type intern_variable_status = { + intern_ids : Id.Set.t; + notation_variable_status : + (bool ref * Notation_term.subscopes option ref * + Notation_term.notation_var_internalization_type) + Id.Map.t +} + type glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Store.t; + intern_sign : intern_variable_status; } val empty_glob_sign : Environ.env -> glob_sign diff --git a/interp/interp.mllib b/interp/interp.mllib index 3668455aeb..aa20bda705 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -3,8 +3,8 @@ Genredexpr Redops Tactypes Stdarg -Genintern Notation_term +Genintern Notation_ops Notation Syntax_def diff --git a/interp/modintern.ml b/interp/modintern.ml index c27cc9cc07..51e27299e3 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -61,13 +61,52 @@ let lookup_module_or_modtype kind qid = let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) -let transl_with_decl env = function +let lookup_polymorphism env base kind fqid = + let m = match kind with + | Module -> (Environ.lookup_module base env).mod_type + | ModType -> (Environ.lookup_modtype base env).mod_type + | ModAny -> assert false + in + let rec defunctor = function + | NoFunctor m -> m + | MoreFunctor (_,_,m) -> defunctor m + in + let rec aux m fqid = + let open Names in + match fqid with + | [] -> assert false + | [id] -> + let test (lab,obj) = + match Id.equal (Label.to_id lab) id, obj with + | false, _ | _, (SFBmodule _ | SFBmodtype _) -> None + | true, SFBmind mind -> Some (Declareops.inductive_is_polymorphic mind) + | true, SFBconst const -> Some (Declareops.constant_is_polymorphic const) + in + (try CList.find_map test m with Not_found -> false (* error later *)) + | id::rem -> + let next = function + | MoreFunctor _ -> false (* error later *) + | NoFunctor body -> aux body rem + in + let test (lab,obj) = + match Id.equal (Label.to_id lab) id, obj with + | false, _ | _, (SFBconst _ | SFBmind _) -> None + | true, SFBmodule body -> Some (next body.mod_type) + | true, SFBmodtype body -> (* XXX is this valid? If not error later *) + Some (next body.mod_type) + in + (try CList.find_map test m with Not_found -> false (* error later *)) + in + aux (defunctor m) fqid + +let transl_with_decl env base kind = function | CWith_Module ({CAst.v=fqid},qid) -> WithMod (fqid,lookup_module qid), Univ.ContextSet.empty | CWith_Definition ({CAst.v=fqid},udecl,c) -> let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in let c, ectx = interp_constr env sigma c in - begin match UState.check_univ_decl ~poly:(Flags.is_universe_polymorphism()) ectx udecl with + let poly = lookup_polymorphism env base kind fqid in + begin match UState.check_univ_decl ~poly ectx udecl with | Entries.Polymorphic_const_entry ctx -> let inst, ctx = Univ.abstract_universes ctx in let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in @@ -86,23 +125,24 @@ let loc_of_module l = l.CAst.loc let rec interp_module_ast env kind m cst = match m with | {CAst.loc;v=CMident qid} -> let (mp,kind) = lookup_module_or_modtype kind qid in - (MEident mp, kind, cst) + (MEident mp, mp, kind, cst) | {CAst.loc;v=CMapply (me1,me2)} -> - let me1',kind1, cst = interp_module_ast env kind me1 cst in - let me2',kind2, cst = interp_module_ast env ModAny me2 cst in + let me1', base, kind1, cst = interp_module_ast env kind me1 cst in + let me2', _, kind2, cst = interp_module_ast env ModAny me2 cst in let mp2 = match me2' with | MEident mp -> mp | _ -> error_application_to_not_path (loc_of_module me2) me2' in if kind2 == ModType then error_application_to_module_type (loc_of_module me2); - (MEapply (me1',mp2), kind1, cst) + (MEapply (me1',mp2), base, kind1, cst) | {CAst.loc;v=CMwith (me,decl)} -> - let me,kind,cst = interp_module_ast env kind me cst in + let me,base,kind,cst = interp_module_ast env kind me cst in if kind == Module then error_incorrect_with_in_module m.CAst.loc; - let decl, cst' = transl_with_decl env decl in + let decl, cst' = transl_with_decl env base kind decl in let cst = Univ.ContextSet.union cst cst' in - (MEwith(me,decl), kind, cst) + (MEwith(me,decl), base, kind, cst) let interp_module_ast env kind m = - interp_module_ast env kind m Univ.ContextSet.empty + let me, _, kind, cst = interp_module_ast env kind m Univ.ContextSet.empty in + me, kind, cst diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index c558689595..95546a83e1 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -21,6 +21,8 @@ (* This file implements a lazy reduction for the Calculus of Inductive Constructions *) +[@@@ocaml.warning "+4"] + open CErrors open Util open Pp @@ -255,7 +257,7 @@ open Context.Named.Declaration let assoc_defined id env = match Environ.lookup_named id env with | LocalDef (_, c, _) -> c -| _ -> raise Not_found +| LocalAssum _ -> raise Not_found (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) @@ -310,7 +312,7 @@ and fterm = let fterm_of v = v.term let set_norm v = v.norm <- Norm -let is_val v = match v.norm with Norm -> true | _ -> false +let is_val v = match v.norm with Norm -> true | Cstr | Whnf | Red -> false let mk_atom c = {norm=Norm;term=FAtom c} let mk_red f = {norm=Red;term=f} @@ -359,20 +361,21 @@ let append_stack v s = if Int.equal (Array.length v) 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s - | _ -> Zapp v :: s + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> + Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s - | _ -> Zshift(n)::s + | (_,(ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zupdate _) :: _) | _,[] -> Zshift(n)::s let rec stack_args_size = function | Zapp v :: s -> Array.length v + stack_args_size s | Zshift(_)::s -> stack_args_size s | Zupdate(_)::s -> stack_args_size s - | _ -> 0 + | (ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> 0 (* When used as an argument stack (only Zapp can appear) *) let rec decomp_stack = function @@ -382,12 +385,12 @@ let rec decomp_stack = function | 1 -> Some (v.(0), s) | _ -> Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) - | _ -> None + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> None let array_of_stack s = let rec stackrec = function | [] -> [] | Zapp args :: s -> args :: (stackrec s) - | _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ -> assert false in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> @@ -398,7 +401,7 @@ let rec stack_assign s p c = match s with (let nargs = Array.copy args in nargs.(p) <- c; Zapp nargs :: s) - | _ -> s + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> s let rec stack_tail p s = if Int.equal p 0 then s else match s with @@ -406,13 +409,13 @@ let rec stack_tail p s = let q = Array.length args in if p >= q then stack_tail (p-q) s else Zapp (Array.sub args p (q-p)) :: s - | _ -> failwith "stack_tail" + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> failwith "stack_tail" let rec stack_nth s p = match s with | Zapp args :: s -> let q = Array.length args in if p >= q then stack_nth s (p-q) else args.(p) - | _ -> raise Not_found + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> raise Not_found (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it @@ -426,7 +429,7 @@ let rec lft_fconstr n ft = | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false - | FFlex _ | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ + | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f @@ -451,13 +454,14 @@ let compact_stack head stk = (** The stack contains [Zupdate] marks only if in sharing mode *) let _ = update ~share:true m h'.norm h'.term in strip_rec depth s - | stk -> zshift depth stk in + | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _) :: _ | []) as stk -> zshift depth stk + in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match m.norm with Red -> true | _ -> false end + if share && begin match m.norm with Red -> true | Norm | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -469,12 +473,12 @@ let mk_lambda env t = FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = - match t.term with - FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) - | FLambda(n,(na,ty)::tys,b,e) -> - (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) - | _ -> assert false - (* t must be a FLambda and binding list cannot be empty *) + match [@ocaml.warning "-4"] t.term with + | FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) + | FLambda(n,(na,ty)::tys,b,e) -> + (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) + | _ -> assert false +(* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) @@ -602,7 +606,7 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) -and subst_constr subst c = match Constr.kind c with +and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> begin match expand_rel i subst with | Inl (k, lazy v) -> Vars.lift k v @@ -664,15 +668,17 @@ let strip_update_shift_app_red head stk = | Zupdate(m)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) strip_rec rstk (update ~share:true m h.norm h.term) depth s - | stk -> (depth,List.rev rstk, stk) in + | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as stk -> + (depth,List.rev rstk, stk) + in strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match head.norm with Red -> false | _ -> true); + assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match head.norm with Red -> false | _ -> true); + assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -690,14 +696,13 @@ let get_nth_arg head n stk = | Zupdate(m)::s -> (** The stack contains [Zupdate] mark only if in sharing mode *) strip_rec rstk (update ~share:true m h.norm h.term) n s - | s -> (None, List.rev rstk @ s) in + | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) -let rec get_args n tys f e stk = - match stk with - Zupdate r :: s -> +let rec get_args n tys f e = function + | Zupdate r :: s -> (** The stack contains [Zupdate] mark only if in sharing mode *) let _hd = update ~share:true r Cstr (FLambda(n,tys,f,e)) in get_args n tys f e s @@ -713,7 +718,8 @@ let rec get_args n tys f e stk = else (* more lambdas *) let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s - | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) + | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as stk -> + (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function @@ -725,19 +731,17 @@ let rec eta_expand_stack = function (* Iota reduction: extract the arguments to be passed to the Case branches *) -let rec reloc_rargs_rec depth stk = - match stk with - Zapp args :: s -> - Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s - | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s - | _ -> stk +let rec reloc_rargs_rec depth = function + | Zapp args :: s -> + Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s + | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s + | ((ZcaseT _ | Zproj _ | Zfix _ | Zupdate _) :: _ | []) as stk -> stk let reloc_rargs depth stk = if Int.equal depth 0 then stk else reloc_rargs_rec depth stk -let rec try_drop_parameters depth n argstk = - match argstk with - Zapp args::s -> +let rec try_drop_parameters depth n = function + | Zapp args::s -> let q = Array.length args in if n > q then try_drop_parameters depth (n-q) s else if Int.equal n q then reloc_rargs depth s @@ -748,7 +752,7 @@ let rec try_drop_parameters depth n argstk = | [] -> if Int.equal n 0 then [] else raise Not_found - | _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _) :: _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = @@ -788,13 +792,12 @@ let eta_expand_ind_stack env ind m s (f, s') = argss, [Zapp hstack] | None -> raise Not_found (* disallow eta-exp for non-primitive records *) -let rec project_nth_arg n argstk = - match argstk with +let rec project_nth_arg n = function | Zapp args :: s -> let q = Array.length args in if n >= q then project_nth_arg (n - q) s else (* n < q *) args.(n) - | _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) @@ -809,7 +812,7 @@ let rec project_nth_arg n argstk = (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = - match fix with + match [@ocaml.warning "-4"] fix with | FFix (((reci,i),(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), @@ -900,7 +903,7 @@ let rec knr info tab m stk = let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then - (match strip_update_shift_app m stk with + (match [@ocaml.warning "-4"] strip_update_shift_app m stk with | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in @@ -918,17 +921,17 @@ let rec knr info tab m stk = else (m,stk) | FCoFix _ when red_set info.i_flags fCOFIX -> (match strip_update_shift_app m stk with - (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> + | (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info tab fxe fxbd (args@stk') - | (_,args,s) -> (m,args@s)) + | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] as s)) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info tab (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk | None -> (m,stk)) - | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FApp _ | FProj _ + | FLOCKED | FRel _ | FAtom _ | FFlex (RelKey _ | ConstKey _ | VarKey _) | FInd _ | FApp _ | FProj _ | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ | FCLOS _ -> (m, stk) @@ -1057,4 +1060,4 @@ let unfold_reference info tab key = if red_set info.i_flags (fVAR i) then ref_value_cache info tab key else None - | _ -> ref_value_cache info tab key + | RelKey _ -> ref_value_cache info tab key diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 61fcb4832a..c1b38b4156 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -66,6 +66,8 @@ type typing_flags = { check_universes : bool; (** If [false] universe constraints are not checked *) conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *) share_reduction : bool; (** Use by-need reduction algorithm *) + enable_VM : bool; (** If [false], all VM conversions fall back to interpreted ones *) + enable_native_compiler : bool; (** If [false], all native conversions fall back to VM ones *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index d995786d97..3ed599c538 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -22,6 +22,8 @@ let safe_flags oracle = { check_universes = true; conv_oracle = oracle; share_reduction = true; + enable_VM = true; + enable_native_compiler = true; } (** {6 Arities } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 3b7e3ae544..f61dd0c101 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -350,9 +350,6 @@ let map_universes f env = { env with env_stratification = { s with env_universes = f s.env_universes } } -let set_universes env u = - { env with env_stratification = { env.env_stratification with env_universes = u } } - let add_constraints c env = if Univ.Constraint.is_empty c then env else map_universes (UGraph.merge_constraints c) env @@ -405,19 +402,12 @@ let add_constant_key kn cb linkinfo env = let add_constant kn cb env = add_constant_key kn cb no_link_info env -let constraints_of cb u = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Constraint.empty - | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx - (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in - match cb.const_universes with - | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty - | Polymorphic_const _ctx -> - let csts = constraints_of cb u in - (subst_instance_constr u cb.const_type, csts) + let uctx = Declareops.constant_polymorphic_context cb in + let csts = Univ.AUContext.instantiate u uctx in + (subst_instance_constr u cb.const_type, csts) type const_evaluation_result = NoBody | Opaque @@ -425,20 +415,24 @@ exception NotEvaluableConst of const_evaluation_result let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in - if Declareops.constant_is_polymorphic cb then - let cst = constraints_of cb u in - let b' = match cb.const_body with - | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) - | OpaqueDef _ -> None - | Undef _ -> None - in - b', subst_instance_constr u cb.const_type, cst - else - let b' = match cb.const_body with - | Def l_body -> Some (Mod_subst.force_constr l_body) - | OpaqueDef _ -> None - | Undef _ -> None - in b', cb.const_type, Univ.Constraint.empty + let uctx = Declareops.constant_polymorphic_context cb in + let cst = Univ.AUContext.instantiate u uctx in + let b' = match cb.const_body with + | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) + | OpaqueDef _ -> None + | Undef _ -> None + in + b', subst_instance_constr u cb.const_type, cst + +let body_of_constant_body env cb = + let otab = opaque_tables env in + match cb.const_body with + | Undef _ -> + None + | Def c -> + Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb) + | OpaqueDef o -> + Some (Opaqueproof.force_proof otab o, Declareops.constant_polymorphic_context cb) (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant @@ -447,9 +441,7 @@ let constant_value_and_type env (kn, u) = (* constant_type gives the type of a constant *) let constant_type_in env (kn,u) = let cb = lookup_constant kn env in - if Declareops.constant_is_polymorphic cb then - subst_instance_constr u cb.const_type - else cb.const_type + subst_instance_constr u cb.const_type let constant_value_in env (kn,u) = let cb = lookup_constant kn env in @@ -694,6 +686,22 @@ let is_polymorphic env r = | IndRef ind -> polymorphic_ind ind env | ConstructRef cstr -> polymorphic_ind (inductive_of_constructor cstr) env +let is_template_polymorphic env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef _c -> false + | IndRef ind -> template_polymorphic_ind ind env + | ConstructRef cstr -> template_polymorphic_ind (inductive_of_constructor cstr) env + +let is_type_in_type env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef c -> type_in_type_constant c env + | IndRef ind -> type_in_type_ind ind env + | ConstructRef cstr -> type_in_type_ind (inductive_of_constructor cstr) env + (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module Safetyping, Environ only synchronizes the proactive and the reactive parts*) diff --git a/kernel/environ.mli b/kernel/environ.mli index 43bfe7c2fb..c285f907fc 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -155,11 +155,6 @@ val named_body : variable -> env -> constr option val fold_named_context : (env -> Constr.named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a -val set_universes : env -> UGraph.t -> env -(** This is used to update universes during a proof for the sake of - evar map-unaware functions, eg [Typing] calling - [Typeops.check_hyps_inclusion]. *) - (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> Constr.named_declaration -> 'a) -> init:'a -> env -> 'a @@ -211,6 +206,12 @@ val constant_value_and_type : env -> Constant.t puniverses -> polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t +(** Returns the body of the constant if it has any, and the polymorphic context + it lives in. For monomorphic constant, the latter is empty, and for + polymorphic constants, the term contains De Bruijn universe variables that + need to be instantiated. *) +val body_of_constant_body : env -> constant_body -> (Constr.constr * Univ.AUContext.t) option + (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) @@ -320,6 +321,8 @@ val apply_to_hyp : named_context_val -> variable -> val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val val is_polymorphic : env -> Names.GlobRef.t -> bool +val is_template_polymorphic : env -> GlobRef.t -> bool +val is_type_in_type : env -> GlobRef.t -> bool open Retroknowledge (** functions manipulating the retroknowledge diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 054b6a2d17..f5d7ab3c9d 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -14,7 +14,8 @@ open Nativelib open Reduction open Util open Nativevalues -open Nativecode +open Nativecode +open Environ (** This module implements the conversion test by compiling to OCaml code *) @@ -142,7 +143,7 @@ let warn_no_native_compiler = strbrk " falling back to VM conversion test.") let native_conv_gen pb sigma env univs t1 t2 = - if not Coq_config.native_compiler then begin + if not (typing_flags env).Declarations.enable_native_compiler then begin warn_no_native_compiler (); Vconv.vm_conv_gen pb env univs t1 t2 end diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index d294f2060e..833e4082f0 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -66,7 +66,6 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = - let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 18697d07e5..5515ff9767 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -68,7 +68,7 @@ type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack - | Zlcase of case_info * lift * fconstr * fconstr array + | Zlcase of case_info * lift * constr * constr array * fconstr subs and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function @@ -102,7 +102,7 @@ let pure_stack lfts stk = let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)) + (l,Zlcase(ci,l,p,br,e)::pstk)) in snd (pure_rec lfts stk) @@ -288,31 +288,13 @@ let conv_table_key infos k1 k2 cuniv = | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible -let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = - let rec cmp_rec pstk1 pstk2 cuniv = - match (pstk1,pstk2) with - | (z1::s1, z2::s2) -> - let cu1 = cmp_rec s1 s2 cuniv in - (match (z1,z2) with - | (Zlapp a1,Zlapp a2) -> - Array.fold_right2 f a1 a2 cu1 - | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> - if not (Projection.Repr.equal c1 c2) then - raise NotConvertible - else cu1 - | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> - let cu2 = f fx1 fx2 cu1 in - cmp_rec a1 a2 cu2 - | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> - if not (fmind ci1.ci_ind ci2.ci_ind) then - raise NotConvertible; - let cu2 = f (l1,p1) (l2,p2) cu1 in - Array.fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2 - | _ -> assert false) - | _ -> cuniv in - if compare_stack_shape stk1 stk2 then - cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv - else raise NotConvertible +exception IrregularPatternShape + +let rec skip_pattern n c = + if Int.equal n 0 then c + else match kind c with + | Lambda (_, _, c) -> skip_pattern (pred n) c + | _ -> raise IrregularPatternShape type conv_tab = { cnv_inf : clos_infos; @@ -611,10 +593,31 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | FProd _ | FEvar _), _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = - compare_stacks - (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) - (eq_ind) - lft1 stk1 lft2 stk2 cuniv + let f (l1, t1) (l2, t2) cuniv = ccnv CONV l2r infos l1 l2 t1 t2 cuniv in + let rec cmp_rec pstk1 pstk2 cuniv = + match (pstk1,pstk2) with + | (z1::s1, z2::s2) -> + let cu1 = cmp_rec s1 s2 cuniv in + (match (z1,z2) with + | (Zlapp a1,Zlapp a2) -> + Array.fold_right2 f a1 a2 cu1 + | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> + if not (Projection.Repr.equal c1 c2) then + raise NotConvertible + else cu1 + | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> + let cu2 = f fx1 fx2 cu1 in + cmp_rec a1 a2 cu2 + | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> + if not (eq_ind ci1.ci_ind ci2.ci_ind) then + raise NotConvertible; + let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in + convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 + | _ -> assert false) + | _ -> cuniv in + if compare_stack_shape stk1 stk2 then + cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv + else raise NotConvertible and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in @@ -629,6 +632,22 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible +and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = + (** Skip comparison of the pattern types. We know that the two terms are + living in a common type, thus this check is useless. *) + let fold n c1 c2 cuniv = match skip_pattern n c1, skip_pattern n c2 with + | (c1, c2) -> + let lft1 = el_liftn n lft1 in + let lft2 = el_liftn n lft2 in + let e1 = subs_liftn n e1 in + let e2 = subs_liftn n e2 in + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + | exception IrregularPatternShape -> + (** Might happen due to a shape invariant that is not enforced *) + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + in + Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv + let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 12f9592ab7..4b64cc6d11 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -194,6 +194,18 @@ let set_engagement c senv = let set_typing_flags c senv = { senv with env = Environ.set_typing_flags c senv.env } +let set_share_reduction b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with share_reduction = b } senv + +let set_VM b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with enable_VM = b } senv + +let set_native_compiler b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with enable_native_compiler = b } senv + (** Check that the engagement [c] expected by a library matches the current (initial) one *) let check_engagement env expected_impredicative_set = @@ -1190,7 +1202,7 @@ loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) -let set_strategy e k l = { e with env = +let set_strategy k l e = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 26fa91adbd..8fb33b04d4 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -137,6 +137,9 @@ val add_constraints : (** Setting the type theory flavor *) val set_engagement : Declarations.engagement -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 +val set_share_reduction : bool -> safe_transformer0 +val set_VM : bool -> safe_transformer0 +val set_native_compiler : bool -> safe_transformer0 (** {6 Interactive module functions } *) @@ -217,4 +220,4 @@ val register : val register_inline : Constant.t -> safe_transformer0 val set_strategy : - safe_environment -> Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_environment + Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_transformer0 diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 1bb2d3c79c..c8fd83c8a9 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -91,7 +91,8 @@ let type_of_variable env id = (* Checks if a context of variables can be instantiated by the variables of the current env. Order does not have to be checked assuming that all names are distinct *) -let check_hyps_inclusion env f c sign = +let check_hyps_inclusion env ?evars f c sign = + let conv env a b = conv env ?evars a b in Context.Named.fold_outside (fun d1 () -> let open Context.Named.Declaration in diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d24002065b..4193324136 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -116,4 +116,5 @@ val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t (** {6 Miscellaneous. } *) (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Constr.named_context -> unit +val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) -> + ('a -> constr) -> 'a -> Constr.named_context -> unit diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 5965853e1e..c1130e62c9 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -189,7 +189,7 @@ let warn_bytecode_compiler_failed = strbrk "falling back to standard conversion") let vm_conv_gen cv_pb env univs t1 t2 = - if not Coq_config.bytecode_compiler then + if not (typing_flags env).Declarations.enable_VM then Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) full_transparent_state env univs t1 t2 else diff --git a/lib/flags.ml b/lib/flags.ml index c8f19f2f11..582506f3a8 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -103,10 +103,6 @@ let auto_intros = ref true let make_auto_intros flag = auto_intros := flag let is_auto_intros () = !auto_intros -let universe_polymorphism = ref false -let make_universe_polymorphism b = universe_polymorphism := b -let is_universe_polymorphism () = !universe_polymorphism - let polymorphic_inductive_cumulativity = ref false let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity diff --git a/lib/flags.mli b/lib/flags.mli index 3d9eafde75..b667235678 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -84,10 +84,6 @@ val is_auto_intros : unit -> bool val program_mode : bool ref val is_program_mode : unit -> bool -(** Global universe polymorphism flag. *) -val make_universe_polymorphism : bool -> unit -val is_universe_polymorphism : unit -> bool - (** Global polymorphic inductive cumulativity flag. *) val make_polymorphic_inductive_cumulativity : bool -> unit val is_polymorphic_inductive_cumulativity : unit -> bool diff --git a/library/declaremods.ml b/library/declaremods.ml index e01a99f731..d20775a0d7 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -139,7 +139,7 @@ let expand_sobjs (_,aobjs) = expand_aobjs aobjs Module M:SIG. ... End M. have the keep list empty. *) -type module_objects = object_prefix * Lib.lib_objects * Lib.lib_objects +type module_objects = Nametab.object_prefix * Lib.lib_objects * Lib.lib_objects module ModObjs : sig @@ -185,7 +185,7 @@ let consistency_checks exists dir dirinfo = user_err ~hdr:"consistency_checks" (DirPath.print dir ++ str " should already exist!") in - assert (eq_global_dir_reference globref dirinfo) + assert (Nametab.GlobDirRef.equal globref dirinfo) else if Nametab.exists_dir dir then user_err ~hdr:"consistency_checks" @@ -197,8 +197,8 @@ let compute_visibility exists i = (** Iterate some function [iter_objects] on all components of a module *) let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = - let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in - let dirinfo = DirModule prefix in + let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks exists obj_dir dirinfo; Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; ModSubstObjs.set obj_mp sobjs; @@ -239,19 +239,19 @@ let cache_keep _ = anomaly (Pp.str "This module should not be cached!") let load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in let prefix',sobjs,kobjs0 = try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) in - assert (eq_op prefix' prefix); + assert Nametab.(eq_op prefix' prefix); assert (List.is_empty kobjs0); ModObjs.set obj_mp (prefix,sobjs,kobjs); Lib.load_objects i prefix kobjs let open_keep i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in Lib.open_objects i prefix kobjs let in_modkeep : Lib.lib_objects -> obj = @@ -302,7 +302,7 @@ let (in_modtype : substitutive_objects -> obj), let do_include do_load do_open i ((sp,kn),aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in let o = expand_aobjs aobjs in if do_load then Lib.load_objects i prefix o; if do_open then Lib.open_objects i prefix o @@ -605,7 +605,7 @@ let start_module interp_modast export id args res fs = let () = Global.push_context_set true cst in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in - Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModule prefix); + Nametab.(push_dir (Until 1) (prefix.obj_dir) (GlobDirRef.DirOpenModule prefix)); mp let end_module () = @@ -723,7 +723,7 @@ let start_modtype interp_modast id args mtys fs = let () = Global.push_context_set true cst in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in - Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModtype prefix); + Nametab.(push_dir (Until 1) (prefix.obj_dir) (GlobDirRef.DirOpenModtype prefix)); mp let end_modtype () = @@ -977,7 +977,7 @@ let iter_all_segments f = | "INCLUDE" -> let objs = expand_aobjs (out_include obj) in List.iter (apply_obj prefix) objs - | _ -> f (make_oname prefix id) obj + | _ -> f (Lib.make_oname prefix id) obj in let apply_mod_obj _ (prefix,substobjs,keepobjs) = List.iter (apply_obj prefix) substobjs; diff --git a/library/declaremods.mli b/library/declaremods.mli index b42a59bfbd..7aa4bc30ce 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -130,7 +130,7 @@ val declare_include : (together with their section path). *) val iter_all_segments : - (Libnames.object_name -> Libobject.obj -> unit) -> unit + (Libobject.object_name -> Libobject.obj -> unit) -> unit val debug_print_modtab : unit -> Pp.t diff --git a/library/global.ml b/library/global.ml index 3781ff3230..4ea5969a6f 100644 --- a/library/global.ml +++ b/library/global.ml @@ -128,19 +128,7 @@ let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ()) let opaque_tables () = Environ.opaque_tables (env ()) -let instantiate cb c = - let open Declarations in - match cb.const_universes with - | Monomorphic_const _ -> c, Univ.AUContext.empty - | Polymorphic_const ctx -> c, ctx - -let body_of_constant_body cb = - let open Declarations in - let otab = opaque_tables () in - match cb.const_body with - | Undef _ -> None - | Def c -> Some (instantiate cb (Mod_subst.force_constr c)) - | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) +let body_of_constant_body ce = body_of_constant_body (env ()) ce let body_of_constant cst = body_of_constant_body (lookup_constant cst) @@ -165,8 +153,6 @@ let import c u d = globalize (Safe_typing.import c u d) let env_of_context hyps = reset_with_named_context hyps (env()) -open Globnames - let constr_of_global_in_context = Typeops.constr_of_global_in_context let type_of_global_in_context = Typeops.type_of_global_in_context @@ -175,21 +161,9 @@ let universes_of_global gr = let is_polymorphic r = Environ.is_polymorphic (env()) r -let is_template_polymorphic r = - let env = env() in - match r with - | VarRef id -> false - | ConstRef c -> false - | IndRef ind -> Environ.template_polymorphic_ind ind env - | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env - -let is_type_in_type r = - let env = env() in - match r with - | VarRef id -> false - | ConstRef c -> Environ.type_in_type_constant c env - | IndRef ind -> Environ.type_in_type_ind ind env - | ConstructRef cstr -> Environ.type_in_type_ind (inductive_of_constructor cstr) env +let is_template_polymorphic r = is_template_polymorphic (env ()) r + +let is_type_in_type r = is_type_in_type (env ()) r let current_modpath () = Safe_typing.current_modpath (safe_env ()) @@ -208,11 +182,10 @@ let register field value = let register_inline c = globalize0 (Safe_typing.register_inline c) let set_strategy k l = - GlobalSafeEnv.set_safe_env (Safe_typing.set_strategy (safe_env ()) k l) - -let set_reduction_sharing b = - let env = safe_env () in - let flags = Environ.typing_flags (Safe_typing.env_of_safe_env env) in - let flags = { flags with Declarations.share_reduction = b } in - let env = Safe_typing.set_typing_flags flags env in - GlobalSafeEnv.set_safe_env env + globalize0 (Safe_typing.set_strategy k l) + +let set_share_reduction b = + globalize0 (Safe_typing.set_share_reduction b) + +let set_VM b = globalize0 (Safe_typing.set_VM b) +let set_native_compiler b = globalize0 (Safe_typing.set_native_compiler b) diff --git a/library/global.mli b/library/global.mli index 42a8005a4f..01ee695c49 100644 --- a/library/global.mli +++ b/library/global.mli @@ -150,7 +150,12 @@ val register_inline : Constant.t -> unit val set_strategy : Constant.t Names.tableKey -> Conv_oracle.level -> unit -val set_reduction_sharing : bool -> unit +(** {6 Conversion settings } *) + +val set_share_reduction : bool -> unit + +val set_VM : bool -> unit +val set_native_compiler : bool -> unit (* Modifies the global state, registering new universes *) diff --git a/library/lib.ml b/library/lib.ml index 27c5056a7f..690a4fd53d 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -22,11 +22,16 @@ module NamedDecl = Context.Named.Declaration type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) +(* let make_oname (dirpath,(mp,dir)) id = *) +let make_oname Nametab.{ obj_dir; obj_mp } id = + Names.(make_path obj_dir id, KerName.make obj_mp (Label.of_id id)) + +(* let make_oname (dirpath,(mp,dir)) id = *) type node = | Leaf of obj - | CompilingLibrary of object_prefix - | OpenedModule of is_type * export * object_prefix * Summary.frozen - | OpenedSection of object_prefix * Summary.frozen + | CompilingLibrary of Nametab.object_prefix + | OpenedModule of is_type * export * Nametab.object_prefix * Summary.frozen + | OpenedSection of Nametab.object_prefix * Summary.frozen type library_entry = object_name * node @@ -89,7 +94,7 @@ let segment_of_objects prefix = sections, but on the contrary there are many constructions of section paths based on the library path. *) -let initial_prefix = { +let initial_prefix = Nametab.{ obj_dir = default_library; obj_mp = ModPath.initial; obj_sec = DirPath.empty; @@ -98,7 +103,7 @@ let initial_prefix = { type lib_state = { comp_name : DirPath.t option; lib_stk : library_segment; - path_prefix : object_prefix; + path_prefix : Nametab.object_prefix; } let initial_lib_state = { @@ -115,9 +120,9 @@ let library_dp () = (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let cwd () = !lib_state.path_prefix.obj_dir -let current_mp () = !lib_state.path_prefix.obj_mp -let current_sections () = !lib_state.path_prefix.obj_sec +let cwd () = !lib_state.path_prefix.Nametab.obj_dir +let current_mp () = !lib_state.path_prefix.Nametab.obj_mp +let current_sections () = !lib_state.path_prefix.Nametab.obj_sec let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -138,7 +143,7 @@ let make_kn id = let mp = current_mp () in Names.KerName.make mp (Names.Label.of_id id) -let make_oname id = Libnames.make_oname !lib_state.path_prefix id +let make_foname id = make_oname !lib_state.path_prefix id let recalc_path_prefix () = let rec recalc = function @@ -153,9 +158,9 @@ let recalc_path_prefix () = let pop_path_prefix () = let op = !lib_state.path_prefix in lib_state := { !lib_state - with path_prefix = { op with obj_dir = pop_dirpath op.obj_dir; - obj_sec = pop_dirpath op.obj_sec; - } } + with path_prefix = Nametab.{ op with obj_dir = pop_dirpath op.obj_dir; + obj_sec = pop_dirpath op.obj_sec; + } } let find_entry_p p = let rec find = function @@ -214,24 +219,24 @@ let anonymous_id = fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = - add_entry (make_oname (anonymous_id ())) node + add_entry (make_foname (anonymous_id ())) node let add_leaf id obj = if ModPath.equal (current_mp ()) ModPath.initial then user_err Pp.(str "No session module started (use -top dir)"); - let oname = make_oname id in + let oname = make_foname id in cache_object (oname,obj); add_entry oname (Leaf obj); oname let add_discharged_leaf id obj = - let oname = make_oname id in + let oname = make_foname id in let newobj = rebuild_object obj in cache_object (oname,newobj); add_entry oname (Leaf newobj) let add_leaves id objs = - let oname = make_oname id in + let oname = make_foname id in let add_obj obj = add_entry oname (Leaf obj); load_object 1 (oname,obj) @@ -241,7 +246,7 @@ let add_leaves id objs = let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in - let oname = make_oname id in + let oname = make_foname id in if cache_first then begin cache_object (oname,obj); add_entry oname (Leaf obj) @@ -269,15 +274,15 @@ let current_mod_id () = let start_mod is_type export id mp fs = - let dir = add_dirpath_suffix (!lib_state.path_prefix.obj_dir) id in - let prefix = { obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in + let dir = add_dirpath_suffix (!lib_state.path_prefix.Nametab.obj_dir) id in + let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_module dir in if exists then user_err ~hdr:"open_module" (Id.print id ++ str " already exists"); - add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); + add_entry (make_foname id) (OpenedModule (is_type,export,prefix,fs)); lib_state := { !lib_state with path_prefix = prefix} ; prefix @@ -318,9 +323,9 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (!lib_state.path_prefix.obj_sec)) then + if not (Names.DirPath.is_empty (!lib_state.path_prefix.Nametab.obj_sec)) then user_err Pp.(str "some sections are already opened"); - let prefix = Libnames.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -544,14 +549,14 @@ let is_in_section ref = (* Sections. *) let open_section id = let opp = !lib_state.path_prefix in - let obj_dir = add_dirpath_suffix opp.obj_dir id in - let prefix = { obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in + let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in + let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in - add_entry (make_oname id) (OpenedSection (prefix, fs)); + add_entry (make_foname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) - Nametab.push_dir (Nametab.Until 1) obj_dir (DirOpenSection prefix); + Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirOpenSection prefix)); lib_state := { !lib_state with path_prefix = prefix }; add_section () @@ -611,7 +616,7 @@ let init () = (* Misc *) let mp_of_global = function - | VarRef id -> !lib_state.path_prefix.obj_mp + | VarRef id -> !lib_state.path_prefix.Nametab.obj_mp | ConstRef cst -> Names.Constant.modpath cst | IndRef ind -> Names.ind_modpath ind | ConstructRef constr -> Names.constr_modpath constr diff --git a/library/lib.mli b/library/lib.mli index 686e6a0e2d..d1b4977dd5 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -19,22 +19,24 @@ open Names type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) +val make_oname : Nametab.object_prefix -> Names.Id.t -> Libobject.object_name + type node = | Leaf of Libobject.obj - | CompilingLibrary of Libnames.object_prefix - | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | OpenedSection of Libnames.object_prefix * Summary.frozen + | CompilingLibrary of Nametab.object_prefix + | OpenedModule of is_type * export * Nametab.object_prefix * Summary.frozen + | OpenedSection of Nametab.object_prefix * Summary.frozen -type library_segment = (Libnames.object_name * node) list +type library_segment = (Libobject.object_name * node) list type lib_objects = (Id.t * Libobject.obj) list (** {6 Object iteration functions. } *) -val open_objects : int -> Libnames.object_prefix -> lib_objects -> unit -val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit +val open_objects : int -> Nametab.object_prefix -> lib_objects -> unit +val load_objects : int -> Nametab.object_prefix -> lib_objects -> unit val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects -(*val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) +(*val load_and_subst_objects : int -> Libnames.Nametab.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) (** [classify_segment seg] verifies that there are no OpenedThings, clears ClosedSections and FrozenStates and divides Leafs according @@ -46,20 +48,20 @@ val classify_segment : (** [segment_of_objects prefix objs] forms a list of Leafs *) val segment_of_objects : - Libnames.object_prefix -> lib_objects -> library_segment + Nametab.object_prefix -> lib_objects -> library_segment (** {6 ... } *) (** Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) -val add_leaf : Id.t -> Libobject.obj -> Libnames.object_name +val add_leaf : Id.t -> Libobject.obj -> Libobject.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit -val pull_to_head : Libnames.object_name -> unit +val pull_to_head : Libobject.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) -val add_leaves : Id.t -> Libobject.obj list -> Libnames.object_name +val add_leaves : Id.t -> Libobject.obj list -> Libobject.object_name (** {6 ... } *) @@ -70,7 +72,7 @@ val contents : unit -> library_segment (** The function [contents_after] returns the current library segment, starting from a given section path. *) -val contents_after : Libnames.object_name -> library_segment +val contents_after : Libobject.object_name -> library_segment (** {6 Functions relative to current path } *) @@ -105,28 +107,28 @@ val find_opening_node : Id.t -> node val start_module : export -> module_ident -> ModPath.t -> - Summary.frozen -> Libnames.object_prefix + Summary.frozen -> Nametab.object_prefix val start_modtype : module_ident -> ModPath.t -> - Summary.frozen -> Libnames.object_prefix + Summary.frozen -> Nametab.object_prefix val end_module : unit -> - Libnames.object_name * Libnames.object_prefix * + Libobject.object_name * Nametab.object_prefix * Summary.frozen * library_segment val end_modtype : unit -> - Libnames.object_name * Libnames.object_prefix * + Libobject.object_name * Nametab.object_prefix * Summary.frozen * library_segment (** {6 Compilation units } *) val start_compilation : DirPath.t -> ModPath.t -> unit -val end_compilation_checks : DirPath.t -> Libnames.object_name +val end_compilation_checks : DirPath.t -> Libobject.object_name val end_compilation : - Libnames.object_name-> Libnames.object_prefix * library_segment + Libobject.object_name-> Nametab.object_prefix * library_segment (** The function [library_dp] returns the [DirPath.t] of the current compiling library (or [default_library]) *) diff --git a/library/libnames.ml b/library/libnames.ml index bd2ca550b9..87c4de42e8 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -162,37 +162,6 @@ let qualid_basename qid = let qualid_path qid = qid.CAst.v.dirpath -type object_name = full_path * KerName.t - -type object_prefix = { - obj_dir : DirPath.t; - obj_mp : ModPath.t; - obj_sec : DirPath.t; -} - -(* let make_oname (dirpath,(mp,dir)) id = *) -let make_oname { obj_dir; obj_mp } id = - make_path obj_dir id, KerName.make obj_mp (Label.of_id id) - -(* to this type are mapped DirPath.t's in the nametab *) -type global_dir_reference = - | DirOpenModule of object_prefix - | DirOpenModtype of object_prefix - | DirOpenSection of object_prefix - | DirModule of object_prefix - -let eq_op op1 op2 = - DirPath.equal op1.obj_dir op2.obj_dir && - DirPath.equal op1.obj_sec op2.obj_sec && - ModPath.equal op1.obj_mp op2.obj_mp - -let eq_global_dir_reference r1 r2 = match r1, r2 with -| DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 -| DirOpenModtype op1, DirOpenModtype op2 -> eq_op op1 op2 -| DirOpenSection op1, DirOpenSection op2 -> eq_op op1 op2 -| DirModule op1, DirModule op2 -> eq_op op1 op2 -| _ -> false - (* Default paths *) let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/libnames.mli b/library/libnames.mli index 447eecbb5c..9960603cbb 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -88,46 +88,6 @@ val qualid_is_ident : qualid -> bool val qualid_path : qualid -> DirPath.t val qualid_basename : qualid -> Id.t -(** Both names are passed to objects: a "semantic" [kernel_name], which - can be substituted and a "syntactic" [full_path] which can be printed -*) - -type object_name = full_path * KerName.t - -(** Object prefix morally contains the "prefix" naming of an object to - be stored by [library], where [obj_dir] is the "absolute" path, - [obj_mp] is the current "module" prefix and [obj_sec] is the - "section" prefix. - - Thus, for an object living inside [Module A. Section B.] the - prefix would be: - - [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ] - - Note that both [obj_dir] and [obj_sec] are "paths" that is to say, - as opposed to [obj_mp] which is a single module name. - - *) -type object_prefix = { - obj_dir : DirPath.t; - obj_mp : ModPath.t; - obj_sec : DirPath.t; -} - -val eq_op : object_prefix -> object_prefix -> bool - -val make_oname : object_prefix -> Id.t -> object_name - -(** to this type are mapped [DirPath.t]'s in the nametab *) -type global_dir_reference = - | DirOpenModule of object_prefix - | DirOpenModtype of object_prefix - | DirOpenSection of object_prefix - | DirModule of object_prefix - -val eq_global_dir_reference : - global_dir_reference -> global_dir_reference -> bool - (** {6 ... } *) (** some preset paths *) diff --git a/library/libobject.ml b/library/libobject.ml index 79a3fed1b9..c153e9a09a 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Libnames open Pp module Dyn = Dyn.Make () @@ -16,6 +15,8 @@ module Dyn = Dyn.Make () type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a +type object_name = Libnames.full_path * Names.KerName.t + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; @@ -65,7 +66,7 @@ type dynamic_object_declaration = { let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t let cache_tab = - (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) + (Hashtbl.create 223 : (string,dynamic_object_declaration) Hashtbl.t) let declare_object_full odecl = let na = odecl.object_name in diff --git a/library/libobject.mli b/library/libobject.mli index aefa81b225..32ffc5b79e 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -66,6 +66,12 @@ open Mod_subst type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a +(** Both names are passed to objects: a "semantic" [kernel_name], which + can be substituted and a "syntactic" [full_path] which can be printed +*) + +type object_name = full_path * Names.KerName.t + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; diff --git a/library/nametab.ml b/library/nametab.ml index 06ace373c3..e29c7b2960 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -15,6 +15,39 @@ open Names open Libnames open Globnames +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} + +let eq_op op1 op2 = + DirPath.equal op1.obj_dir op2.obj_dir && + DirPath.equal op1.obj_sec op2.obj_sec && + ModPath.equal op1.obj_mp op2.obj_mp + +(* to this type are mapped DirPath.t's in the nametab *) +module GlobDirRef = struct + type t = + | DirOpenModule of object_prefix + | DirOpenModtype of object_prefix + | DirOpenSection of object_prefix + | DirModule of object_prefix + + let equal r1 r2 = match r1, r2 with + | DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 + | DirOpenModtype op1, DirOpenModtype op2 -> eq_op op1 op2 + | DirOpenSection op1, DirOpenSection op2 -> eq_op op1 op2 + | DirModule op1, DirModule op2 -> eq_op op1 op2 + | _ -> false + +end + +type global_dir_reference = GlobDirRef.t +[@@ocaml.deprecated "Use [GlobDirRef.t]"] + +let eq_global_dir_reference = GlobDirRef.equal +[@@ocaml.deprecated "Use [GlobDirRef.equal]"] exception GlobalizationError of qualid @@ -74,6 +107,8 @@ module type NAMETREE = sig val user_name : qualid -> t -> user_name val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list + (** Matches a prefix of [qualid], useful for completion *) + val match_prefixes : qualid -> t -> elt list end module Make (U : UserName) (E : EqualityType) : NAMETREE @@ -259,9 +294,19 @@ let find_prefixes qid tab = search_prefixes (Id.Map.find id tab) (DirPath.repr dir) with Not_found -> [] -end - +let match_prefixes = + let cprefix x y = CString.(compare x (sub y 0 (min (length x) (length y)))) in + fun qid tab -> + try + let (dir,id) = repr_qualid qid in + let id_prefix = cprefix Id.(to_string id) in + let matches = Id.Map.filter_range (fun x -> id_prefix Id.(to_string x)) tab in + let matches = Id.Map.mapi (fun _key tab -> search_prefixes tab (DirPath.repr dir)) matches in + (* Coq's flatten is "magical", so this is not so bad perf-wise *) + CList.flatten @@ Id.Map.(fold (fun _ r l -> r :: l) matches []) + with Not_found -> [] +end (* Global name tables *************************************************) @@ -295,13 +340,7 @@ struct | id :: l -> (id, l) end -module GlobDir = -struct - type t = global_dir_reference - let equal = eq_global_dir_reference -end - -module DirTab = Make(DirPath')(GlobDir) +module DirTab = Make(DirPath')(GlobDirRef) (* If we have a (closed) module M having a submodule N, than N does not have the entry in [the_dirtab]. *) @@ -390,7 +429,7 @@ let push_modtype vis sp kn = let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with - | DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab + | GlobDirRef.DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab | _ -> () (* This is for global universe names *) @@ -424,17 +463,17 @@ let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with - | DirModule { obj_mp ; _} -> obj_mp + | GlobDirRef.DirModule { obj_mp ; _} -> obj_mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with - | DirModule { obj_dir ; _} -> obj_dir + | GlobDirRef.DirModule { obj_dir ; _} -> obj_dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with - | DirOpenSection { obj_dir; _ } -> obj_dir + | GlobDirRef.DirOpenSection { obj_dir; _ } -> obj_dir | _ -> raise Not_found let locate_all qid = @@ -447,6 +486,10 @@ let locate_extended_all_dir qid = DirTab.find_prefixes qid !the_dirtab let locate_extended_all_modtype qid = MPTab.find_prefixes qid !the_modtypetab +(* Completion *) +let completion_canditates qualid = + ExtRefTab.match_prefixes qualid !the_ccitab + (* Derived functions *) let locate_constant qid = diff --git a/library/nametab.mli b/library/nametab.mli index 1c3322bfb1..24af07619d 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -57,6 +57,44 @@ open Globnames *) +(** Object prefix morally contains the "prefix" naming of an object to + be stored by [library], where [obj_dir] is the "absolute" path, + [obj_mp] is the current "module" prefix and [obj_sec] is the + "section" prefix. + + Thus, for an object living inside [Module A. Section B.] the + prefix would be: + + [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ] + + Note that both [obj_dir] and [obj_sec] are "paths" that is to say, + as opposed to [obj_mp] which is a single module name. + + *) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} + +val eq_op : object_prefix -> object_prefix -> bool + +(** to this type are mapped [DirPath.t]'s in the nametab *) +module GlobDirRef : sig + type t = + | DirOpenModule of object_prefix + | DirOpenModtype of object_prefix + | DirOpenSection of object_prefix + | DirModule of object_prefix + val equal : t -> t -> bool +end + +type global_dir_reference = GlobDirRef.t +[@@ocaml.deprecated "Use [GlobDirRef.t]"] + +val eq_global_dir_reference : + GlobDirRef.t -> GlobDirRef.t -> bool +[@@ocaml.deprecated "Use [GlobDirRef.equal]"] exception GlobalizationError of qualid @@ -79,7 +117,7 @@ val map_visibility : (int -> int) -> visibility -> visibility val push : visibility -> full_path -> GlobRef.t -> unit val push_modtype : visibility -> full_path -> ModPath.t -> unit -val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit +val push_dir : visibility -> DirPath.t -> GlobDirRef.t -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit type universe_id = DirPath.t * int @@ -98,7 +136,7 @@ val locate_extended : qualid -> extended_global_reference val locate_constant : qualid -> Constant.t val locate_syndef : qualid -> syndef_name val locate_modtype : qualid -> ModPath.t -val locate_dir : qualid -> global_dir_reference +val locate_dir : qualid -> GlobDirRef.t val locate_module : qualid -> ModPath.t val locate_section : qualid -> DirPath.t val locate_universe : qualid -> universe_id @@ -115,9 +153,15 @@ val global_inductive : qualid -> inductive val locate_all : qualid -> GlobRef.t list val locate_extended_all : qualid -> extended_global_reference list -val locate_extended_all_dir : qualid -> global_dir_reference list +val locate_extended_all_dir : qualid -> GlobDirRef.t list val locate_extended_all_modtype : qualid -> ModPath.t list +(** Experimental completion support, API is _unstable_ *) +val completion_canditates : qualid -> extended_global_reference list +(** [completion_canditates qualid] will return the list of global + references that have [qualid] as a prefix. UI usually will want to + compose this with [shortest_qualid_of_global] *) + (** Mapping a full path to a global reference *) val global_of_path : full_path -> GlobRef.t @@ -211,6 +255,7 @@ module type NAMETREE = sig val user_name : qualid -> t -> user_name val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list + val match_prefixes : qualid -> t -> elt list end module Make (U : UserName) (E : EqualityType) : diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index c41687e721..b9274cf6b8 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -20,6 +20,7 @@ open Tacticals.New open Tacinterp open Stdarg open Tacarg +open Attributes open Pcoq.Prim } @@ -73,10 +74,9 @@ let (set_default_solver, default_solver, print_default_solver) = } VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF -| [ "Set" "Firstorder" "Solver" tactic(t) ] -> { - let open Vernacinterp in +| #[ locality; ] [ "Set" "Firstorder" "Solver" tactic(t) ] -> { set_default_solver - (Locality.make_section_locality atts.locality) + (Locality.make_section_locality locality) (Tacintern.glob_tactic t) } END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ad1114b733..651895aa08 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -229,10 +229,6 @@ let isAppConstruct ?(env=Global.env ()) sigma t = true with Not_found -> false -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env @@ Evd.from_env Environ.empty_env - - exception NoChange let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = @@ -420,7 +416,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp @@ -800,7 +796,7 @@ let build_proof g | LetIn _ -> let new_infos = - { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in tclTHENLIST @@ -834,7 +830,7 @@ let build_proof | LetIn _ -> let new_infos = { dyn_infos with - info = nf_betaiotazeta dyn_infos.info + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in @@ -977,7 +973,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "body " ++ pr_lconstr bodies.(num)); *) let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f @@ -1008,7 +1004,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd lemma_type (Lemmas.mk_hook (fun _ _ -> ())); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d57b931785..d1e7d8a5a8 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -307,7 +307,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) hook @@ -359,10 +359,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = - let poly = Flags.is_universe_polymorphism () in - Evd.const_univ_entry ~poly evd' - in + let univs = Evd.const_univ_entry ~poly:false evd' in let ce = Declare.definition_entry ~univs value in ignore( Declare.declare_constant diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 7c80b776a4..98aaa081c3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1494,7 +1494,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds (Flags.is_universe_polymorphism ()) false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9a6169d42a..35acbea488 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -414,7 +414,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ComDefinition.do_definition ~program_mode:false fname - (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl + (Decl_kinds.Global,false,Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left @@ -431,7 +431,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + ComFixpoint.do_fixpoint Global false fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index b0842c3721..d1a227d517 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -63,12 +63,6 @@ let observe_tac s tac g = then do_observe_tac (str s) tac g else tac g -(* [nf_zeta] $\zeta$-normalization of a term *) -let nf_zeta = - Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - Environ.empty_env - (Evd.from_env Environ.empty_env) - let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl (* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *) @@ -219,7 +213,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in - let princ_type = nf_zeta princ_type in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in @@ -397,7 +391,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (nf_zeta p)::bindings,id::avoid) + (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -630,12 +624,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in + let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -771,7 +765,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in evd := sigma; - let type_of_lemma = nf_zeta type_of_lemma in + let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) @@ -810,7 +804,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let (typ,_) = lemmas_types_infos.(i) in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) + (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd typ (Lemmas.mk_hook (fun _ _ -> ())); @@ -838,7 +832,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); type_of_lemma,type_info ) @@ -872,7 +866,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index f9df3aed45..63a3e0582d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -103,21 +103,6 @@ let const_of_ref = function ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") - -let nf_zeta env = - Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env (Evd.from_env env) - - -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env - (Evd.from_env Environ.empty_env) - - - - - - (* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in @@ -747,7 +732,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) )) g @@ -1537,13 +1522,13 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in let evd = Evd.minimize_universes evd in - let equation_lemma_type = nf_betaiotazeta (Evarutil.nf_evar evd ty) in + let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in - let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in + let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index b660865e8b..85fb0c73c9 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -30,7 +30,7 @@ open Namegen open Tactypes open Tactics open Proofview.Notations -open Vernacinterp +open Attributes let wit_hyp = wit_var @@ -321,15 +321,15 @@ let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater } VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:atts.polymorphic bl o None l } -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~poly:polymorphic bl o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l } -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - { add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l } -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - { add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l } + { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) @@ -411,45 +411,39 @@ let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater END*) VERNAC COMMAND EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac } + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_clear_tac } -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => { seff na } +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac } + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_clear_tac } END VERNAC COMMAND EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac } + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_tac } -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => { seff na } +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac } + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_tac } END VERNAC COMMAND EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac } + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_tac } END VERNAC COMMAND EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => { seff na } -> { - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac } + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_clear_tac } END (**********************************************************************) @@ -855,9 +849,9 @@ END TACTIC EXTEND transparent_abstract | [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } | [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } END (* ********************************************************************* *) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index c07b653f3a..5af393a3e5 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -239,10 +239,9 @@ ARGUMENT EXTEND opthints END VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { - let open Vernacinterp in +| #[ locality = Attributes.locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints ~local:(Locality.make_section_locality atts.locality) + Hints.add_hints ~local:(Locality.make_section_locality locality) (match dbnames with None -> ["core"] | Some l -> l) entry; } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index d62f985350..c58c8556c5 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -22,6 +22,7 @@ open Genarg open Genredexpr open Tok (* necessary for camlp5 *) open Names +open Attributes open Pcoq open Pcoq.Prim @@ -498,12 +499,12 @@ VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY { pr_ltac_production_item END VERNAC COMMAND EXTEND VernacTacticNotation -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => +| #[ deprecation; locality; ] + [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => { VtSideff [], VtNow } -> - { let open Vernacinterp in - let n = Option.default 0 n in - let deprecation = atts.deprecated in - Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n ?deprecation r e; + { + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality locality) n ?deprecation r e; } END @@ -545,13 +546,12 @@ PRINTED BY { pr_tacdef_body } END VERNAC COMMAND EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { +| #[ deprecation; locality; ] [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { VtSideff (List.map (function | TacticDefinition ({CAst.v=r},_) -> r | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater - } -> { let open Vernacinterp in - let deprecation = atts.deprecated in - Tacentries.register_ltac (Locality.make_module_locality atts.locality) ?deprecation l; + } -> { + Tacentries.register_ltac (Locality.make_module_locality locality) ?deprecation l; } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 26f2b08d3a..aa78fb5d1e 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -131,10 +131,9 @@ VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF END VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> { - let open Vernacinterp in +| #[ locality = Attributes.locality; ] [ "Obligation" "Tactic" ":=" tactic(t) ] -> { set_default_tactic - (Locality.make_section_locality atts.locality) + (Locality.make_section_locality locality) (Tacintern.glob_tactic t); } END diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 3e47724c4c..1c7220ddc0 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -180,36 +180,36 @@ TACTIC EXTEND setoid_rewrite END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - { declare_relation a aeq n (Some lemma1) (Some lemma2) None } + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> - { declare_relation a aeq n (Some lemma1) None None } - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - { declare_relation a aeq n None None None } + { declare_relation atts a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - { declare_relation a aeq n None (Some lemma2) None } - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation a aeq n None (Some lemma2) (Some lemma3) } + { declare_relation atts a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation a aeq n (Some lemma1) None (Some lemma3) } - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation a aeq n None None (Some lemma3) } + { declare_relation atts a aeq n None None (Some lemma3) } END { @@ -236,64 +236,64 @@ GRAMMAR EXTEND Gram END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None } - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n (Some lemma1) None None } - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n None None None } + { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n None (Some lemma2) None } - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) } + { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) } - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - { declare_relation ~binders:b a aeq n None None (Some lemma3) } + { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - | [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - { let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) [] a aeq t n; + | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts [] a aeq t n; } - | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - { let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) binders a aeq t n; + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts binders a aeq t n; } - | [ "Add" "Morphism" constr(m) ":" ident(n) ] + | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => { Vernacexpr.VtUnknown, Vernacexpr.VtNow } - -> { let open Vernacinterp in - add_morphism_infer (not (Locality.make_section_locality atts.locality)) m n; + -> { + add_morphism_infer atts m n; } - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } - -> { let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) [] m s n; + -> { + add_morphism atts [] m s n; } - | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } - -> { let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) binders m s n; + -> { + add_morphism atts binders m s n; } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 9f7669f1d5..7d917c58fe 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -43,6 +43,14 @@ module NamedDecl = Context.Named.Declaration (** Typeclass-based generalized rewriting. *) +type rewrite_attributes = { polymorphic : bool; program : bool; global : bool } + +let rewrite_attributes = + let open Attributes.Notations in + Attributes.(polymorphic ++ program ++ locality) >>= fun ((polymorphic, program), locality) -> + let global = not (Locality.make_section_locality locality) in + Attributes.Notations.return { polymorphic; program; global } + (** Constants used by the tactic. *) let classes_dirpath = @@ -1492,7 +1500,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul if not (Evd.is_defined acc ev) then user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ - Termops.pr_evar_info (Evd.find acc ev)) + Termops.pr_evar_info env acc (Evd.find acc ev)) else Evd.remove acc ev) cstrs evars' in @@ -1776,67 +1784,65 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance global binders instance fields = - let program_mode = Flags.is_program_mode () in - let poly = Flags.is_universe_polymorphism () in - new_instance ~program_mode poly +let anew_instance atts binders instance fields = + let program_mode = atts.program in + new_instance ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) - ~global ~generalize:false ~refine:false Hints.empty_hint_info + ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl global binders a aeq n lemma = +let declare_instance_refl atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance global binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] -let declare_instance_sym global binders a aeq n lemma = +let declare_instance_sym atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance global binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "symmetry"),lemma)] -let declare_instance_trans global binders a aeq n lemma = +let declare_instance_trans atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance global binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = +let declare_relation atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let global = not (Locality.make_section_locality locality) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance global binders instance []); + in ignore(anew_instance atts binders instance []); match (refl,symm,trans) with (None, None, None) -> () | (Some lemma1, None, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1) + ignore (declare_instance_refl atts binders a aeq n lemma1) | (None, Some lemma2, None) -> - ignore (declare_instance_sym global binders a aeq n lemma2) + ignore (declare_instance_sym atts binders a aeq n lemma2) | (None, None, Some lemma3) -> - ignore (declare_instance_trans global binders a aeq n lemma3) + ignore (declare_instance_trans atts binders a aeq n lemma3) | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1); - ignore (declare_instance_sym global binders a aeq n lemma2) + ignore (declare_instance_refl atts binders a aeq n lemma1); + ignore (declare_instance_sym atts binders a aeq n lemma2) | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( - anew_instance global binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( - anew_instance global binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance global binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) @@ -1935,15 +1941,15 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid global binders a aeq t n = +let add_setoid atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance global binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) @@ -1958,26 +1964,26 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer glob m n = +let add_morphism_infer atts m n = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); - let poly = Flags.is_universe_polymorphism () in + (* NB: atts.program is ignored, program mode automatically set by vernacentries *) let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then - let uctx = UState.const_univ_entry ~poly uctx in + let uctx = UState.const_univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob (ConstRef cst)); + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else - let kind = Decl_kinds.Global, poly, + let kind = Decl_kinds.Global, atts.polymorphic, Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1985,7 +1991,7 @@ let add_morphism_infer glob m n = | Globnames.ConstRef cst -> add_instance (Typeclasses.new_instance (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info - glob (ConstRef cst)); + atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false in @@ -1995,9 +2001,8 @@ let add_morphism_infer glob m n = Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook; ignore (Pfedit.by (Tacinterp.interp tac))) () -let add_morphism glob binders m s n = +let add_morphism atts binders m s n = init_setoid (); - let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, @@ -2006,8 +2011,7 @@ let add_morphism glob binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let program_mode = Flags.is_program_mode () in - ignore(new_instance ~program_mode ~global:glob poly binders instance + ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord [])) ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 0d014a0bf3..4f46e78c71 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -19,6 +19,9 @@ open Tacinterp (** TODO: document and clean me! *) +type rewrite_attributes +val rewrite_attributes : rewrite_attributes Attributes.attribute + type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat @@ -77,18 +80,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : ?locality:bool -> +val declare_relation : rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> constr_expr option -> constr_expr option -> constr_expr option -> unit val add_setoid : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> Id.t -> unit -val add_morphism_infer : bool -> constr_expr -> Id.t -> unit +val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> unit val add_morphism : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 16cff420bd..0f88734caf 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -353,7 +353,7 @@ let extend_atomic_tactic name entries = let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + | Some def -> Tacintern.intern_tactic_or_tacarg (Genintern.empty_glob_sign Environ.empty_env) def in try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None in diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 5b4bedb50a..c93d6251e0 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,7 +12,7 @@ open Vernacexpr open Tacexpr -open Vernacinterp +open Attributes (** {5 Tactic Definitions} *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index a88285c9ee..d5f22b2c72 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -55,7 +55,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Vernacinterp.deprecation option; + alias_deprecation: Attributes.deprecation option; } let alias_map = Summary.ref ~name:"tactic-alias" @@ -121,7 +121,7 @@ type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; - tac_deprecation : Vernacinterp.deprecation option + tac_deprecation : Attributes.deprecation option } let mactab = @@ -178,7 +178,7 @@ let subst_md (subst, (local, id, b, t, deprecation)) = let classify_md (local, _, _, _, _ as o) = Substitute o let inMD : bool * ltac_constant option * bool * glob_tactic_expr * - Vernacinterp.deprecation option -> obj = + Attributes.deprecation option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index d5d36c97fa..5b98daf383 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,7 +12,7 @@ open Names open Libnames open Tacexpr open Geninterp -open Vernacinterp +open Attributes (** This module centralizes the various ways of registering tactics. *) @@ -33,7 +33,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Vernacinterp.deprecation option; + alias_deprecation: deprecation option; } (** Contents of a tactic notation *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 55412c74bb..ebec3c887c 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -44,9 +44,9 @@ type glob_sign = Genintern.glob_sign = { (* ltac variables and the subset of vars introduced by Intro/Let/... *) genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -let fully_empty_glob_sign = Genintern.empty_glob_sign Environ.empty_env let make_empty_glob_sign () = Genintern.empty_glob_sign (Global.env ()) (* We have identifier <| global_reference <| constr *) @@ -83,7 +83,8 @@ let intern_hyp ist ({loc;v=id} as locid) = else if find_ident id ist then make id else - Pretype_errors.error_var_not_found ?loc id + CErrors.user_err ?loc Pp.(str "Hypothesis" ++ spc () ++ Id.print id ++ spc() ++ + str "was not found in the current environment.") let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -121,15 +122,15 @@ let warn_deprecated_tactic = CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ strbrk " is deprecated" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) let warn_deprecated_alias = CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ strbrk " is deprecated since" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) let intern_isolated_global_tactic_reference qid = let loc = qid.CAst.loc in @@ -209,7 +210,7 @@ let intern_binding_name ist x = and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = +let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra; intern_sign} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { @@ -218,7 +219,7 @@ let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = ltac_extra = extra; } in let c' = - warn (Constrintern.intern_gen scope ~pattern_mode ~ltacvars env Evd.(from_env env)) c + warn (Constrintern.intern_core scope ~pattern_mode ~ltacvars env Evd.(from_env env) intern_sign) c in (c',if !strict_check then None else Some c) diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 9146fced2d..178f6af71d 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -21,12 +21,11 @@ type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -val fully_empty_glob_sign : glob_sign - val make_empty_glob_sign : unit -> glob_sign - (** same as [fully_empty_glob_sign], but with [Global.env()] as + (** build an empty [glob_sign] using [Global.env()] as environment *) (** Main globalization functions *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index b60b77595b..2a046a3e65 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -686,7 +686,7 @@ let interp_may_eval f ist env sigma = function | ConstrContext ({loc;v=s},c) -> (try let (sigma,ic) = f ist env sigma c in - let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let ctxt = try_interp_ltac_var coerce_to_constr_context ist (Some (env, sigma)) (make ?loc s) in let ctxt = EConstr.Unsafe.to_constr ctxt in let ic = EConstr.Unsafe.to_constr ic in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in @@ -1078,7 +1078,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with push_trace(None,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:TacAbstract" trace (catch_error_tac trace begin - Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.enter begin fun gl -> Abstract.tclABSTRACT (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t) end end) | TacThen (t1,t) -> @@ -2024,7 +2024,7 @@ let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k let interp_redexp env sigma r = let ist = default_ist () in - let gist = { fully_empty_glob_sign with genv = env; } in + let gist = Genintern.empty_glob_sign env in interp_red_expr ist env sigma (intern_red_expr gist r) (***************************************************************************) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index a284c3bfc7..5d75b28539 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -940,7 +940,7 @@ let pf_saturate ?beta ?bi_types gl c ?ty m = let pf_partial_solution gl t evl = let sigma, g = project gl, sig_it gl in - let sigma = Goal.V82.partial_solution sigma g t in + let sigma = Goal.V82.partial_solution (pf_env gl) sigma g t in re_sig (List.map (fun x -> (fst (EConstr.destEvar sigma x))) evl) sigma let dependent_apply_error = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index c04ced4ab4..036b20bfcd 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -433,15 +433,15 @@ let lz_coq_prod = let lz_setoid_relation = let sdir = ["Classes"; "RelationClasses"] in - let last_srel = ref (Environ.empty_env, None) in + let last_srel = ref None in fun env -> match !last_srel with - | env', srel when env' == env -> srel + | Some (env', srel) when env' == env -> srel | _ -> let srel = try Some (UnivGen.constr_of_global @@ Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in - last_srel := (env, srel); srel + last_srel := Some (env, srel); srel let ssr_is_setoid env = match lz_setoid_relation env with diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 940defb743..4ed75cdbe4 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -170,10 +170,9 @@ let declare_one_prenex_implicit locality f = } VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF - | [ "Prenex" "Implicits" ne_global_list(fl) ] + | #[ locality = Attributes.locality; ] [ "Prenex" "Implicits" ne_global_list(fl) ] -> { - let open Vernacinterp in - let locality = Locality.make_section_locality atts.locality in + let locality = Locality.make_section_locality locality in List.iter (declare_one_prenex_implicit locality) fl; } END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 7f67487f5d..bb6decd848 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -1048,7 +1048,7 @@ let thin id sigma goal = | None -> sigma | Some (sigma, hyps, concl) -> let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl in - let sigma = Goal.V82.partial_solution_to sigma goal gl ev in + let sigma = Goal.V82.partial_solution_to env sigma goal gl ev in sigma (* diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 5dbc9eea7a..13e0bcbd47 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -16,7 +16,6 @@ open Notation open Numeral open Pp open Names -open Vernacinterp open Ltac_plugin open Stdarg open Pcoq.Prim @@ -36,7 +35,7 @@ ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { vernac_numeral_notation (Locality.make_module_locality atts.locality) ty f g (Id.to_string sc) o } + { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 6a776dc961..6d1b6eefd4 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -17,6 +17,8 @@ val rename_arguments : bool -> GlobRef.t -> Name.t list -> unit (** [Not_found] is raised if no names are defined for [r] *) val arguments_names : GlobRef.t -> Name.t list +val rename_type : types -> GlobRef.t -> types + val rename_type_of_constant : env -> pconstant -> types val rename_type_of_inductive : env -> pinductive -> types val rename_type_of_constructor : env -> pconstructor -> types diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e15c00f7dc..e21c2fda85 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -104,6 +104,7 @@ let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env ev Evar_kinds.qm_name=na; }) in let evd, v = Evarutil.new_evar env !evdref ~src c in + let evd = Evd.set_obligation_evar evd (fst (destEvar evd v)) in evdref := evd; v diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 674f6846ae..96213af9c6 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -83,7 +83,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) (** Refresh the types of evars under template polymorphic references *) let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with - | App (f, args) when is_template_polymorphic env !evdref f -> + | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> let pos = get_polymorphic_positions !evdref f in refresh_polymorphic_positions args pos; t | App (f, args) when top && isEvar !evdref f -> @@ -1240,9 +1240,9 @@ let check_evar_instance evd evk1 body conv_algo = let update_evar_info ev1 ev2 evd = (* We update the source of obligation evars during evar-evar unifications. *) - let loc, evs2 = evar_source ev2 evd in - let evi = Evd.find evd ev1 in - Evd.add evd ev1 {evi with evar_source = loc, evs2} + let loc, evs1 = evar_source ev1 evd in + let evi = Evd.find evd ev2 in + Evd.add evd ev2 {evi with evar_source = loc, evs1} let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index ea222397a8..14358dd02a 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -746,8 +746,11 @@ let type_of_projection_knowing_arg env sigma p c ty = syntactic conditions *) let control_only_guard env sigma c = + let c = Evarutil.nf_evar sigma c in let check_fix_cofix e c = - match kind (EConstr.to_constr sigma c) with + (** [c] has already been normalized upfront *) + let c = EConstr.Unsafe.to_constr c in + match kind c with | CoFix (_,(_,_,_) as cofix) -> Inductive.check_cofix e cofix | Fix (_,(_,_,_) as fix) -> diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 856894d9a6..01b0d96f98 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -164,8 +164,8 @@ let error_not_product ?loc env sigma c = (*s Error in conversion from AST to glob_constr *) -let error_var_not_found ?loc s = - raise_pretype_error ?loc (empty_env, Evd.from_env empty_env, VarNotFound s) +let error_var_not_found ?loc env sigma s = + raise_pretype_error ?loc (env, sigma, VarNotFound s) (*s Typeclass errors *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 6f14d025c7..054f0c76a9 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -150,9 +150,7 @@ val error_unexpected_type : val error_not_product : ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b -(** {6 Error in conversion from AST to glob_constr } *) - -val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b +val error_var_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b (** {6 Typeclass errors } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 37afcf75e1..cba1533da5 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -390,7 +390,7 @@ let pretype_id pretype k0 loc env sigma id = sigma, { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id !!env) } with Not_found -> (* [id] not found, standard error message *) - error_var_not_found ?loc id + error_var_not_found ?loc !!env sigma id (*************************************************************************) (* Main pretyping function *) @@ -436,7 +436,7 @@ let pretype_ref ?loc sigma env ref us = (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) - Pretype_errors.error_var_not_found ?loc id) + Pretype_errors.error_var_not_found ?loc !!env sigma id) | ref -> let sigma, c = pretype_global ?loc univ_flexible env sigma ref us in let ty = unsafe_type_of !!env sigma c in @@ -457,6 +457,15 @@ let pretype_sort ?loc sigma = function let new_type_evar env sigma loc = new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) +let mark_obligation_evar sigma k evc = + if Flags.is_program_mode () then + match k with + | Evar_kinds.QuestionMark _ + | Evar_kinds.ImplicitArg (_, _, false) -> + Evd.set_obligation_evar sigma (fst (destEvar sigma evc)) + | _ -> sigma + else sigma + (* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) @@ -510,15 +519,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | Some ty -> sigma, ty | None -> new_type_evar env sigma loc in let sigma, uj_val = new_evar env sigma ~src:(loc,k) ~naming ty in - let sigma = - if Flags.is_program_mode () then - match k with - | Evar_kinds.QuestionMark _ - | Evar_kinds.ImplicitArg (_, _, false) -> - Evd.set_obligation_evar sigma (fst (destEvar sigma uj_val)) - | _ -> sigma - else sigma - in + let sigma = mark_obligation_evar sigma k uj_val in sigma, { uj_val; uj_type = ty } | GHole (k, _naming, Some arg) -> @@ -691,7 +692,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let sigma, resj = match EConstr.kind sigma resj.uj_val with | App (f,args) -> - if is_template_polymorphic !!env sigma f then + if Termops.is_template_polymorphic_ind !!env sigma f then (* Special case for inductive type applications that must be refreshed right away. *) let c = mkApp (f, args) in @@ -1039,6 +1040,7 @@ and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get | None -> let sigma, s = new_sort_variable univ_flexible_alg sigma in let sigma, utj_val = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in + let sigma = mark_obligation_evar sigma knd utj_val in sigma, { utj_val; utj_type = s}) | _ -> let sigma, j = pretype k0 resolve_tc empty_tycon env sigma c in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 367a48cb5e..aced97e910 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1251,6 +1251,7 @@ let clos_whd_flags flgs env sigma t = let nf_beta = clos_norm_flags CClosure.beta let nf_betaiota = clos_norm_flags CClosure.betaiota let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta +let nf_zeta = clos_norm_flags CClosure.zeta let nf_all env sigma = clos_norm_flags CClosure.all env sigma diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index c0ff6723f6..41de779414 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -171,6 +171,7 @@ val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function val nf_beta : reduction_function val nf_betaiota : reduction_function val nf_betaiotazeta : reduction_function +val nf_zeta : reduction_function val nf_all : reduction_function val nf_evar : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 7e43c5e41d..62ad296ecb 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -130,7 +130,7 @@ let retype ?(polyprop=true) sigma = subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) - | App(f,args) when is_template_polymorphic env sigma f -> + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in strip_outer_cast sigma (subst_type env sigma t (Array.to_list args)) | App(f,args) -> @@ -156,7 +156,7 @@ let retype ?(polyprop=true) sigma = let dom = sort_of env t in let rang = sort_of (push_rel (LocalAssum (name,t)) env) c2 in Typeops.sort_of_product env dom rang - | App(f,args) when is_template_polymorphic env sigma f -> + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in sort_of_atomic_type env sigma t args | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args @@ -190,14 +190,14 @@ let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env sigma f -> + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> if truncation_style then InType else let t = type_of_global_reference_knowing_parameters env f args in Sorts.family (sort_of_atomic_type env sigma t args) | App(f,args) -> Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | Ind _ when truncation_style && is_template_polymorphic env sigma t -> InType + | Ind _ when truncation_style && Termops.is_template_polymorphic_ind env sigma t -> InType | _ -> Sorts.family (decomp_sort env sigma (type_of env t)) in sort_family_of env t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 8911a2f343..4ec8569dd8 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1135,8 +1135,8 @@ let fold_commands cl env sigma c = let cbv_norm_flags flags env sigma t = cbv_norm (create_cbv_infos flags env sigma) t -let cbv_beta = cbv_norm_flags beta empty_env -let cbv_betaiota = cbv_norm_flags betaiota empty_env +let cbv_beta = cbv_norm_flags beta +let cbv_betaiota = cbv_norm_flags betaiota let cbv_betadeltaiota env sigma = cbv_norm_flags all env sigma let compute = cbv_betadeltaiota diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index bf38c30a1f..0887d0efd3 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -69,8 +69,8 @@ val pattern_occs : (occurrences * constr) list -> e_reduction_function (** Call by value strategy (uses Closures) *) val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function - val cbv_beta : local_reduction_function - val cbv_betaiota : local_reduction_function + val cbv_beta : reduction_function + val cbv_betaiota : reduction_function val cbv_betadeltaiota : reduction_function val compute : reduction_function (** = [cbv_betadeltaiota] *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index dc3f042431..b5729d7574 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -218,9 +218,6 @@ let judge_of_cast env sigma cj k tj = sigma, { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } -let enrich_env env sigma = - set_universes env @@ Evd.universes sigma - let check_fix env sigma pfix = let inj c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let (idx, (ids, cs, ts)) = pfix in @@ -277,6 +274,38 @@ let judge_of_letin env name defj typj j = { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } +let check_hyps_inclusion env sigma f x hyps = + let evars = Evarutil.safe_evar_value sigma, Evd.universes sigma in + let f x = EConstr.Unsafe.to_constr (f x) in + Typeops.check_hyps_inclusion env ~evars f x hyps + +let type_of_constant env sigma (c,u) = + let open Declarations in + let cb = Environ.lookup_constant c env in + let () = check_hyps_inclusion env sigma mkConstU (c,u) cb.const_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Environ.constant_type env (c,u) in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstRef c))) + +let type_of_inductive env sigma (ind,u) = + let open Declarations in + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Inductive.constrained_type_of_inductive env (specif,u) in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.IndRef ind))) + +let type_of_constructor env sigma ((ind,_ as ctor),u) = + let open Declarations in + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Inductive.constrained_type_of_constructor (ctor,u) specif in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstructRef ctor))) + (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env sigma cstr = @@ -297,17 +326,17 @@ let rec execute env sigma cstr = | Var id -> sigma, judge_of_variable env id - | Const (c, u) -> - let u = EInstance.kind sigma u in - sigma, make_judge cstr (EConstr.of_constr (rename_type_of_constant env (c, u))) + | Const c -> + let sigma, ty = type_of_constant env sigma c in + sigma, make_judge cstr ty - | Ind (ind, u) -> - let u = EInstance.kind sigma u in - sigma, make_judge cstr (EConstr.of_constr (rename_type_of_inductive env (ind, u))) + | Ind ind -> + let sigma, ty = type_of_inductive env sigma ind in + sigma, make_judge cstr ty - | Construct (cstruct, u) -> - let u = EInstance.kind sigma u in - sigma, make_judge cstr (EConstr.of_constr (rename_type_of_constructor env (cstruct, u))) + | Construct ctor -> + let sigma, ty = type_of_constructor env sigma ctor in + sigma, make_judge cstr ty | Case (ci,p,c,lf) -> let sigma, cj = execute env sigma c in @@ -391,7 +420,6 @@ and execute_recdef env sigma (names,lar,vdef) = and execute_array env = Array.fold_left_map (execute env) let check env sigma c t = - let env = enrich_env env sigma in let sigma, j = execute env sigma c in match Evarconv.cumul env sigma j.uj_type t with | None -> @@ -401,14 +429,12 @@ let check env sigma c t = (* Type of a constr *) let unsafe_type_of env sigma c = - let env = enrich_env env sigma in let sigma, j = execute env sigma c in j.uj_type (* Sort of a type *) let sort_of env sigma c = - let env = enrich_env env sigma in let sigma, j = execute env sigma c in let sigma, a = type_judgment env sigma j in sigma, a.utj_type @@ -416,7 +442,6 @@ let sort_of env sigma c = (* Try to solve the existential variables by typing *) let type_of ?(refresh=false) env sigma c = - let env = enrich_env env sigma in let sigma, j = execute env sigma c in (* side-effect on evdref *) if refresh then @@ -424,7 +449,6 @@ let type_of ?(refresh=false) env sigma c = else sigma, j.uj_type let solve_evars env sigma c = - let env = enrich_env env sigma in let sigma, j = execute env sigma c in (* side-effect on evdref *) sigma, nf_evar sigma j.uj_val diff --git a/pretyping/typing.mli b/pretyping/typing.mli index b8830ff4a2..366af0772f 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -48,6 +48,8 @@ val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map -> val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment +val judge_of_apply : env -> evar_map -> unsafe_judgment -> unsafe_judgment array -> + evar_map * unsafe_judgment val judge_of_abstraction : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment val judge_of_product : Environ.env -> Name.t -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 4619e049e0..e698ba9f8f 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -227,13 +227,11 @@ let print_if_is_coercion ref = let print_polymorphism ref = let poly = Global.is_polymorphic ref in let template_poly = Global.is_template_polymorphic ref in - if Flags.is_universe_polymorphism () || poly || template_poly then - [ pr_global ref ++ str " is " ++ str + [ pr_global ref ++ str " is " ++ str (if poly then "universe polymorphic" else if template_poly then "template universe polymorphic" else "not universe polymorphic") ] - else [] let print_type_in_type ref = let unsafe = Global.is_type_in_type ref in @@ -326,7 +324,7 @@ type locatable = Locatable : 'a locatable_info -> locatable type logical_name = | Term of GlobRef.t - | Dir of global_dir_reference + | Dir of Nametab.GlobDirRef.t | Syntactic of KerName.t | ModuleType of ModPath.t | Other : 'a * 'a locatable_info -> logical_name @@ -367,7 +365,9 @@ let pr_located_qualid = function | Syntactic kn -> str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) | Dir dir -> - let s,dir = match dir with + let s,dir = + let open Nametab in + let open GlobDirRef in match dir with | DirOpenModule { obj_dir ; _ } -> "Open Module", obj_dir | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir @@ -416,8 +416,8 @@ let locate_term qid = let locate_module qid = let all = Nametab.locate_extended_all_dir qid in - let map dir = match dir with - | DirModule { obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp) + let map dir = let open Nametab.GlobDirRef in match dir with + | DirModule { Nametab.obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp) | DirOpenModule _ -> Some (Dir dir, qid) | _ -> None in @@ -429,7 +429,7 @@ let locate_modtype qid = let modtypes = List.map map all in (** Don't forget the opened module types: they are not part of the same name tab. *) let all = Nametab.locate_extended_all_dir qid in - let map dir = match dir with + let map dir = let open Nametab.GlobDirRef in match dir with | DirOpenModtype _ -> Some (Dir dir, qid) | _ -> None in @@ -634,7 +634,7 @@ let gallina_print_library_entry env sigma with_values ent = gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (_,Lib.CompilingLibrary { obj_dir; _ }) -> + | (_,Lib.CompilingLibrary { Nametab.obj_dir; _ }) -> Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) @@ -759,7 +759,7 @@ let read_sec_context qid = with Not_found -> user_err ?loc:qid.loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function - | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> + | (_,Lib.OpenedSection ({Nametab.obj_dir;_},_) as hd)::rest -> if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest @@ -788,7 +788,7 @@ let print_any_name env sigma na udecl = | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp | Syntactic kn -> print_syntactic_def env kn - | Dir (DirModule { obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp + | Dir (Nametab.GlobDirRef.DirModule Nametab.{ obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp | Other (obj, info) -> info.print obj diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 58606db019..9213bc8561 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -19,7 +19,7 @@ val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option +val print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option val print_full_context : env -> Evd.evar_map -> Pp.t val print_full_context_typ : env -> Evd.evar_map -> Pp.t val print_full_pure_context : env -> Evd.evar_map -> Pp.t @@ -89,7 +89,7 @@ type object_pr = { print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; diff --git a/printing/printer.ml b/printing/printer.ml index 3cf995a005..da364c8b9e 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -969,19 +969,13 @@ let pr_assumptionset env sigma s = ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) -let xor a b = - (a && not b) || (not a && b) - let pr_cumulative poly cum = if poly then if cum then str "Cumulative " else str "NonCumulative " else mt () let pr_polymorphic b = - let print = xor (Flags.is_universe_polymorphism ()) b in - if print then - if b then str"Polymorphic " else str"Monomorphic " - else mt () + if b then str"Polymorphic " else str"Monomorphic " (* print the proof step, possibly with diffs highlighted, *) let print_and_diff oldp newp = diff --git a/printing/printmod.ml b/printing/printmod.ml index 20e0a989f3..cc40c74998 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -223,7 +223,7 @@ let print_kn locals kn = let nametab_register_dir obj_mp = let id = mk_fake_top () in let obj_dir = DirPath.make [id] in - Nametab.push_dir (Nametab.Until 1) obj_dir (DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty }) + Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty })) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here @@ -402,6 +402,7 @@ let rec printable_body dir = let dir = pop_dirpath dir in DirPath.is_empty dir || try + let open Nametab.GlobDirRef in match Nametab.locate_dir (qualid_of_dirpath dir) with DirOpenModtype _ -> false | DirModule _ | DirOpenModule _ -> printable_body dir diff --git a/proofs/clenv.ml b/proofs/clenv.ml index d25ae38c53..b7ccd647b5 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -577,7 +577,7 @@ let pr_clenv clenv = h 0 (str"TEMPL: " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templval.rebus ++ str" : " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templtyp.rebus ++ fnl () ++ - pr_evar_map (Some 2) clenv.evd) + pr_evar_map (Some 2) clenv.env clenv.evd) (****************************************************************) (** Evar version of mk_clenv *) @@ -603,12 +603,20 @@ let make_evar_clause env sigma ?len t = in (** FIXME: do the renaming online *) let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in - let rec clrec (sigma, holes) n t = + let rec clrec (sigma, holes) inst n t = if n = 0 then (sigma, holes, t) else match EConstr.kind sigma t with - | Cast (t, _, _) -> clrec (sigma, holes) n t + | Cast (t, _, _) -> clrec (sigma, holes) inst n t | Prod (na, t1, t2) -> - let (sigma, ev) = new_evar env sigma ~typeclass_candidate:false t1 in + (** Share the evar instances as we are living in the same context *) + let inst, ctx, args, subst = match inst with + | None -> + (** Dummy type *) + let ctx, _, args, subst = push_rel_context_to_named_context env sigma mkProp in + Some (ctx, args, subst), ctx, args, subst + | Some (ctx, args, subst) -> inst, ctx, args, subst + in + let (sigma, ev) = new_evar_instance ~typeclass_candidate:false ctx sigma (csubst_subst subst t1) args in let dep = not (noccurn sigma 1 t2) in let hole = { hole_evar = ev; @@ -618,11 +626,11 @@ let make_evar_clause env sigma ?len t = hole_name = na; } in let t2 = if dep then subst1 ev t2 else t2 in - clrec (sigma, hole :: holes) (pred n) t2 - | LetIn (na, b, _, t) -> clrec (sigma, holes) n (subst1 b t) + clrec (sigma, hole :: holes) inst (pred n) t2 + | LetIn (na, b, _, t) -> clrec (sigma, holes) inst n (subst1 b t) | _ -> (sigma, holes, t) in - let (sigma, holes, t) = clrec (sigma, []) bound t in + let (sigma, holes, t) = clrec (sigma, []) None bound t in let holes = List.rev holes in let clause = { cl_concl = t; cl_holes = holes } in (sigma, clause) diff --git a/proofs/goal.ml b/proofs/goal.ml index 4e540de538..7245d4a004 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -72,18 +72,18 @@ module V82 = struct (evk, ev, evars) (* Instantiates a goal with an open term *) - let partial_solution sigma evk c = + let partial_solution env sigma evk c = (* Check that the goal itself does not appear in the refined term *) let _ = if not (Evarutil.occur_evar_upto sigma evk c) then () - else Pretype_errors.error_occur_check Environ.empty_env sigma evk c + else Pretype_errors.error_occur_check env sigma evk c in Evd.define evk c sigma (* Instantiates a goal with an open term, using name of goal for evk' *) - let partial_solution_to sigma evk evk' c = + let partial_solution_to env sigma evk evk' c = let id = Evd.evar_ident evk sigma in - let sigma = partial_solution sigma evk c in + let sigma = partial_solution env sigma evk c in match id with | None -> sigma | Some id -> Evd.rename evk' id sigma diff --git a/proofs/goal.mli b/proofs/goal.mli index 3b31cff8d7..af9fb662bf 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -48,11 +48,11 @@ module V82 : sig goal * EConstr.constr * Evd.evar_map (* Instantiates a goal with an open term *) - val partial_solution : Evd.evar_map -> goal -> EConstr.constr -> Evd.evar_map + val partial_solution : Environ.env -> Evd.evar_map -> goal -> EConstr.constr -> Evd.evar_map (* Instantiates a goal with an open term, reusing name of goal for second goal *) - val partial_solution_to : Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map + val partial_solution_to : Environ.env -> Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool diff --git a/proofs/logic.ml b/proofs/logic.ml index 254c93d0a2..4d5711c195 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -384,7 +384,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | App (f,l) -> let (acc',hdty,sigma,applicand) = - if is_template_polymorphic env sigma (EConstr.of_constr f) then + if Termops.is_template_polymorphic_ind env sigma (EConstr.of_constr f) then let ty = (* Template polymorphism of definitions and inductive types *) let firstmeta = Array.findi (fun i x -> occur_meta sigma (EConstr.of_constr x)) l in @@ -447,7 +447,7 @@ and mk_hdgoals sigma goal goalacc trm = | App (f,l) -> let (acc',hdty,sigma,applicand) = - if is_template_polymorphic env sigma (EConstr.of_constr f) + if Termops.is_template_polymorphic_ind env sigma (EConstr.of_constr f) then let l' = meta_free_prefix sigma l in (goalacc,EConstr.Unsafe.to_constr (type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) l'),sigma,f) @@ -590,5 +590,5 @@ let prim_refiner r sigma goal = check_meta_variables env sigma c; let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in let sgl = List.rev sgl in - let sigma = Goal.V82.partial_solution sigma goal (EConstr.of_constr oterm) in + let sigma = Goal.V82.partial_solution env sigma goal (EConstr.of_constr oterm) in (sgl, sigma) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 388bf8efb5..231a8fe266 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -130,10 +130,10 @@ let db_pr_goal sigma g = str" " ++ pc) ++ fnl () let pr_gls gls = - hov 0 (pr_evar_map (Some 2) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) + hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) let pr_glls glls = - hov 0 (pr_evar_map (Some 2) (sig_sig glls) ++ fnl () ++ + hov 0 (pr_evar_map (Some 2) (Global.env()) (sig_sig glls) ++ fnl () ++ prlist_with_sep fnl (db_pr_goal (project glls)) (sig_it glls)) (* Variants of [Tacmach] functions built with the new proof engine *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index f302960870..14c83a6802 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -83,6 +83,7 @@ val refine : constr -> tactic (** {6 Pretty-printing functions (debug only). } *) val pr_gls : goal sigma -> Pp.t val pr_glls : goal list sigma -> Pp.t +[@@ocaml.deprecated "Please move to \"new\" proof engine"] (** Variants of [Tacmach] functions built with the new proof engine *) module New : sig diff --git a/stm/stm.ml b/stm/stm.ml index 19915b1600..514b364af3 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1077,6 +1077,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | _ -> false in let aux_interp st expr = + (* XXX unsupported attributes *) let cmd = Vernacprop.under_control expr in if is_filtered_command cmd then (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) @@ -2028,7 +2029,7 @@ end = struct (* {{{ *) str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ str"uc=" ++ Termops.pr_evar_universe_context uc)); - (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) + (if abstract then Abstract.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> Tactics.exact_no_check (EConstr.of_constr pt)) | None -> @@ -2132,7 +2133,7 @@ and Reach : sig end = struct (* {{{ *) let async_policy () = - if Flags.is_universe_polymorphism () then false + if Attributes.is_universe_polymorphism () then false else if VCS.is_interactive () = `Yes then (async_proofs_is_master !cur_opt || !cur_opt.async_proofs_mode = APonLazy) else diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 85babd922b..c93487d377 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -50,7 +50,7 @@ let idents_of_name : Names.Name.t -> Names.Id.t list = let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = - [ Vernacentries.universe_polymorphism_option_name; + [ Attributes.universe_polymorphism_option_name; stm_allow_nested_proofs_option_name ] let classify_vernac e = @@ -192,16 +192,15 @@ let classify_vernac e = try Vernacentries.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier ~poly = function + let rec static_control_classifier = function | VernacExpr (f, e) -> - let _, atts = Vernacentries.attributes_of_flags f Vernacinterp.(mk_atts ~polymorphic:poly ()) in - let poly = atts.Vernacinterp.polymorphic in + let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in static_classifier ~poly e - | VernacTimeout (_,e) -> static_control_classifier ~poly e + | VernacTimeout (_,e) -> static_control_classifier e | VernacTime (_,{v=e}) | VernacRedirect (_, {v=e}) -> - static_control_classifier ~poly e + static_control_classifier e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) - (match static_control_classifier ~poly e with + (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ | VtProofMode _ | VtMeta), _ as x -> x | VtQed _, _ -> @@ -209,7 +208,7 @@ let classify_vernac e = VtNow | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) in - static_control_classifier ~poly:(Flags.is_universe_polymorphism ()) e + static_control_classifier e let classify_as_query = VtQuery, VtLater let classify_as_sideeff = VtSideff [], VtLater diff --git a/tactics/abstract.ml b/tactics/abstract.ml new file mode 100644 index 0000000000..2b4d9a7adf --- /dev/null +++ b/tactics/abstract.ml @@ -0,0 +1,195 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module CVars = Vars + +open Util +open Names +open Termops +open EConstr +open Decl_kinds +open Evarutil + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* tactical to save as name a subproof such that the generalisation of + the current goal, abstracted with respect to the local signature, + is solved by tac *) + +(** d1 is the section variable in the global context, d2 in the goal context *) +let interpretable_as_section_decl env evd d1 d2 = + let open Context.Named.Declaration in + let e_eq_constr_univs sigma c1 c2 = match eq_constr_universes env !sigma c1 c2 with + | None -> false + | Some cstr -> + try ignore (Evd.add_universe_constraints !sigma cstr); true + with UState.UniversesDiffer -> false + in + match d2, d1 with + | LocalDef _, LocalAssum _ -> false + | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> + e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (NamedDecl.get_type d2) + +let rec decompose len c t accu = + let open Constr in + let open Context.Rel.Declaration in + if len = 0 then (c, t, accu) + else match kind c, kind t with + | Lambda (na, u, c), Prod (_, _, t) -> + decompose (pred len) c t (LocalAssum (na, u) :: accu) + | LetIn (na, b, u, c), LetIn (_, _, _, t) -> + decompose (pred len) c t (LocalDef (na, b, u) :: accu) + | _ -> assert false + +let rec shrink ctx sign c t accu = + let open Constr in + let open CVars in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + if noccurn 1 c && noccurn 1 t then + let c = subst1 mkProp c in + let t = subst1 mkProp t in + shrink ctx sign c t accu + else + let c = Term.mkLambda_or_LetIn p c in + let t = Term.mkProd_or_LetIn p t in + let accu = if RelDecl.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu + in + shrink ctx sign c t accu +| _ -> assert false + +let shrink_entry sign const = + let open Entries in + let typ = match const.const_entry_type with + | None -> assert false + | Some t -> t + in + (** The body has been forced by the call to [build_constant_by_tactic] *) + let () = assert (Future.is_over const.const_entry_body) in + let ((body, uctx), eff) = Future.force const.const_entry_body in + let (body, typ, ctx) = decompose (List.length sign) body typ [] in + let (body, typ, args) = shrink ctx sign body typ [] in + let const = { const with + const_entry_body = Future.from_val ((body, uctx), eff); + const_entry_type = Some typ; + } in + (const, args) + +let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = + let open Tacticals.New in + let open Tacmach.New in + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let current_sign = Global.named_context_val () + and global_sign = Proofview.Goal.hyps gl in + let evdref = ref sigma in + let sign,secsign = + List.fold_right + (fun d (s1,s2) -> + let id = NamedDecl.get_id d in + if mem_named_context_val id current_sign && + interpretable_as_section_decl env evdref (lookup_named_val id current_sign) d + then (s1,push_named_context_val d s2) + else (Context.Named.add d s1,s2)) + global_sign (Context.Named.empty, Environ.empty_named_context_val) in + let id = Namegen.next_global_ident_away id (pf_ids_set_of_hyps gl) in + let concl = match goal_type with + | None -> Proofview.Goal.concl gl + | Some ty -> ty in + let concl = it_mkNamedProd_or_LetIn concl sign in + let concl = + try flush_and_check_evars !evdref concl + with Uninstantiated_evar _ -> + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") in + + let evd, ctx, concl = + (* FIXME: should be done only if the tactic succeeds *) + let evd = Evd.minimize_universes !evdref in + let ctx = Evd.universe_context_set evd in + evd, ctx, Evarutil.nf_evars_universes evd concl + in + let concl = EConstr.of_constr concl in + let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in + let ectx = Evd.evar_universe_context evd in + let (const, safe, ectx) = + try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac + with Logic_monad.TacticFailure e as src -> + (* if the tactic [tac] fails, it reports a [TacticFailure e], + which is an error irrelevant to the proof system (in fact it + means that [e] comes from [tac] failing to yield enough + success). Hence it reraises [e]. *) + let (_, info) = CErrors.push src in + iraise (e, info) + in + let const, args = shrink_entry sign const in + let args = List.map EConstr.of_constr args in + let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in + let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in + let cst () = + (** do not compute the implicit arguments, it may be costly *) + let () = Impargs.make_implicit_args false in + (** ppedrot: seems legit to have abstracted subproofs as local*) + Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl + in + let cst = Impargs.with_implicit_protection cst () in + let inst = match const.Entries.const_entry_universes with + | Entries.Monomorphic_const_entry _ -> EInstance.empty + | Entries.Polymorphic_const_entry ctx -> + (** We mimick what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EInstance.make (Univ.UContext.instance ctx) + in + let lem = mkConstU (cst, inst) in + let evd = Evd.set_universe_context evd ectx in + let open Safe_typing in + let eff = private_con_of_con (Global.safe_env ()) cst in + let effs = concat_private eff + Entries.(snd (Future.force const.const_entry_body)) in + let solve = + Proofview.tclEFFECTS effs <*> + tacK lem args + in + let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac + end + +let abstract_subproof ~opaque id gk tac = + cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> Tactics.exact_no_check (applist (lem, args))) + +let anon_id = Id.of_string "anonymous" + +let name_op_to_name name_op object_kind suffix = + let open Proof_global in + let default_gk = (Global, false, object_kind) in + let name, gk = match Proof_global.V82.get_current_initial_conclusions () with + | (id, (_, gk)) -> Some id, gk + | exception NoCurrentProof -> None, default_gk + in + match name_op with + | Some s -> s, gk + | None -> + let name = Option.default anon_id name in + Nameops.add_suffix name suffix, gk + +let tclABSTRACT ?(opaque=true) name_op tac = + let s, gk = if opaque + then name_op_to_name name_op (Proof Theorem) "_subproof" + else name_op_to_name name_op (DefinitionBody Definition) "_subterm" in + abstract_subproof ~opaque s gk tac diff --git a/tactics/abstract.mli b/tactics/abstract.mli new file mode 100644 index 0000000000..7fb671fbf8 --- /dev/null +++ b/tactics/abstract.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr + +val cache_term_by_tactic_then : opaque:bool -> ?goal_type:(constr option) -> Id.t -> Decl_kinds.goal_kind -> unit Proofview.tactic -> (constr -> constr list -> unit Proofview.tactic) -> unit Proofview.tactic + +val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a6a104ccca..5cead11a5c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module CVars = Vars - open Pp open CErrors open Util @@ -36,7 +34,6 @@ open Refiner open Tacticals open Hipattern open Coqlib -open Decl_kinds open Evarutil open Indrec open Pretype_errors @@ -4100,12 +4097,15 @@ let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let (mind, u), _ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in - let evd, elimc = - if isrec && not (is_nonrec mind) then find_ind_eliminator mind s gl + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + let sigma, elimc = + if isrec && not (is_nonrec mind) + then + let gr = lookup_eliminator mind s in + Evd.fresh_global env sigma gr else - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in - let u = EInstance.kind (Tacmach.New.project gl) u in + let u = EInstance.kind sigma u in if dep then let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in @@ -4115,8 +4115,8 @@ let guess_elim isrec dep s hyp0 gl = let ind = EConstr.of_constr ind in (sigma, ind) in - let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in - evd, ((elimc, NoBindings), elimt), mkIndU (mind, u) + let elimt = Typing.unsafe_type_of env sigma elimc in + sigma, ((elimc, NoBindings), elimt), mkIndU (mind, u) let given_elim hyp0 (elimc,lbind as e) gl = let sigma = Tacmach.New.project gl in @@ -4884,179 +4884,6 @@ let transitivity t = transitivity_gen (Some t) let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) -(* tactical to save as name a subproof such that the generalisation of - the current goal, abstracted with respect to the local signature, - is solved by tac *) - -(** d1 is the section variable in the global context, d2 in the goal context *) -let interpretable_as_section_decl env evd d1 d2 = - let open Context.Named.Declaration in - let e_eq_constr_univs sigma c1 c2 = match eq_constr_universes env !sigma c1 c2 with - | None -> false - | Some cstr -> - try ignore (Evd.add_universe_constraints !sigma cstr); true - with UniversesDiffer -> false - in - match d2, d1 with - | LocalDef _, LocalAssum _ -> false - | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> - e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (NamedDecl.get_type d2) - -let rec decompose len c t accu = - let open Context.Rel.Declaration in - if len = 0 then (c, t, accu) - else match Constr.kind c, Constr.kind t with - | Lambda (na, u, c), Prod (_, _, t) -> - decompose (pred len) c t (LocalAssum (na, u) :: accu) - | LetIn (na, b, u, c), LetIn (_, _, _, t) -> - decompose (pred len) c t (LocalDef (na, b, u) :: accu) - | _ -> assert false - -let rec shrink ctx sign c t accu = - let open Constr in - let open CVars in - match ctx, sign with - | [], [] -> (c, t, accu) - | p :: ctx, decl :: sign -> - if noccurn 1 c && noccurn 1 t then - let c = subst1 mkProp c in - let t = subst1 mkProp t in - shrink ctx sign c t accu - else - let c = Term.mkLambda_or_LetIn p c in - let t = Term.mkProd_or_LetIn p t in - let accu = if RelDecl.is_local_assum p - then mkVar (NamedDecl.get_id decl) :: accu - else accu - in - shrink ctx sign c t accu -| _ -> assert false - -let shrink_entry sign const = - let open Entries in - let typ = match const.const_entry_type with - | None -> assert false - | Some t -> t - in - (** The body has been forced by the call to [build_constant_by_tactic] *) - let () = assert (Future.is_over const.const_entry_body) in - let ((body, uctx), eff) = Future.force const.const_entry_body in - let (body, typ, ctx) = decompose (List.length sign) body typ [] in - let (body, typ, args) = shrink ctx sign body typ [] in - let const = { const with - const_entry_body = Future.from_val ((body, uctx), eff); - const_entry_type = Some typ; - } in - (const, args) - -let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = - let open Tacticals.New in - let open Tacmach.New in - let open Proofview.Notations in - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let current_sign = Global.named_context_val () - and global_sign = Proofview.Goal.hyps gl in - let evdref = ref sigma in - let sign,secsign = - List.fold_right - (fun d (s1,s2) -> - let id = NamedDecl.get_id d in - if mem_named_context_val id current_sign && - interpretable_as_section_decl env evdref (lookup_named_val id current_sign) d - then (s1,push_named_context_val d s2) - else (Context.Named.add d s1,s2)) - global_sign (Context.Named.empty, empty_named_context_val) in - let id = next_global_ident_away id (pf_ids_set_of_hyps gl) in - let concl = match goal_type with - | None -> Proofview.Goal.concl gl - | Some ty -> ty in - let concl = it_mkNamedProd_or_LetIn concl sign in - let concl = - try flush_and_check_evars !evdref concl - with Uninstantiated_evar _ -> - error "\"abstract\" cannot handle existentials." in - - let evd, ctx, concl = - (* FIXME: should be done only if the tactic succeeds *) - let evd = Evd.minimize_universes !evdref in - let ctx = Evd.universe_context_set evd in - evd, ctx, Evarutil.nf_evars_universes evd concl - in - let concl = EConstr.of_constr concl in - let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in - let ectx = Evd.evar_universe_context evd in - let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac - with Logic_monad.TacticFailure e as src -> - (* if the tactic [tac] fails, it reports a [TacticFailure e], - which is an error irrelevant to the proof system (in fact it - means that [e] comes from [tac] failing to yield enough - success). Hence it reraises [e]. *) - let (_, info) = CErrors.push src in - iraise (e, info) - in - let const, args = shrink_entry sign const in - let args = List.map EConstr.of_constr args in - let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in - let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in - let cst () = - (** do not compute the implicit arguments, it may be costly *) - let () = Impargs.make_implicit_args false in - (** ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl - in - let cst = Impargs.with_implicit_protection cst () in - let inst = match const.Entries.const_entry_universes with - | Entries.Monomorphic_const_entry _ -> EInstance.empty - | Entries.Polymorphic_const_entry ctx -> - (** We mimick what the kernel does, that is ensuring that no additional - constraints appear in the body of polymorphic constants. Ideally this - should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in - let () = assert (Univ.ContextSet.is_empty body_uctx) in - EInstance.make (Univ.UContext.instance ctx) - in - let lem = mkConstU (cst, inst) in - let evd = Evd.set_universe_context evd ectx in - let open Safe_typing in - let eff = private_con_of_con (Global.safe_env ()) cst in - let effs = concat_private eff - Entries.(snd (Future.force const.const_entry_body)) in - let solve = - Proofview.tclEFFECTS effs <*> - tacK lem args - in - let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac - end - -let abstract_subproof ~opaque id gk tac = - cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> exact_no_check (applist (lem, args))) - -let anon_id = Id.of_string "anonymous" - -let name_op_to_name name_op object_kind suffix = - let open Proof_global in - let default_gk = (Global, false, object_kind) in - let name, gk = match Proof_global.V82.get_current_initial_conclusions () with - | (id, (_, gk)) -> Some id, gk - | exception NoCurrentProof -> None, default_gk - in - match name_op with - | Some s -> s, gk - | None -> - let name = Option.default anon_id name in - add_suffix name suffix, gk - -let tclABSTRACT ?(opaque=true) name_op tac = - let s, gk = if opaque - then name_op_to_name name_op (Proof Theorem) "_subproof" - else name_op_to_name name_op (DefinitionBody Definition) "_subterm" in - abstract_subproof ~opaque s gk tac - let constr_eq ~strict x y = let fail = Tacticals.New.tclFAIL 0 (str "Not equal") in let fail_universes = Tacticals.New.tclFAIL 0 (str "Not equal (due to universes)") in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 24c12ffd82..7efadb2c28 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -418,10 +418,6 @@ val constr_eq : strict:bool -> constr -> constr -> unit Proofview.tactic val unify : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic -val cache_term_by_tactic_then : opaque:bool -> ?goal_type:(constr option) -> Id.t -> Decl_kinds.goal_kind -> unit Proofview.tactic -> (constr -> constr list -> unit Proofview.tactic) -> unit Proofview.tactic - -val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic - val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic val specialize_eqs : Id.t -> unit Proofview.tactic diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index f54ad86a3f..5afec74fae 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -7,6 +7,7 @@ Ind_tables Eqschemes Elimschemes Tactics +Abstract Elim Equality Contradiction diff --git a/test-suite/bugs/closed/bug_3468.v b/test-suite/bugs/closed/bug_3468.v new file mode 100644 index 0000000000..6ff394bca6 --- /dev/null +++ b/test-suite/bugs/closed/bug_3468.v @@ -0,0 +1,29 @@ +(* Checking that unrelated terms requiring some scope do not affect + the interpretation of tactic-in-term. The "Check" was failing with: + The term "Set" has type "Type" while it is expected to have type + "nat". *) + +Notation bar2 a b := (let __ := ltac:(exact I) in (a + b)%type) (only parsing). +Check bar2 (Set + Set) Set. + +(* Taking into account scopes in notations containing tactic-in-term *) + +Declare Scope foo_scope. +Delimit Scope foo_scope with foo. +Notation "x ~~" := (x) (at level 0, only parsing) : foo_scope. +Notation bar x := (x%foo) (only parsing). +Notation baz x := ltac:(exact x%foo) (only parsing). +Check bar (O ~~). +Check baz (O ~~). (* Was failing *) + +(* This was reported as bug #8706 *) + +Declare Scope my_scope. +Notation "@ a" := a%nat (at level 100, only parsing) : my_scope. +Delimit Scope my_scope with my. + +Notation "& b" := ltac:(exact (b)%my) (at level 100, only parsing): my_scope. +Definition test := (& (@4))%my. + +(* Check inconsistent scopes *) +Fail Notation bar3 a := (let __ := ltac:(exact a%nat) in a%bool) (only parsing). diff --git a/test-suite/bugs/closed/bug_8755.v b/test-suite/bugs/closed/bug_8755.v new file mode 100644 index 0000000000..cd5aee4fa0 --- /dev/null +++ b/test-suite/bugs/closed/bug_8755.v @@ -0,0 +1,6 @@ + +Lemma f : Type. +Fail let i := ident:(i) in +let t := context i [Type] in +idtac. +Abort. diff --git a/test-suite/bugs/closed/bug_8848.v b/test-suite/bugs/closed/bug_8848.v new file mode 100644 index 0000000000..26563e6747 --- /dev/null +++ b/test-suite/bugs/closed/bug_8848.v @@ -0,0 +1,18 @@ +Require Import Program. +Set Implicit Arguments. +Unset Strict Implicit. + +Definition def (a : nat) := a = a. + +Structure record {a : nat} {D : def a} := + inR { prop : Prop }. + +Program +Canonical Structure ins (a : nat) (rec : @record a _) := + @inR a _ (prop rec). +Next Obligation. + exact eq_refl. +Defined. +Next Obligation. + exact eq_refl. +Defined. diff --git a/test-suite/coq-makefile/native1/_CoqProject b/test-suite/coq-makefile/native1/_CoqProject index 847b2c00a9..3dfca7ffc0 100644 --- a/test-suite/coq-makefile/native1/_CoqProject +++ b/test-suite/coq-makefile/native1/_CoqProject @@ -2,6 +2,7 @@ -R theories test -I src -arg -native-compiler +-arg yes src/test_plugin.mlpack src/test.mlg diff --git a/test-suite/coqchk/bug_8655.v b/test-suite/coqchk/bug_8655.v new file mode 100644 index 0000000000..06d08b2082 --- /dev/null +++ b/test-suite/coqchk/bug_8655.v @@ -0,0 +1 @@ +Inductive IND2 (A:Type) (T:=fun _ : Type->Type => A) := CONS2 : IND2 A -> IND2 (T IND2). diff --git a/test-suite/coqchk/bug_8876.v b/test-suite/coqchk/bug_8876.v new file mode 100644 index 0000000000..2d20511a04 --- /dev/null +++ b/test-suite/coqchk/bug_8876.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) +Require Import Coq.Init.Notations. + +Notation "x -> y" := (forall _ : x, y). + +Inductive eq {A:Type} (a:A) : A -> Prop := eq_refl : eq a a. + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. +Set Printing Universes. + +(* Constructors for an inductive with indices *) +Module WithIndex. + Inductive foo@{i} : (Prop -> Prop) -> Prop := mkfoo: foo (fun x => x). + + Monomorphic Universes i j. + Monomorphic Constraint i < j. + Definition bar : eq mkfoo@{i} mkfoo@{j} := eq_refl _. +End WithIndex. diff --git a/test-suite/coqchk/bug_8881.v b/test-suite/coqchk/bug_8881.v new file mode 100644 index 0000000000..dfc209b318 --- /dev/null +++ b/test-suite/coqchk/bug_8881.v @@ -0,0 +1,23 @@ + +(* Check use of equivalence on inductive types (bug #1242) *) + +Module Type ASIG. + Inductive t : Set := a | b : t. + Definition f := fun x => match x with a => true | b => false end. +End ASIG. + +Module Type BSIG. + Declare Module A : ASIG. + Definition f := fun x => match x with A.a => true | A.b => false end. +End BSIG. + +Module C (A : ASIG) (B : BSIG with Module A:=A). + + (* Check equivalence is considered in "case_info" *) + Lemma test : forall x, A.f x = B.f x. + Proof. + intro x. unfold B.f, A.f. + destruct x; reflexivity. + Qed. + +End C. diff --git a/test-suite/misc/poly-capture-global-univs/.gitignore b/test-suite/misc/poly-capture-global-univs/.gitignore index f5a6d22b8e..2a6a6bc68d 100644 --- a/test-suite/misc/poly-capture-global-univs/.gitignore +++ b/test-suite/misc/poly-capture-global-univs/.gitignore @@ -1 +1,2 @@ /Makefile* +/src/evil.ml diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index d587d1f09b..7074ad2d41 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,11 +1,13 @@ Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub but avoid exposing match constructs Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when applied to 1 argument but avoid exposing match constructs @@ -13,6 +15,7 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st argument evaluates to a constructor and @@ -21,6 +24,7 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor and when applied to 2 arguments @@ -28,6 +32,7 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor @@ -37,6 +42,7 @@ pf : forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 +pf is not universe polymorphic Arguments D2, C2 are implicit Arguments D1, C1 are implicit and maximally inserted Argument scopes are [foo_scope type_scope _ _ _ _ _] @@ -45,6 +51,7 @@ pf is transparent Expands to: Constant Arguments.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C +fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] The reduction tactics unfold fcomp when applied to 6 arguments @@ -52,17 +59,20 @@ fcomp is transparent Expands to: Constant Arguments.fcomp volatile : nat -> nat +volatile is not universe polymorphic Argument scope is [nat_scope] The reduction tactics always unfold volatile volatile is transparent Expands to: Constant Arguments.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] f is transparent Expands to: Constant Arguments.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 3rd, 4th and 5th arguments evaluate to a constructor @@ -70,6 +80,7 @@ f is transparent Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 4th, 5th and @@ -78,6 +89,7 @@ f is transparent Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 5th, 6th and @@ -90,6 +102,7 @@ Expands to: Constant Arguments.f : Prop f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic The reduction tactics unfold f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out index febe160820..69ba329ff1 100644 --- a/test-suite/output/ArgumentsScope.out +++ b/test-suite/output/ArgumentsScope.out @@ -1,56 +1,70 @@ a : bool -> bool +a is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable a b : bool -> bool +b is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable b negb'' : bool -> bool +negb'' is not universe polymorphic Argument scope is [bool_scope] negb'' is transparent Expands to: Constant ArgumentsScope.A.B.negb'' negb' : bool -> bool +negb' is not universe polymorphic Argument scope is [bool_scope] negb' is transparent Expands to: Constant ArgumentsScope.A.negb' negb : bool -> bool +negb is not universe polymorphic Argument scope is [bool_scope] negb is transparent Expands to: Constant Coq.Init.Datatypes.negb a : bool -> bool +a is not universe polymorphic Expands to: Variable a b : bool -> bool +b is not universe polymorphic Expands to: Variable b negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant ArgumentsScope.A.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant ArgumentsScope.A.B.negb'' a : bool -> bool +a is not universe polymorphic Expands to: Variable a negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant ArgumentsScope.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant ArgumentsScope.negb'' diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 1755886967..b071da86c9 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -11,7 +11,7 @@ eq_refl : ?y = ?y where ?y : [ |- nat] -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq_refl: Arguments are renamed to B, y For eq: Argument A is implicit and maximally inserted @@ -23,6 +23,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic Arguments are renamed to B, y When applied to no arguments: Arguments B, y are implicit and maximally inserted @@ -30,7 +31,8 @@ When applied to 1 argument: Argument B is implicit Argument scopes are [type_scope _] Expands to: Constructor Coq.Init.Logic.eq_refl -Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x +Monomorphic Inductive myEq (B : Type) (x : A) : A -> Prop := + myrefl : B -> myEq B x x For myrefl: Arguments are renamed to C, x, _ For myrefl: Argument C is implicit and maximally inserted @@ -38,11 +40,12 @@ For myEq: Argument scopes are [type_scope _ _] For myrefl: Argument scopes are [type_scope _ _] myrefl : forall (B : Type) (x : A), B -> myEq B x x +myrefl is not universe polymorphic Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] Expands to: Constructor Arguments_renaming.Test1.myrefl -myplus = +Monomorphic myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m @@ -50,11 +53,13 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] @@ -64,7 +69,7 @@ myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat -Inductive myEq (A B : Type) (x : A) : A -> Prop := +Monomorphic Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x For myrefl: Arguments are renamed to A, C, x, _ @@ -73,13 +78,14 @@ For myEq: Argument scopes are [type_scope type_scope _ _] For myrefl: Argument scopes are [type_scope type_scope _ _] myrefl : forall (A B : Type) (x : A), B -> myEq A B x x +myrefl is not universe polymorphic Arguments are renamed to A, C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope type_scope _ _] Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x -myplus = +Monomorphic myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m @@ -87,11 +93,13 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] diff --git a/test-suite/output/Binder.out b/test-suite/output/Binder.out index 34558e9a6b..9c46ace463 100644 --- a/test-suite/output/Binder.out +++ b/test-suite/output/Binder.out @@ -1,8 +1,12 @@ -foo = fun '(x, y) => x + y +Monomorphic foo = fun '(x, y) => x + y : nat * nat -> nat + +foo is not universe polymorphic forall '(a, b), a /\ b : Prop -foo = λ '(x, y), x + y +Monomorphic foo = λ '(x, y), x + y : nat * nat → nat + +foo is not universe polymorphic ∀ '(a, b), a ∧ b : Prop diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index cb835ab48d..0a02c5a7dd 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -1,4 +1,4 @@ -t_rect = +Monomorphic t_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with @@ -7,6 +7,7 @@ fix F (t : t) : P t := : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t +t_rect is not universe polymorphic Argument scopes are [function_scope function_scope _] = fun d : TT => match d with | {| f3 := b |} => b @@ -16,7 +17,7 @@ Argument scopes are [function_scope function_scope _] | {| f3 := b |} => b end : TT -> 0 = 0 -proj = +Monomorphic proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => match Nat.eq_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with @@ -26,8 +27,9 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y +proj is not universe polymorphic Argument scopes are [nat_scope nat_scope function_scope _ _] -foo = +Monomorphic foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with | nil => None @@ -36,17 +38,21 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A +foo is not universe polymorphic Argument scopes are [type_scope list_scope] -uncast = +Monomorphic uncast = fun (A : Type) (x : I A) => match x with | x0 <: _ => x0 end : forall A : Type, I A -> A +uncast is not universe polymorphic Argument scopes are [type_scope _] -foo' = if A 0 then true else false +Monomorphic foo' = if A 0 then true else false : bool -f = + +foo' is not universe polymorphic +Monomorphic f = fun H : B => match H with | AC x => @@ -56,6 +62,8 @@ match H with else fun _ : P false => Logic.I) x end : B -> True + +f is not universe polymorphic The command has indeed failed with message: Non exhaustive pattern-matching: no clause found for pattern gadtTy _ _ @@ -75,17 +83,22 @@ fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: The constructor D (in type J) expects 3 arguments. -lem1 = +Monomorphic lem1 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k -lem2 = + +lem1 is not universe polymorphic +Monomorphic lem2 = fun dd : bool => if dd as aa return (aa = aa) then eq_refl else eq_refl : forall k : bool, k = k +lem2 is not universe polymorphic Argument scope is [bool_scope] -lem3 = +Monomorphic lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k + +lem3 is not universe polymorphic 1 subgoal x : nat diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 3b65003c29..71c7070f2b 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -2,9 +2,11 @@ compose (C:=nat) S : (nat -> nat) -> nat -> nat ex_intro (P:=fun _ : nat => True) (x:=0) I : ex (fun _ : nat => True) -d2 = fun x : nat => d1 (y:=x) +Monomorphic d2 = +fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x +d2 is not universe polymorphic Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index af202ea01c..6d65db9e22 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,7 +1,8 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in "A -> list' A -> list' (A * A)%type". -Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x +Monomorphic Inductive foo (A : Type) (x : A) (y : A := x) : Prop := + Foo : foo A x For foo: Argument scopes are [type_scope _] For Foo: Argument scopes are [type_scope _] diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index c17c63e724..4743fb0d0a 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,4 +1,4 @@ -Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := +Monomorphic Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} For sig2: Argument A is implicit diff --git a/test-suite/output/Load.out b/test-suite/output/Load.out index 0904d5540b..f84cedfa62 100644 --- a/test-suite/output/Load.out +++ b/test-suite/output/Load.out @@ -1,6 +1,10 @@ -f = 2 +Monomorphic f = 2 : nat -u = I + +f is not universe polymorphic +Monomorphic u = I : True + +u is not universe polymorphic The command has indeed failed with message: Files processed by Load cannot leave open proofs. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index d32cf67e28..48379f713d 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -223,13 +223,14 @@ fun S : nat => [[S | S.S]] : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop -foo = +Monomorphic foo = fun l : list nat => match l with | _ :: (_ :: _) as l1 => l1 | _ => l end : list nat -> list nat +foo is not universe polymorphic Argument scope is [list_scope] Notation "'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..) : type_scope diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index cef7d1a702..46784d1897 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -1,5 +1,7 @@ [< 0 > + < 1 > * < 2 >] : nat +[< b > + < b > * < 2 >] + : nat [<< # 0 >>] : option nat [1 {f 1}] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 9738ce5a5e..6bdbf1bed5 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -10,6 +10,10 @@ Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). Check [ < 0 > + < 1 > * < 2 >]. +Axiom a : nat. +Notation b := a. +Check [ < b > + < a > * < 2 >]. + Declare Custom Entry anotherconstr. Notation "[ x ]" := x (x custom myconstr at level 6). diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 8a6d94c732..bfeff20524 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -1,20 +1,31 @@ -swap = fun '(x, y) => (y, x) +Monomorphic swap = fun '(x, y) => (y, x) : A * B -> B * A + +swap is not universe polymorphic fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -proj_informative = fun '(exist _ x _) => x : A +Monomorphic proj_informative = +fun '(exist _ x _) => x : A : {x : A | P x} -> A -foo = fun '(Bar n b tt p) => if b then n + p else n - p + +proj_informative is not universe polymorphic +Monomorphic foo = +fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat -baz = + +foo is not universe polymorphic +Monomorphic baz = fun '(Bar n1 _ tt p1) '(Bar _ _ tt _) => n1 + p1 : Foo -> Foo -> nat -swap = + +baz is not universe polymorphic +Monomorphic swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A +swap is not universe polymorphic Arguments A, B are implicit and maximally inserted Argument scopes are [type_scope type_scope _] fun (A B : Type) '(x, y) => swap (x, y) = (y, x) @@ -29,19 +40,22 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) : A * B → B * A ∀ '(x, y), swap (x, y) = (y, x) : Prop -both_z = +Monomorphic both_z = fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) : forall pat : nat * nat, F pat + +both_z is not universe polymorphic fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop forall '(x, y) '(z, t), swap (x, y) = (z, t) : Prop fun (pat : nat) '(x, y) => x + y = pat : nat -> nat * nat -> Prop -f = fun x : nat => x + x +Monomorphic f = fun x : nat => x + x : nat -> nat +f is not universe polymorphic Argument scope is [nat_scope] fun x : nat => x + x : nat -> nat diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 38a16e01c2..be793dd453 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -4,7 +4,7 @@ existT is template universe polymorphic Argument A is implicit Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT -Inductive sigT (A : Type) (P : A -> Type) : Type := +Monomorphic Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} For sigT: Argument A is implicit @@ -14,7 +14,7 @@ For existT: Argument scopes are [type_scope function_scope _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: @@ -25,6 +25,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: @@ -37,7 +38,7 @@ When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit -Nat.add = +Monomorphic Nat.add = fix add (n m : nat) {struct n} : nat := match n with | 0 => m @@ -45,9 +46,11 @@ fix add (n m : nat) {struct n} : nat := end : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] Nat.add : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] Nat.add is transparent Expands to: Constant Coq.Init.Nat.add @@ -55,10 +58,11 @@ Nat.add : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 +plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O -Inductive le (n : nat) : nat -> Prop := +Monomorphic Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m For le_S: Argument m is implicit @@ -68,18 +72,21 @@ For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] comparison : Set +comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison -Inductive comparison : Set := +Monomorphic Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison bar : foo +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Expands to: Constant PrintInfos.bar -*** [ bar : foo ] +Monomorphic *** [ bar : foo ] +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -87,7 +94,7 @@ Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index f94ed64234..f080f6d0f0 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,7 +1,15 @@ -TrM.A = M.A +Monomorphic TrM.A = M.A : Set -OpM.A = M.A + +TrM.A is not universe polymorphic +Monomorphic OpM.A = M.A : Set -TrM.B = M.B + +OpM.A is not universe polymorphic +Monomorphic TrM.B = M.B : Set -*** [ OpM.B : Set ] + +TrM.B is not universe polymorphic +Monomorphic *** [ OpM.B : Set ] + +OpM.B is not universe polymorphic diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index acc37f653c..49c292c501 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,34 +1,37 @@ -NonCumulative Inductive Empty@{u} : Type@{u} := -NonCumulative Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } +Polymorphic NonCumulative Inductive Empty@{u} : Type@{u} := +Polymorphic NonCumulative Record PWrap (A : Type@{u}) : Type@{u} := pwrap + { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] For pwrap: Argument scopes are [type_scope _] -punwrap@{u} = +Polymorphic punwrap@{u} = fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) punwrap is universe polymorphic Argument scopes are [type_scope _] -NonCumulative Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } +Polymorphic NonCumulative Record RWrap (A : Type@{u}) : Type@{u} := rwrap + { runwrap : A } For RWrap: Argument scope is [type_scope] For rwrap: Argument scopes are [type_scope _] -runwrap@{u} = +Polymorphic runwrap@{u} = fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap : forall A : Type@{u}, RWrap@{u} A -> A (* u |= *) runwrap is universe polymorphic Argument scopes are [type_scope _] -Wrap@{u} = fun A : Type@{u} => A +Polymorphic Wrap@{u} = +fun A : Type@{u} => A : Type@{u} -> Type@{u} (* u |= *) Wrap is universe polymorphic Argument scope is [type_scope] -wrap@{u} = +Polymorphic wrap@{u} = fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap : forall A : Type@{u}, Wrap@{u} A -> A (* u |= *) @@ -36,13 +39,13 @@ fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap wrap is universe polymorphic Arguments A, Wrap are implicit and maximally inserted Argument scopes are [type_scope _] -bar@{u} = nat +Polymorphic bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) bar is universe polymorphic -foo@{u UnivBinders.17 v} = +Polymorphic foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) @@ -75,25 +78,28 @@ mono : Type@{mono.u+1} The command has indeed failed with message: Universe u already exists. -bobmorane = +Monomorphic bobmorane = let tt := Type@{tt.v} in let ff := Type@{ff.v} in tt -> ff : Type@{max(tt.u,ff.u)} + +bobmorane is not universe polymorphic The command has indeed failed with message: Universe u already bound. -foo@{E M N} = +Polymorphic foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} : Type@{max(E+1,M+1,N+1)} (* E M N |= *) foo is universe polymorphic -foo@{u UnivBinders.17 v} = +Polymorphic foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) foo is universe polymorphic -NonCumulative Inductive Empty@{E} : Type@{E} := -NonCumulative Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } +Polymorphic NonCumulative Inductive Empty@{E} : Type@{E} := +Polymorphic NonCumulative Record PWrap (A : Type@{E}) : Type@{E} := pwrap + { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] @@ -119,45 +125,47 @@ Type@{bind_univs.mono.u} (* {bind_univs.mono.u} |= *) bind_univs.mono is not universe polymorphic -bind_univs.poly@{u} = Type@{u} +Polymorphic bind_univs.poly@{u} = Type@{u} : Type@{u+1} (* u |= *) bind_univs.poly is universe polymorphic -insec@{v} = Type@{u} -> Type@{v} +Polymorphic insec@{v} = +Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* v |= *) insec is universe polymorphic -NonCumulative Inductive insecind@{k} : Type@{k+1} := +Polymorphic NonCumulative Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} For inseccstr: Argument scope is [type_scope] -insec@{u v} = Type@{u} -> Type@{v} +Polymorphic insec@{u v} = +Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) insec is universe polymorphic -NonCumulative Inductive insecind@{u k} : Type@{k+1} := +Polymorphic NonCumulative Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} For inseccstr: Argument scope is [type_scope] -inmod@{u} = Type@{u} +Polymorphic inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) inmod is universe polymorphic -SomeMod.inmod@{u} = Type@{u} +Polymorphic SomeMod.inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) SomeMod.inmod is universe polymorphic -inmod@{u} = Type@{u} +Polymorphic inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) inmod is universe polymorphic -Applied.infunct@{u v} = +Polymorphic Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 773533a8d3..3dad2360c4 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -1,7 +1,11 @@ -Nat.t = nat +Monomorphic Nat.t = nat : Set -Nat.t = nat + +Nat.t is not universe polymorphic +Monomorphic Nat.t = nat : Set + +Nat.t is not universe polymorphic 1 subgoal ============================ diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f7ffd1959a..a1326596bb 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -1,9 +1,11 @@ -P = +Monomorphic P = fun e : option L => match e with | Some cl => Some cl | None => None end : option L -> option L + +P is not universe polymorphic fun n : nat => let y : T n := A n in ?t ?x : T n : forall n : nat, T n where diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index f07c0191f1..c2130995fc 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -1,7 +1,5 @@ (* Test des definitions inductives imbriquees *) -Require Import List. - Inductive X : Set := cons1 : list X -> X. diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v index 1c6e2d81d8..cfc25c3346 100644 --- a/test-suite/success/Template.v +++ b/test-suite/success/Template.v @@ -25,7 +25,7 @@ Module AutoNo. End AutoNo. Module Yes. - #[template] + #[universes(template)] Inductive Box@{i} (A:Type@{i}) : Type@{i} := box : A -> Box A. About Box. @@ -37,7 +37,7 @@ Module Yes. End Yes. Module No. - #[notemplate] + #[universes(notemplate)] Inductive Box (A:Type) : Type := box : A -> Box A. About Box. diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v index 7b972f4ed9..f4f59a3c16 100644 --- a/test-suite/success/attribute_syntax.v +++ b/test-suite/success/attribute_syntax.v @@ -11,7 +11,7 @@ End Scope. Fail Check 0 = true :> nat. -#[polymorphic] +#[universes(polymorphic)] Definition ι T (x: T) := x. Check ι _ ι. @@ -24,9 +24,9 @@ Reset f. Ltac foo := foo. Module M. - #[local] #[polymorphic] Definition zed := Type. + #[local] #[universes(polymorphic)] Definition zed := Type. - #[local, polymorphic] Definition kats := Type. + #[local, universes(polymorphic)] Definition kats := Type. End M. Check M.zed@{_}. Fail Check zed. diff --git a/test-suite/success/module_with_def_univ_poly.v b/test-suite/success/module_with_def_univ_poly.v new file mode 100644 index 0000000000..a547be4c46 --- /dev/null +++ b/test-suite/success/module_with_def_univ_poly.v @@ -0,0 +1,31 @@ + +(* When doing Module Foo with Definition bar := ..., bar must be + generated with the same polymorphism as Foo.bar. *) +Module Mono. + Unset Universe Polymorphism. + Module Type T. + Parameter foo : Type. + End T. + + Module Type F(A:T). End F. + + Set Universe Polymorphism. + Module M : T with Definition foo := Type. + Monomorphic Definition foo := Type. + End M. +End Mono. + +Module Poly. + Set Universe Polymorphism. + + Module Type T. + Parameter foo@{i|Set < i} : Type@{i}. + End T. + + Module Type F(A:T). End F. + + Unset Universe Polymorphism. + Module M : T with Definition foo := Set : Type. + Polymorphic Definition foo := Set : Type. + End M. +End Poly. diff --git a/tools/coqc.ml b/tools/coqc.ml index 2cbf05bd8b..ad845470ec 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -97,7 +97,7 @@ let parse_args () = |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-profile"|"-echo" |"-quiet" |"-silent"|"-m"|"-beautify"|"-strict-implicit" - |"-impredicative-set"|"-vm"|"-native-compiler" + |"-impredicative-set"|"-vm" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" |"-stm-debug" @@ -111,7 +111,7 @@ let parse_args () = |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o"|"-profile-ltac-cutoff"|"-mangle-names" + |"-o"|"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" as o) :: rem -> begin match rem with diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 9918adfed3..8c643a285e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s)) - let fatal_error exn = Topfmt.print_err_exn Topfmt.ParsingCommandLine exn; let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in @@ -66,6 +64,8 @@ type coq_cmdopts = { color : color; impredicative_set : Declarations.set_predicativity; + enable_VM : bool; + enable_native_compiler : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; @@ -116,6 +116,8 @@ let init_args = { color = `AUTO; impredicative_set = Declarations.PredicativeSet; + enable_VM = true; + enable_native_compiler = Coq_config.native_compiler; stm_flags = Stm.AsyncOpts.default_opts; debug = false; diffs_set = false; @@ -508,6 +510,26 @@ let parse_args arglist : coq_cmdopts * string list = |"-o" -> { oval with compilation_output_name = Some (next()) } + |"-bytecode-compiler" -> + { oval with enable_VM = get_bool opt (next ()) } + + |"-native-compiler" -> + + (* We use two boolean flags because the four states make sense, even if + only three are accessible to the user at the moment. The selection of the + produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by + a separate flag, and the "ondemand" value removed. Once this is done, use + [get_bool] here. *) + let (enable,precompile) = + match (next ()) with + | ("yes" | "on") -> true, true + | "ondemand" -> true, false + | ("no" | "off") -> false, false + | _ -> prerr_endline ("Error: (yes|no|ondemand) expected after option -native-compiler"); exit 1 + in + Flags.output_native_objects := precompile; + { oval with enable_native_compiler = enable } + (* Options with zero arg *) |"-async-queries-always-delegate" |"-async-proofs-always-delegate" @@ -542,10 +564,6 @@ let parse_args arglist : coq_cmdopts * string list = |"-m"|"--memory" -> { oval with memory_stat = true } |"-noinit"|"-nois" -> { oval with load_init = false } |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true } - |"-native-compiler" -> - if not Coq_config.native_compiler then - warning "Native compilation was disabled at configure time." - else Flags.output_native_objects := true; oval |"-output-context" -> { oval with output_context = true } |"-profile-ltac" -> Flags.profile_ltac := true; oval |"-q" -> { oval with load_rcfile = false; } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 7b0cdcf127..accb6c2beb 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -41,6 +41,8 @@ type coq_cmdopts = { color : color; impredicative_set : Declarations.set_predicativity; + enable_VM : bool; + enable_native_compiler : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8cd262c6d6..e4d9e9ac25 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -456,6 +456,8 @@ let init_toplevel custom_init arglist = Flags.if_verbose print_header (); Mltop.init_known_plugins (); Global.set_engagement opts.impredicative_set; + Global.set_VM opts.enable_VM; + Global.set_native_compiler opts.enable_native_compiler; (* Allow the user to load an arbitrary state here *) inputstate opts; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index d85fed5f43..c2437836f3 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -87,7 +87,8 @@ let print_usage_channel co command = \n (use environment variable\ \n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ \n for full Gc stats dump)\ -\n -native-compiler precompile files for the native_compute machinery\ +\n -bytecode-compiler (yes|no) controls the vm_compute machinery\ +\n -native-compiler (yes|no|ondemand) controls the native_compute machinery\ \n -h, -help, --help print this list of options\ \n"; List.iter (fun (name, text) -> diff --git a/vernac/attributes.ml b/vernac/attributes.ml new file mode 100644 index 0000000000..88638b295b --- /dev/null +++ b/vernac/attributes.ml @@ -0,0 +1,215 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Vernacexpr + +let unsupported_attributes = function + | [] -> () + | atts -> + let keys = List.map fst atts in + let keys = List.sort_uniq String.compare keys in + let conj = match keys with [_] -> "this attribute: " | _ -> "these attributes: " in + user_err Pp.(str "This command does not support " ++ str conj ++ prlist str keys ++ str".") + +type 'a key_parser = 'a option -> vernac_flag_value -> 'a + +type 'a attribute = vernac_flags -> vernac_flags * 'a + +let parse_with_extra (p:'a attribute) (atts:vernac_flags) : vernac_flags * 'a = + p atts + +let parse_drop_extra att atts = + snd (parse_with_extra att atts) + +let parse (p:'a attribute) atts : 'a = + let extra, v = parse_with_extra p atts in + unsupported_attributes extra; + v + +let make_attribute x = x + +module Notations = struct + + type 'a t = 'a attribute + + let return x = fun atts -> atts, x + + let (>>=) att f = + fun atts -> + let atts, v = att atts in + f v atts + + let (>>) p1 p2 = + fun atts -> + let atts, () = p1 atts in + p2 atts + + let map f att = + fun atts -> + let atts, v = att atts in + atts, f v + + let (++) (p1:'a attribute) (p2:'b attribute) : ('a*'b) attribute = + fun atts -> + let atts, v1 = p1 atts in + let atts, v2 = p2 atts in + atts, (v1, v2) + +end +open Notations + +type deprecation = { since : string option ; note : string option } + +let mk_deprecation ?(since=None) ?(note=None) () = + { since ; note } + +type t = { + locality : bool option; + polymorphic : bool; + template : bool option; + program : bool; + deprecated : deprecation option; +} + +let assert_empty k v = + if v <> VernacFlagEmpty + then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") + +let assert_once ~name prev = + if Option.has_some prev then + user_err Pp.(str "Attribute for " ++ str name ++ str " specified twice.") + +let attribute_of_list (l:(string * 'a key_parser) list) : 'a option attribute = + let rec p extra v = function + | [] -> List.rev extra, v + | (key, attv as att) :: rem -> + (match CList.assoc_f String.equal key l with + | exception Not_found -> p (att::extra) v rem + | parser -> + let v = Some (parser v attv) in + p extra v rem) + in + p [] None + +let single_key_parser ~name ~key v prev args = + assert_empty key args; + assert_once ~name prev; + v + +let bool_attribute ~name ~on ~off : bool option attribute = + attribute_of_list [(on, single_key_parser ~name ~key:on true); + (off, single_key_parser ~name ~key:off false)] + +let qualify_attribute qual (parser:'a attribute) : 'a attribute = + fun atts -> + let rec extract extra qualified = function + | [] -> List.rev extra, List.flatten (List.rev qualified) + | (key,attv) :: rem when String.equal key qual -> + (match attv with + | VernacFlagEmpty | VernacFlagLeaf _ -> + CErrors.user_err ~hdr:"qualified_attribute" + Pp.(str "Malformed attribute " ++ str qual ++ str ": attribute list expected.") + | VernacFlagList atts -> + extract extra (atts::qualified) rem) + | att :: rem -> extract (att::extra) qualified rem + in + let extra, qualified = extract [] [] atts in + let rem, v = parser qualified in + let extra = if rem = [] then extra else (qual, VernacFlagList rem) :: extra in + extra, v + +let program_opt = bool_attribute ~name:"Program mode" ~on:"program" ~off:"noprogram" + +let program = program_opt >>= function + | Some b -> return b + | None -> return (Flags.is_program_mode()) + +let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" + +let warn_unqualified_univ_attr = + CWarnings.create ~name:"unqualified-univ-attr" ~category:"deprecated" + (fun key -> Pp.(str "Attribute " ++ str key ++ + str " should be qualified as \"universes("++str key++str")\".")) + +let ukey = "universes" +let universe_transform ~warn_unqualified : unit attribute = + fun atts -> + let atts = List.map (fun (key,_ as att) -> + match key with + | "polymorphic" | "monomorphic" + | "template" | "notemplate" -> + if warn_unqualified then warn_unqualified_univ_attr key; + ukey, VernacFlagList [att] + | _ -> att) atts + in + atts, () + +let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] +let is_universe_polymorphism = + let b = ref false in + let _ = let open Goptions in + declare_bool_option + { optdepr = false; + optname = "universe polymorphism"; + optkey = universe_polymorphism_option_name; + optread = (fun () -> !b); + optwrite = ((:=) b) } + in + fun () -> !b + +let polymorphic_base = + bool_attribute ~name:"Polymorphism" ~on:"polymorphic" ~off:"monomorphic" >>= function + | Some b -> return b + | None -> return (is_universe_polymorphism()) + +let polymorphic_nowarn = + universe_transform ~warn_unqualified:false >> + qualify_attribute ukey polymorphic_base + +let universe_poly_template = + let template = bool_attribute ~name:"Template" ~on:"template" ~off:"notemplate" in + universe_transform ~warn_unqualified:true >> + qualify_attribute ukey (polymorphic_base ++ template) + +let polymorphic = + universe_transform ~warn_unqualified:true >> + qualify_attribute ukey polymorphic_base + +let deprecation_parser : deprecation key_parser = fun orig args -> + assert_once ~name:"deprecation" orig; + match args with + | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ] + | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] -> + let since = Some since and note = Some note in + mk_deprecation ~since ~note () + | VernacFlagList [ "since", VernacFlagLeaf since ] -> + let since = Some since in + mk_deprecation ~since () + | VernacFlagList [ "note", VernacFlagLeaf note ] -> + let note = Some note in + mk_deprecation ~note () + | _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute") + +let deprecation = attribute_of_list ["deprecated",deprecation_parser] + +let attributes_of_flags f = + let ((locality, deprecated), (polymorphic, template)), program = + parse (locality ++ deprecation ++ universe_poly_template ++ program) f + in + { polymorphic; program; locality; template; deprecated } + +let only_locality atts = parse locality atts + +let only_polymorphism atts = parse polymorphic atts + + +let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] +let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] diff --git a/vernac/attributes.mli b/vernac/attributes.mli new file mode 100644 index 0000000000..c81082d5ad --- /dev/null +++ b/vernac/attributes.mli @@ -0,0 +1,133 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Vernacexpr + +type +'a attribute +(** The type of attributes. When parsing attributes if an ['a + attribute] is present then an ['a] value will be produced. + In the most general case, an attribute transforms the raw flags + along with its value. *) + +val parse : 'a attribute -> vernac_flags -> 'a +(** Errors on unsupported attributes. *) + +val unsupported_attributes : vernac_flags -> unit +(** Errors if the list of flags is nonempty. *) + +module Notations : sig + (** Notations to combine attributes. *) + + include Monad.Def with type 'a t = 'a attribute + (** Attributes form a monad. [a1 >>= f] means [f] will be run on the + flags transformed by [a1] and using the value produced by [a1]. + The trivial attribute [return x] does no action on the flags. *) + + val (++) : 'a attribute -> 'b attribute -> ('a * 'b) attribute + (** Combine 2 attributes. If any keys are in common an error will be raised. *) + +end + +(** Definitions for some standard attributes. *) + +type deprecation = { since : string option ; note : string option } + +val mk_deprecation : ?since: string option -> ?note: string option -> unit -> deprecation + +val polymorphic : bool attribute +val program : bool attribute +val universe_poly_template : (bool * bool option) attribute +val locality : bool option attribute +val deprecation : deprecation option attribute + +val program_opt : bool option attribute +(** For internal use when messing with the global option. *) + +type t = { + locality : bool option; + polymorphic : bool; + template : bool option; + program : bool; + deprecated : deprecation option; +} +(** Some attributes gathered in a adhoc record. Will probably be + removed at some point. *) + +val attributes_of_flags : vernac_flags -> t +(** Parse the attributes supported by type [t]. Errors on other + attributes. Polymorphism and Program use the global flags as + default values. *) + +val only_locality : vernac_flags -> bool option +(** Parse attributes allowing only locality. *) + +val only_polymorphism : vernac_flags -> bool +(** Parse attributes allowing only polymorphism. + Uses the global flag for the default value. *) + +val parse_drop_extra : 'a attribute -> vernac_flags -> 'a +(** Ignores unsupported attributes. *) + +val parse_with_extra : 'a attribute -> vernac_flags -> vernac_flags * 'a +(** Returns unsupported attributes. *) + +(** * Defining attributes. *) + +type 'a key_parser = 'a option -> Vernacexpr.vernac_flag_value -> 'a +(** A parser for some key in an attribute. It is given a nonempty ['a + option] when the attribute is multiply set for some command. + + eg in [#[polymorphic] Monomorphic Definition foo := ...], when + parsing [Monomorphic] it will be given [Some true]. *) + +val attribute_of_list : (string * 'a key_parser) list -> 'a option attribute +(** Make an attribute from a list of key parsers together with their + associated key. *) + +val bool_attribute : name:string -> on:string -> off:string -> bool option attribute +(** Define boolean attribute [name] with value [true] when [on] is + provided and [false] when [off] is provided. The attribute may only + be set once for a command. *) + +val qualify_attribute : string -> 'a attribute -> 'a attribute +(** [qualified_attribute qual att] treats [#[qual(atts)]] like [att] + treats [atts]. *) + +(** Combinators to help define your own parsers. See the + implementation of [bool_attribute] for practical use. *) + +val assert_empty : string -> vernac_flag_value -> unit +(** [assert_empty key v] errors if [v] is not empty. [key] is used in + the error message as the name of the attribute. *) + +val assert_once : name:string -> 'a option -> unit +(** [assert_once ~name v] errors if [v] is not empty. [name] is used + in the error message as the name of the attribute. Used to ensure + that a given attribute is not reapeated. *) + +val single_key_parser : name:string -> key:string -> 'a -> 'a key_parser +(** [single_key_parser ~name ~key v] makes a parser for attribute + [name] giving the constant value [v] for key [key] taking no + arguments. [name] may only be given once. *) + +val make_attribute : (vernac_flags -> vernac_flags * 'a) -> 'a attribute +(** Make an attribute using the internal representation, thus with + access to the full power of attributes. Unstable. *) + +(** Compatibility values for parsing [Polymorphic]. *) +val vernac_polymorphic_flag : vernac_flag +val vernac_monomorphic_flag : vernac_flag + +(** For the stm, do not use! *) + +val polymorphic_nowarn : bool attribute +(** For internal use, avoid warning if not qualified as eg [universes(polymorphic)]. *) +val universe_polymorphism_option_name : string list +val is_universe_polymorphism : unit -> bool diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index cea8af3f05..fe8ef1f0e0 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -178,7 +178,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let sigma, h_e_term = Evarutil.new_evar env sigma ~src:(Loc.tag @@ Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Evar_kinds.Define false; - }) wf_proof in + }) wf_proof in + let sigma = Evd.set_obligation_evar sigma (fst (destEvar sigma h_e_term)) in sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |]) in let sigma, def = Typing.solve_evars env sigma def in diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index d7229d32fe..1d0a5ab0a3 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -112,8 +112,10 @@ GRAMMAR EXTEND Gram ] ; vernac_poly: - [ [ IDENT "Polymorphic"; v = vernac_aux -> { let (f, v) = v in (("polymorphic", VernacFlagEmpty) :: f, v) } - | IDENT "Monomorphic"; v = vernac_aux -> { let (f, v) = v in (("monomorphic", VernacFlagEmpty) :: f, v) } + [ [ IDENT "Polymorphic"; v = vernac_aux -> + { let (f, v) = v in (Attributes.vernac_polymorphic_flag :: f, v) } + | IDENT "Monomorphic"; v = vernac_aux -> + { let (f, v) = v in (Attributes.vernac_monomorphic_flag :: f, v) } | v = vernac_aux -> { v } ] ] ; diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ca77e03707..ad6ca3a84e 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -391,11 +391,10 @@ let explain_unexpected_type env sigma actual_type expected_type = str "where" ++ spc () ++ prexp ++ str " was expected." let explain_not_product env sigma c = - let c = EConstr.to_constr sigma c in - let pr = pr_lconstr_env env sigma c in + let pr = pr_econstr_env env sigma c in str "The type of this term is a product" ++ spc () ++ str "while it is expected to be" ++ - (if Constr.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + (if EConstr.isType sigma c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) @@ -769,7 +768,7 @@ let pr_constraints printenv env sigma evars cstrs = h 0 (pe ++ evs ++ pr_evar_constraints sigma cstrs) else let filter evk _ = Evar.Map.mem evk evars in - pr_evar_map_filter ~with_univs:false filter sigma + pr_evar_map_filter ~with_univs:false filter env sigma let explain_unsatisfiable_constraints env sigma constr comp = let (_, constraints) = Evd.extract_all_conv_pbs sigma in diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index d8cd429e6e..c1343fb592 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -101,13 +101,9 @@ let _ = (* Util *) -let define id internal ctx c t = +let define ~poly id internal sigma c t = let f = declare_constant ~internal in - let univs = - if Flags.is_universe_polymorphism () - then Polymorphic_const_entry (Evd.to_universe_context ctx) - else Monomorphic_const_entry (Evd.universe_context_set ctx) - in + let univs = Evd.const_univ_entry ~poly sigma in let kn = f id (DefinitionEntry { const_entry_body = c; @@ -396,11 +392,17 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma ~force_mutual lrecspec in + let poly = + (* NB: build_mutual_induction_scheme forces nonempty list of mutual inductives + (force_mutual is about the generated schemes) *) + let _,_,ind,_ = List.hd lnamedepindsort in + Global.is_polymorphic (IndRef ind) + in let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in + let cst = define ~poly fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -457,10 +459,10 @@ let mk_coq_prod sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.prod.typ let mk_coq_pair sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.prod.intro") let build_combined_scheme env schemes = - let evdref = ref (Evd.from_env env) in - let defs = List.map (fun cst -> - let evd, c = Evd.fresh_constant_instance env !evdref cst in - evdref := evd; (c, Typeops.type_of_constant_in env c)) schemes in + let sigma = Evd.from_env env in + let sigma, defs = List.fold_left_map (fun sigma cst -> + let sigma, c = Evd.fresh_constant_instance env sigma cst in + sigma, (c, Typeops.type_of_constant_in env c)) sigma schemes in let find_inductive ty = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in @@ -478,7 +480,7 @@ let build_combined_scheme env schemes = *) let inprop = let inprop (_,t) = - Retyping.get_sort_family_of env !evdref (EConstr.of_constr t) + Retyping.get_sort_family_of env sigma (EConstr.of_constr t) == Sorts.InProp in List.for_all inprop defs @@ -489,10 +491,9 @@ let build_combined_scheme env schemes = else (mk_coq_prod, mk_coq_pair) in (* Number of clauses, including the predicates quantification *) - let prods = nb_prod !evdref (EConstr.of_constr t) - (nargs + 1) in - let sigma, coqand = mk_and !evdref in + let prods = nb_prod sigma (EConstr.of_constr t) - (nargs + 1) in + let sigma, coqand = mk_and sigma in let sigma, coqconj = mk_conj sigma in - let () = evdref := sigma in let relargs = rel_vect 0 prods in let concls = List.rev_map (fun (cst, t) -> @@ -501,15 +502,15 @@ let build_combined_scheme env schemes = let concl_bod, concl_typ = fold_left' (fun (accb, acct) (cst, x) -> - mkApp (EConstr.to_constr !evdref coqconj, [| x; acct; cst; accb |]), - mkApp (EConstr.to_constr !evdref coqand, [| x; acct |])) concls + mkApp (EConstr.to_constr sigma coqconj, [| x; acct; cst; accb |]), + mkApp (EConstr.to_constr sigma coqand, [| x; acct |])) concls in let ctx, _ = list_split_rev_at prods (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in let typ = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in - let sigma = Typing.check env !evdref (EConstr.of_constr body) (EConstr.of_constr typ) in + let sigma = Typing.check env sigma (EConstr.of_constr body) (EConstr.of_constr typ) in (sigma, body, typ) let do_combined_scheme name schemes = @@ -523,7 +524,14 @@ let do_combined_scheme name schemes = in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - ignore (define name.v UserIndividualRequest sigma proof_output (Some typ)); + (* It is possible for the constants to have different universe + polymorphism from each other, however that is only when the user + manually defined at least one of them (as Scheme would pick the + polymorphism of the inductive block). In that case if they want + some other polymorphism they can also manually define the + combined scheme. *) + let poly = Global.is_polymorphic (ConstRef (List.hd csts)) in + ignore (define ~poly name.v UserIndividualRequest sigma proof_output (Some typ)); fixpoint_message None [name.v] (**********************************************************************) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index fbf552e649..5c1384fba7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -37,13 +37,11 @@ let succfix (depth, fixrels) = let check_evars env evm = Evar.Map.iter - (fun key evi -> - let (loc,k) = evar_source key evm in - match k with - | Evar_kinds.QuestionMark _ - | Evar_kinds.ImplicitArg (_,_,false) -> () - | _ -> - Pretype_errors.error_unsolvable_implicit ?loc env evm key None) + (fun key evi -> + if Evd.is_obligation_evar evm key then () + else + let (loc,k) = evar_source key evm in + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) (Evd.undefined_map evm) type oblinfo = diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 356951b695..30fae756e9 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -1,4 +1,5 @@ Vernacexpr +Attributes Pvernac G_vernac G_proofs diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 1190d73258..74423d482e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -31,6 +31,7 @@ open Redexpr open Lemmas open Locality open Vernacinterp +open Attributes module NamedDecl = Context.Named.Declaration @@ -185,9 +186,10 @@ let print_modules () = let print_module qid = try + let open Nametab.GlobDirRef in let globdir = Nametab.locate_dir qid in match globdir with - DirModule { obj_dir; obj_mp; _ } -> + DirModule Nametab.{ obj_dir; obj_mp; _ } -> Printmod.print_module (Printmod.printable_body obj_dir) obj_mp | _ -> raise Not_found with @@ -409,44 +411,35 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension ~atts infix l = - let local = enforce_module_locality atts.locality in +let vernac_syntax_extension ~module_local infix l = if infix then Metasyntax.check_infix_modifiers (snd l); - Metasyntax.add_syntax_extension local l + Metasyntax.add_syntax_extension module_local l -let vernac_declare_scope ~atts sc = - let local = enforce_module_locality atts.locality in - Metasyntax.declare_scope local sc +let vernac_declare_scope ~module_local sc = + Metasyntax.declare_scope module_local sc -let vernac_delimiters ~atts sc action = - let local = enforce_module_locality atts.locality in +let vernac_delimiters ~module_local sc action = match action with - | Some lr -> Metasyntax.add_delimiters local sc lr - | None -> Metasyntax.remove_delimiters local sc + | Some lr -> Metasyntax.add_delimiters module_local sc lr + | None -> Metasyntax.remove_delimiters module_local sc -let vernac_bind_scope ~atts sc cll = - let local = enforce_module_locality atts.locality in - Metasyntax.add_class_scope local sc (List.map scope_class_of_qualid cll) +let vernac_bind_scope ~module_local sc cll = + Metasyntax.add_class_scope module_local sc (List.map scope_class_of_qualid cll) -let vernac_open_close_scope ~atts (b,s) = - let local = enforce_section_locality atts.locality in - Notation.open_close_scope (local,b,s) +let vernac_open_close_scope ~section_local (b,s) = + Notation.open_close_scope (section_local,b,s) -let vernac_arguments_scope ~atts r scl = - let local = make_section_locality atts.locality in - Notation.declare_arguments_scope local (smart_global r) scl +let vernac_arguments_scope ~section_local r scl = + Notation.declare_arguments_scope section_local (smart_global r) scl -let vernac_infix ~atts = - let local = enforce_module_locality atts.locality in - Metasyntax.add_infix local (Global.env()) +let vernac_infix ~module_local = + Metasyntax.add_infix module_local (Global.env()) -let vernac_notation ~atts = - let local = enforce_module_locality atts.locality in - Metasyntax.add_notation local (Global.env()) +let vernac_notation ~module_local = + Metasyntax.add_notation module_local (Global.env()) -let vernac_custom_entry ~atts s = - let local = enforce_module_locality atts.locality in - Metasyntax.declare_custom_entry local s +let vernac_custom_entry ~module_local s = + Metasyntax.declare_custom_entry module_local s (***********) (* Gallina *) @@ -488,6 +481,7 @@ let vernac_definition_hook p = function | _ -> no_hook let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = + let atts = attributes_of_flags atts in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in let () = @@ -518,6 +512,7 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) let vernac_start_proof ~atts kind l = + let atts = attributes_of_flags atts in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; @@ -535,6 +530,7 @@ let vernac_exact_proof c = if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = + let atts = attributes_of_flags atts in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in let kind = local, atts.polymorphic, kind in @@ -604,6 +600,7 @@ let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = indicates whether the type is inductive, co-inductive or neither. *) let vernac_inductive ~atts cum lo finite indl = + let atts = attributes_of_flags atts in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -699,6 +696,7 @@ let vernac_inductive ~atts cum lo finite indl = *) let vernac_fixpoint ~atts discharge l = + let atts = attributes_of_flags atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; @@ -711,6 +709,7 @@ let vernac_fixpoint ~atts discharge l = do_fixpoint local atts.polymorphic l let vernac_cofixpoint ~atts discharge l = + let atts = attributes_of_flags atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; @@ -737,19 +736,19 @@ let vernac_combined_scheme lid l = List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ AN (qualid_of_ident ?loc id))) l); Indschemes.do_combined_scheme lid l -let vernac_universe ~atts l = - if atts.polymorphic && not (Lib.sections_are_opened ()) then - user_err ?loc:atts.loc ~hdr:"vernac_universe" +let vernac_universe ~poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - Declare.do_universe atts.polymorphic l + Declare.do_universe poly l -let vernac_constraint ~atts l = - if atts.polymorphic && not (Lib.sections_are_opened ()) then - user_err ?loc:atts.loc ~hdr:"vernac_constraint" +let vernac_constraint ~poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - Declare.do_constraint atts.polymorphic l + Declare.do_constraint poly l (**********************) (* Modules *) @@ -933,32 +932,35 @@ let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) let vernac_coercion ~atts ref qids qidt = - let local = enforce_locality atts.locality in + let local, polymorphic = Attributes.(parse Notations.(locality ++ polymorphic) atts) in + let local = enforce_locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local atts.polymorphic ~source ~target; + Class.try_add_new_coercion_with_target ref' ~local polymorphic ~source ~target; Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion ~atts id qids qidt = - let local = enforce_locality atts.locality in + let local, polymorphic = Attributes.(parse Notations.(locality ++ polymorphic) atts) in + let local = enforce_locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local atts.polymorphic ~source ~target + Class.try_add_new_identity_coercion id ~local polymorphic ~source ~target (* Type classes *) let vernac_instance ~atts abst sup inst props pri = + let atts = attributes_of_flags atts in let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = Flags.is_program_mode () in ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri) -let vernac_context ~atts l = - if not (Classes.context atts.polymorphic l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~poly l = + if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom -let vernac_declare_instances ~atts insts = - let glob = not (make_section_locality atts.locality) in +let vernac_declare_instances ~section_local insts = + let glob = not section_local in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts let vernac_declare_class id = @@ -1029,8 +1031,8 @@ let vernac_add_ml_path isrec path = let open Mltop in add_coq_path { recursive = isrec; path_spec = MlPath (expand path) } -let vernac_declare_ml_module ~atts l = - let local = make_locality atts.locality in +let vernac_declare_ml_module ~local l = + let local = Option.default false local in Mltop.declare_ml_modules local (List.map expand l) let vernac_chdir = function @@ -1062,30 +1064,27 @@ let vernac_restore_state file = (************) (* Commands *) -let vernac_create_hintdb ~atts id b = - let local = make_module_locality atts.locality in - Hints.create_hint_db local id full_transparent_state b +let vernac_create_hintdb ~module_local id b = + Hints.create_hint_db module_local id full_transparent_state b -let vernac_remove_hints ~atts dbs ids = - let local = make_module_locality atts.locality in - Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) +let vernac_remove_hints ~module_local dbs ids = + Hints.remove_hints module_local dbs (List.map Smartlocate.global_with_alias ids) let vernac_hints ~atts lb h = - let local = enforce_module_locality atts.locality in - Hints.add_hints ~local lb (Hints.interp_hints atts.polymorphic h) + let local, poly = Attributes.(parse Notations.(locality ++ polymorphic) atts) in + let local = enforce_module_locality local in + Hints.add_hints ~local lb (Hints.interp_hints poly h) -let vernac_syntactic_definition ~atts lid x y = +let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; - let local = enforce_module_locality atts.locality in - Metasyntax.add_syntactic_definition (Global.env()) lid.v x local y + Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y -let vernac_declare_implicits ~atts r l = - let local = make_section_locality atts.locality in +let vernac_declare_implicits ~section_local r l = match l with | [] -> - Impargs.declare_implicits local (smart_global r) + Impargs.declare_implicits section_local (smart_global r) | _::_ as imps -> - Impargs.declare_manual_implicits local (smart_global r) ~enriching:false + Impargs.declare_manual_implicits section_local (smart_global r) ~enriching:false (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) let warn_arguments_assert = @@ -1100,7 +1099,7 @@ let warn_arguments_assert = (* [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 ~atts reference args more_implicits nargs_for_red flags = +let vernac_arguments ~section_local reference args more_implicits nargs_for_red flags = let env = Global.env () in let sigma = Evd.from_env env in let assert_flag = List.mem `Assert flags in @@ -1311,8 +1310,7 @@ let vernac_arguments ~atts reference args more_implicits nargs_for_red flags = (* Actions *) if renaming_specified then begin - let local = make_section_locality atts.locality in - Arguments_renaming.rename_arguments local sr names + Arguments_renaming.rename_arguments section_local sr names end; if scopes_specified || clear_scopes_flag then begin @@ -1321,20 +1319,20 @@ let vernac_arguments ~atts reference args more_implicits nargs_for_red flags = with UserError _ -> Notation.find_delimiters_scope ?loc k)) scopes in - vernac_arguments_scope ~atts reference scopes + vernac_arguments_scope ~section_local reference scopes end; if implicits_specified || clear_implicits_flag then - vernac_declare_implicits ~atts reference implicits; + vernac_declare_implicits ~section_local reference implicits; if default_implicits_flag then - vernac_declare_implicits ~atts reference []; + vernac_declare_implicits ~section_local reference []; if red_modifiers_specified then begin match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - (make_section_locality atts.locality) c + section_local c (rargs, Option.default ~-1 nargs_for_red, red_flags) | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ @@ -1362,8 +1360,8 @@ let vernac_reserve bl = Reserve.declare_reserved_type idl t) in List.iter sb_decl bl -let vernac_generalizable ~atts = - let local = make_non_locality atts.locality in +let vernac_generalizable ~local = + let local = Option.default true local in Implicit_quantifiers.declare_generalizable ~local let _ = @@ -1494,16 +1492,6 @@ let _ = optread = (fun () -> !Flags.program_mode); optwrite = (fun b -> Flags.program_mode:=b) } -let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] - -let _ = - declare_bool_option - { optdepr = false; - optname = "universe polymorphism"; - optkey = universe_polymorphism_option_name; - optread = Flags.is_universe_polymorphism; - optwrite = Flags.make_universe_polymorphism } - let _ = declare_bool_option { optdepr = false; @@ -1536,7 +1524,7 @@ let _ = optname = "kernel term sharing"; optkey = ["Kernel"; "Term"; "Sharing"]; optread = (fun () -> (Global.typing_flags ()).Declarations.share_reduction); - optwrite = (fun b -> Global.set_reduction_sharing b) } + optwrite = Global.set_share_reduction } let _ = declare_bool_option @@ -1618,8 +1606,8 @@ let _ = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } -let vernac_set_strategy ~atts l = - let local = make_locality atts.locality in +let vernac_set_strategy ~local l = + let local = Option.default false local in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1629,8 +1617,8 @@ let vernac_set_strategy ~atts l = let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in Redexpr.set_strategy local l -let vernac_set_opacity ~atts (v,l) = - let local = make_non_locality atts.locality in +let vernac_set_opacity ~local (v,l) = + let local = Option.default true local in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1649,8 +1637,8 @@ let get_option_locality export local = | Some false -> OptGlobal | None -> OptDefault -let vernac_set_option0 ~atts export key opt = - let locality = get_option_locality export atts.locality in +let vernac_set_option0 ~local export key opt = + let locality = get_option_locality export local in match opt with | StringValue s -> set_string_option_value_gen ~locality key s | StringOptValue (Some s) -> set_string_option_value_gen ~locality key s @@ -1658,26 +1646,26 @@ let vernac_set_option0 ~atts export key opt = | IntValue n -> set_int_option_value_gen ~locality key n | BoolValue b -> set_bool_option_value_gen ~locality key b -let vernac_set_append_option ~atts export key s = - let locality = get_option_locality export atts.locality in +let vernac_set_append_option ~local export key s = + let locality = get_option_locality export local in set_string_option_append_value_gen ~locality key s -let vernac_set_option ~atts export table v = match v with +let vernac_set_option ~local export table v = match v with | StringValue s -> (* We make a special case for warnings because appending is their natural semantics *) if CString.List.equal table ["Warnings"] then - vernac_set_append_option ~atts export table s + vernac_set_append_option ~local export table s else let (last, prefix) = List.sep_last table in if String.equal last "Append" && not (List.is_empty prefix) then - vernac_set_append_option ~atts export prefix s + vernac_set_append_option ~local export prefix s else - vernac_set_option0 ~atts export table v -| _ -> vernac_set_option0 ~atts export table v + vernac_set_option0 ~local export table v +| _ -> vernac_set_option0 ~local export table v -let vernac_unset_option ~atts export key = - let locality = get_option_locality export atts.locality in +let vernac_unset_option ~local export key = + let locality = get_option_locality export local in unset_option_value_gen ~locality key let vernac_add_option key lv = @@ -1720,7 +1708,7 @@ let query_command_selector ?loc = function (str "Query commands only support the single numbered goal selector.") let vernac_check_may_eval ~atts redexp glopt rc = - let glopt = query_command_selector ?loc:atts.loc glopt in + let glopt = query_command_selector glopt in let (sigma, env) = get_current_context_of_args glopt in let sigma, c = interp_open_constr env sigma rc in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in @@ -1754,8 +1742,8 @@ let vernac_check_may_eval ~atts redexp glopt rc = in pp ++ Printer.pr_universe_ctx_set sigma uctx -let vernac_declare_reduction ~atts s r = - let local = make_locality atts.locality in +let vernac_declare_reduction ~local s r = + let local = Option.default false local in let env = Global.env () in let sigma = Evd.from_env env in declare_red_expr local s (snd (Hook.get f_interp_redexp env sigma r)) @@ -1814,7 +1802,6 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = print_about env sigma ref_or_by_not udecl let vernac_print ~atts env sigma = - let loc = atts.loc in function | PrintTables -> print_tables () | PrintFullContext-> print_full_context_typ env sigma @@ -1862,7 +1849,7 @@ let vernac_print ~atts env sigma = | PrintVisibility s -> Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> - print_about_hyp_globs ?loc ref_or_by_not udecl glnumopt + print_about_hyp_globs ref_or_by_not udecl glnumopt | PrintImplicit qid -> dump_global qid; print_impargs qid @@ -1928,7 +1915,7 @@ let _ = optwrite = (:=) search_output_name_only } let vernac_search ~atts s gopt r = - let gopt = query_command_selector ?loc:atts.loc gopt in + let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> @@ -2104,12 +2091,25 @@ let vernac_load interp fname = if Proof_global.there_are_pending_proofs () then CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs.") +let with_locality ~atts f = + let local = Attributes.(parse locality atts) in + f ~local + +let with_section_locality ~atts f = + let local = Attributes.(parse locality atts) in + let section_local = make_section_locality local in + f ~section_local + +let with_module_locality ~atts f = + let local = Attributes.(parse locality atts) in + let module_local = make_module_locality local in + f ~module_local + (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) let interp ?proof ~atts ~st c = - let open Vernacinterp in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2133,54 +2133,54 @@ let interp ?proof ~atts ~st c = (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - vernac_syntax_extension ~atts infix sl - | VernacDeclareScope sc -> vernac_declare_scope ~atts sc - | VernacDelimiters (sc,lr) -> vernac_delimiters ~atts sc lr - | VernacBindScope (sc,rl) -> vernac_bind_scope ~atts sc rl - | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s) - | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc - | VernacNotation (c,infpl,sc) -> - vernac_notation ~atts c infpl sc + with_module_locality ~atts vernac_syntax_extension infix sl + | VernacDeclareScope sc -> with_module_locality ~atts vernac_declare_scope sc + | VernacDelimiters (sc,lr) -> with_module_locality ~atts vernac_delimiters sc lr + | VernacBindScope (sc,rl) -> with_module_locality ~atts vernac_bind_scope sc rl + | VernacOpenCloseScope (b, s) -> with_section_locality ~atts vernac_open_close_scope (b,s) + | VernacInfix (mv,qid,sc) -> with_module_locality ~atts vernac_infix mv qid sc + | VernacNotation (c,infpl,sc) -> with_module_locality ~atts vernac_notation c infpl sc | VernacNotationAddFormat(n,k,v) -> - Metasyntax.add_notation_extra_printing_rule n k v + unsupported_attributes atts; + Metasyntax.add_notation_extra_printing_rule n k v | VernacDeclareCustomEntry s -> - vernac_custom_entry ~atts s + with_module_locality ~atts vernac_custom_entry s (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> vernac_definition ~atts discharge kind lid d | VernacStartTheoremProof (k,l) -> vernac_start_proof ~atts k l - | VernacEndProof e -> vernac_end_proof ?proof e - | VernacExactProof c -> vernac_exact_proof c + | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof e + | VernacExactProof c -> unsupported_attributes atts; vernac_exact_proof c | VernacAssumption ((discharge,kind),nl,l) -> vernac_assumption ~atts discharge kind l nl | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l - | VernacScheme l -> vernac_scheme l - | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe ~atts l - | VernacConstraint l -> vernac_constraint ~atts l + | VernacScheme l -> unsupported_attributes atts; vernac_scheme l + | VernacCombinedScheme (id, l) -> unsupported_attributes atts; vernac_combined_scheme id l + | VernacUniverse l -> vernac_universe ~poly:(only_polymorphism atts) l + | VernacConstraint l -> vernac_constraint ~poly:(only_polymorphism atts) l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> - vernac_declare_module export lid bl mtyo + unsupported_attributes atts; vernac_declare_module export lid bl mtyo | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - vernac_define_module export lid bl mtys mexprl + unsupported_attributes atts; vernac_define_module export lid bl mtys mexprl | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - vernac_declare_module_type lid bl mtys mtyo + unsupported_attributes atts; vernac_declare_module_type lid bl mtys mtyo | VernacInclude in_asts -> - vernac_include in_asts + unsupported_attributes atts; vernac_include in_asts (* Gallina extensions *) - | VernacBeginSection lid -> vernac_begin_section lid + | VernacBeginSection lid -> unsupported_attributes atts; vernac_begin_section lid - | VernacEndSegment lid -> vernac_end_segment lid + | VernacEndSegment lid -> unsupported_attributes atts; vernac_end_segment lid - | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set + | VernacNameSectionHypSet (lid, set) -> unsupported_attributes atts; vernac_name_sec_hyp lid set - | VernacRequire (from, export, qidl) -> vernac_require from export qidl - | VernacImport (export,qidl) -> vernac_import export qidl - | VernacCanonical qid -> vernac_canonical qid + | VernacRequire (from, export, qidl) -> unsupported_attributes atts; vernac_require from export qidl + | VernacImport (export,qidl) -> unsupported_attributes atts; vernac_import export qidl + | VernacCanonical qid -> unsupported_attributes atts; vernac_canonical qid | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t | VernacIdentityCoercion ({v=id},s,t) -> vernac_identity_coercion ~atts id s t @@ -2188,77 +2188,82 @@ let interp ?proof ~atts ~st c = (* Type classes *) | VernacInstance (abst, sup, inst, props, info) -> vernac_instance ~atts abst sup inst props info - | VernacContext sup -> vernac_context ~atts sup - | VernacDeclareInstances insts -> vernac_declare_instances ~atts insts - | VernacDeclareClass id -> vernac_declare_class id + | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup + | VernacDeclareInstances insts -> with_section_locality ~atts vernac_declare_instances insts + | VernacDeclareClass id -> unsupported_attributes atts; vernac_declare_class id (* Solving *) - | VernacSolveExistential (n,c) -> vernac_solve_existential n c + | VernacSolveExistential (n,c) -> unsupported_attributes atts; vernac_solve_existential n c (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias - | VernacRemoveLoadPath s -> vernac_remove_loadpath s - | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> vernac_declare_ml_module ~atts l - | VernacChdir s -> vernac_chdir s + | VernacAddLoadPath (isrec,s,alias) -> unsupported_attributes atts; vernac_add_loadpath isrec s alias + | VernacRemoveLoadPath s -> unsupported_attributes atts; vernac_remove_loadpath s + | VernacAddMLPath (isrec,s) -> unsupported_attributes atts; vernac_add_ml_path isrec s + | VernacDeclareMLModule l -> with_locality ~atts vernac_declare_ml_module l + | VernacChdir s -> unsupported_attributes atts; vernac_chdir s (* State management *) - | VernacWriteState s -> vernac_write_state s - | VernacRestoreState s -> vernac_restore_state s + | VernacWriteState s -> unsupported_attributes atts; vernac_write_state s + | VernacRestoreState s -> unsupported_attributes atts; vernac_restore_state s (* Commands *) - | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb ~atts dbname b - | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints ~atts dbnames ids + | VernacCreateHintDb (dbname,b) -> + with_module_locality ~atts vernac_create_hintdb dbname b + | VernacRemoveHints (dbnames,ids) -> + with_module_locality ~atts vernac_remove_hints dbnames ids | VernacHints (dbnames,hints) -> vernac_hints ~atts dbnames hints | VernacSyntacticDefinition (id,c,b) -> - vernac_syntactic_definition ~atts id c b + with_module_locality ~atts vernac_syntactic_definition id c b | VernacArguments (qid, args, more_implicits, nargs, flags) -> - vernac_arguments ~atts qid args more_implicits nargs flags - | VernacReserve bl -> vernac_reserve bl - | VernacGeneralizable gen -> vernac_generalizable ~atts gen - | VernacSetOpacity qidl -> vernac_set_opacity ~atts qidl - | VernacSetStrategy l -> vernac_set_strategy ~atts l - | VernacSetOption (export, key,v) -> vernac_set_option ~atts export key v - | VernacUnsetOption (export, key) -> vernac_unset_option ~atts export key - | VernacRemoveOption (key,v) -> vernac_remove_option key v - | VernacAddOption (key,v) -> vernac_add_option key v - | VernacMemOption (key,v) -> vernac_mem_option key v - | VernacPrintOption key -> vernac_print_option key + with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags + | VernacReserve bl -> unsupported_attributes atts; vernac_reserve bl + | VernacGeneralizable gen -> with_locality ~atts vernac_generalizable gen + | VernacSetOpacity qidl -> with_locality ~atts vernac_set_opacity qidl + | VernacSetStrategy l -> with_locality ~atts vernac_set_strategy l + | VernacSetOption (export, key,v) -> vernac_set_option ~local:(only_locality atts) export key v + | VernacUnsetOption (export, key) -> vernac_unset_option ~local:(only_locality atts) export key + | VernacRemoveOption (key,v) -> unsupported_attributes atts; vernac_remove_option key v + | VernacAddOption (key,v) -> unsupported_attributes atts; vernac_add_option key v + | VernacMemOption (key,v) -> unsupported_attributes atts; vernac_mem_option key v + | VernacPrintOption key -> unsupported_attributes atts; vernac_print_option key | VernacCheckMayEval (r,g,c) -> Feedback.msg_notice @@ vernac_check_may_eval ~atts r g c - | VernacDeclareReduction (s,r) -> vernac_declare_reduction ~atts s r + | VernacDeclareReduction (s,r) -> with_locality ~atts vernac_declare_reduction s r | VernacGlobalCheck c -> + unsupported_attributes atts; Feedback.msg_notice @@ vernac_global_check c | VernacPrint p -> let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice @@ vernac_print ~atts env sigma p - | VernacSearch (s,g,r) -> vernac_search ~atts s g r - | VernacLocate l -> + | VernacSearch (s,g,r) -> unsupported_attributes atts; vernac_search ~atts s g r + | VernacLocate l -> unsupported_attributes atts; Feedback.msg_notice @@ vernac_locate l - | VernacRegister (qid, r) -> vernac_register qid r - | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") + | VernacRegister (qid, r) -> unsupported_attributes atts; vernac_register qid r + | VernacComments l -> unsupported_attributes atts; + Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) - | VernacFocus n -> vernac_focus n - | VernacUnfocus -> vernac_unfocus () - | VernacUnfocused -> + | VernacFocus n -> unsupported_attributes atts; vernac_focus n + | VernacUnfocus -> unsupported_attributes atts; vernac_unfocus () + | VernacUnfocused -> unsupported_attributes atts; Feedback.msg_notice @@ vernac_unfocused () - | VernacBullet b -> vernac_bullet b - | VernacSubproof n -> vernac_subproof n - | VernacEndSubproof -> vernac_end_subproof () - | VernacShow s -> + | VernacBullet b -> unsupported_attributes atts; vernac_bullet b + | VernacSubproof n -> unsupported_attributes atts; vernac_subproof n + | VernacEndSubproof -> unsupported_attributes atts; vernac_end_subproof () + | VernacShow s -> unsupported_attributes atts; Feedback.msg_notice @@ vernac_show s - | VernacCheckGuard -> + | VernacCheckGuard -> unsupported_attributes atts; Feedback.msg_notice @@ vernac_check_guard () - | VernacProof (tac, using) -> + | VernacProof (tac, using) -> unsupported_attributes atts; let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in - Aux_file.record_in_aux_at ?loc:atts.loc "VernacProof" (tacs^" "^usings); + Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); Option.iter vernac_set_end_tac tac; Option.iter vernac_set_used_variables using - | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] + | VernacProofMode mn -> unsupported_attributes atts; + Proof_global.set_proof_mode mn [@ocaml.warning "-3"] (* Extensions *) | VernacExtend (opn,args) -> @@ -2266,46 +2271,6 @@ let interp ?proof ~atts ~st c = let _st : Vernacstate.t = Vernacinterp.call ~atts opn args ~st in () -(* Vernaculars that take a locality flag *) -let check_vernac_supports_locality c l = - match l, c with - | None, _ -> () - | Some _, ( - VernacOpenCloseScope _ - | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ - | VernacDeclareScope _ | VernacDelimiters _ | VernacBindScope _ - | VernacDeclareCustomEntry _ - | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacStartTheoremProof _ - | VernacCoercion _ | VernacIdentityCoercion _ - | VernacInstance _ | VernacDeclareInstances _ - | VernacDeclareMLModule _ - | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ - | VernacSyntacticDefinition _ - | VernacArguments _ - | VernacGeneralizable _ - | VernacSetOpacity _ | VernacSetStrategy _ - | VernacSetOption _ | VernacUnsetOption _ - | VernacDeclareReduction _ - | VernacExtend _ - | VernacRegister _ - | VernacInductive _) -> () - | Some _, _ -> user_err Pp.(str "This command does not support Locality") - -(* Vernaculars that take a polymorphism flag *) -let check_vernac_supports_polymorphism c p = - match p, c with - | None, _ -> () - | Some _, ( - VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacInductive _ - | VernacStartTheoremProof _ - | VernacCoercion _ | VernacIdentityCoercion _ - | VernacInstance _ | VernacDeclareInstances _ - | VernacHints _ | VernacContext _ - | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () - | Some _, _ -> user_err Pp.(str "This command does not support Polymorphism") - (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2371,71 +2336,11 @@ let with_fail st b f = | _ -> assert false end -let attributes_of_flags f atts = - let assert_empty k v = - if v <> VernacFlagEmpty - then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") - in - List.fold_left - (fun (polymorphism, atts) (k, v) -> - match k with - | "program" when not atts.program -> - assert_empty k v; - (polymorphism, { atts with program = true }) - | "program" -> - user_err Pp.(str "Program mode specified twice") - | "polymorphic" when polymorphism = None -> - assert_empty k v; - (Some true, atts) - | "monomorphic" when polymorphism = None -> - assert_empty k v; - (Some false, atts) - | ("polymorphic" | "monomorphic") -> - user_err Pp.(str "Polymorphism specified twice") - | "template" when atts.template = None -> - assert_empty k v; - polymorphism, { atts with template = Some true } - | "notemplate" when atts.template = None -> - assert_empty k v; - polymorphism, { atts with template = Some false } - | "template" | "notemplate" -> - user_err Pp.(str "Templateness specified twice") - | "local" when Option.is_empty atts.locality -> - assert_empty k v; - (polymorphism, { atts with locality = Some true }) - | "global" when Option.is_empty atts.locality -> - assert_empty k v; - (polymorphism, { atts with locality = Some false }) - | ("local" | "global") -> - user_err Pp.(str "Locality specified twice") - | "deprecated" when Option.is_empty atts.deprecated -> - begin match v with - | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ] - | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] -> - let since = Some since and note = Some note in - (polymorphism, { atts with deprecated = Some (mk_deprecation ~since ~note ()) }) - | VernacFlagList [ "since", VernacFlagLeaf since ] -> - let since = Some since in - (polymorphism, { atts with deprecated = Some (mk_deprecation ~since ()) }) - | VernacFlagList [ "note", VernacFlagLeaf note ] -> - let note = Some note in - (polymorphism, { atts with deprecated = Some (mk_deprecation ~note ()) }) - | _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute") - end - | "deprecated" -> - user_err Pp.(str "Deprecation specified twice") - | _ -> user_err Pp.(str "Unknown attribute " ++ str k) - ) - (None, atts) - f - let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = - let orig_univ_poly = Flags.is_universe_polymorphism () in let orig_program_mode = Flags.is_program_mode () in let rec control = function - | VernacExpr (f, v) -> - let (polymorphism, atts) = attributes_of_flags f (mk_atts ~program:orig_program_mode ()) in - aux ~polymorphism ~atts v + | VernacExpr (atts, v) -> + aux ~atts v | VernacFail v -> with_fail st true (fun () -> control v) | VernacTimeout (n,v) -> current_timeout := Some n; @@ -2445,29 +2350,29 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = | VernacTime (batch, {v}) -> System.with_time ~batch control v; - and aux ~polymorphism ~atts : _ -> unit = + and aux ~atts : _ -> unit = function - | VernacLoad (_,fname) -> vernac_load control fname + | VernacLoad (_,fname) -> + unsupported_attributes atts; + vernac_load control fname | c -> - check_vernac_supports_locality c atts.locality; - check_vernac_supports_polymorphism c polymorphism; - let polymorphic = Option.default (Flags.is_universe_polymorphism ()) polymorphism in - Flags.make_universe_polymorphism polymorphic; - Obligations.set_program_mode atts.program; + let program = let open Attributes in + parse_drop_extra program_opt atts + in + (* NB: we keep polymorphism and program in the attributes, we're + just parsing them to do our option magic. *) + Option.iter Obligations.set_program_mode program; try vernac_timeout begin fun () -> - let atts = { atts with polymorphic } in if verbosely then Flags.verbosely (interp ?proof ~atts ~st) c else Flags.silently (interp ?proof ~atts ~st) c; (* If the command is `(Un)Set Program Mode` or `(Un)Set Universe Polymorphism`, we should not restore the previous state of the flag... *) - if orig_program_mode || not !Flags.program_mode || atts.program then + if Option.has_some program then Flags.program_mode := orig_program_mode; - if (Flags.is_universe_polymorphism() = polymorphic) then - Flags.make_universe_polymorphism orig_univ_poly; end with | reraise when @@ -2478,7 +2383,6 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = let e = CErrors.push reraise in let e = locate_if_not_already ?loc e in let () = restore_timeout () in - Flags.make_universe_polymorphism orig_univ_poly; Flags.program_mode := orig_program_mode; iraise e in @@ -2505,7 +2409,7 @@ open Extend type classifier = Genarg.raw_generic_argument list -> vernac_classification type (_, _) ty_sig = -| TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 0c4630e45f..8ccd121b8f 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -37,18 +37,12 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t -val universe_polymorphism_option_name : string list - -(** Elaborate a [atts] record out of a list of flags. - Also returns whether polymorphism is explicitly (un)set. *) -val attributes_of_flags : Vernacexpr.vernac_flags -> Vernacinterp.atts -> bool option * Vernacinterp.atts - (** {5 VERNAC EXTEND} *) type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification type (_, _) ty_sig = -| TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 27b485d94d..594e9eca48 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -395,7 +395,8 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_flags = (string * vernac_flag_value) list +type vernac_flags = vernac_flag list +and vernac_flag = string * vernac_flag_value and vernac_flag_value = | VernacFlagEmpty | VernacFlagLeaf of string diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 2746cbd144..eb4282705e 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -12,24 +12,7 @@ open Util open Pp open CErrors -type deprecation = { since : string option ; note : string option } - -let mk_deprecation ?(since=None) ?(note=None) () = - { since ; note } - -type atts = { - loc : Loc.t option; - locality : bool option; - polymorphic : bool; - template : bool option; - program : bool; - deprecated : deprecation option; -} - -let mk_atts ?(loc=None) ?(locality=None) ?(polymorphic=false) ?(template=None) ?(program=false) ?(deprecated=None) () : atts = - { loc ; locality ; polymorphic ; program ; deprecated; template } - -type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t +type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 62a178b555..0fc02c6915 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -10,24 +10,7 @@ (** Interpretation of extended vernac phrases. *) -type deprecation = { since : string option ; note : string option } - -val mk_deprecation : ?since: string option -> ?note: string option -> unit -> deprecation - -type atts = { - loc : Loc.t option; - locality : bool option; - polymorphic : bool; - template : bool option; - program : bool; - deprecated : deprecation option; -} - -val mk_atts : ?loc: Loc.t option -> ?locality: bool option -> - ?polymorphic: bool -> ?template:bool option -> - ?program: bool -> ?deprecated: deprecation option -> unit -> atts - -type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t +type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t type plugin_args = Genarg.raw_generic_argument list @@ -35,4 +18,4 @@ val vinterp_init : unit -> unit val vinterp_add : bool -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit val overwriting_vinterp_add : Vernacexpr.extend_name -> plugin_args vernac_command -> unit -val call : Vernacexpr.extend_name -> plugin_args -> atts:atts -> st:Vernacstate.t -> Vernacstate.t +val call : Vernacexpr.extend_name -> plugin_args -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t |