diff options
170 files changed, 2238 insertions, 2220 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 ada68f97d5..faf11b9a9e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -24,6 +24,25 @@ 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 + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N`. Changes from 8.8.2 to 8.9+beta1 =============================== @@ -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/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/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/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/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/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 f720e5195d..52880846f8 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -366,12 +366,18 @@ let pr_evar_map_gen with_univs pr_evars env 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 env sigma in - evs ++ svs ++ cstrs ++ typeclasses ++ metas + evs ++ svs ++ cstrs ++ typeclasses ++ obligations ++ metas let pr_evar_list env sigma l = let open Evd in @@ -1173,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 1054fbbc5e..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 diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml index 8960d4f257..72468b540e 100644 --- a/gramlib/gramext.ml +++ b/gramlib/gramext.ml @@ -27,8 +27,6 @@ and 'te g_level = lprefix : 'te g_tree } and g_assoc = NonA | RightA | LeftA and 'te g_symbol = - Sfacto of 'te g_symbol - | Smeta of string * 'te g_symbol list * Obj.t | Snterm of 'te g_entry | Snterml of 'te g_entry * string | Slist0 of 'te g_symbol @@ -36,13 +34,10 @@ and 'te g_symbol = | Slist1 of 'te g_symbol | Slist1sep of 'te g_symbol * 'te g_symbol * bool | Sopt of 'te g_symbol - | Sflag of 'te g_symbol | Sself | Snext - | Scut | Stoken of Plexing.pattern | Stree of 'te g_tree - | Svala of string list * 'te g_symbol and g_action = Obj.t and 'te g_tree = Node of 'te g_node @@ -66,12 +61,10 @@ let rec derive_eps = function Slist0 _ -> true | Slist0sep (_, _, _) -> true - | Sopt _ | Sflag _ -> true - | Sfacto s -> derive_eps s + | Sopt _ -> true | Stree t -> tree_derive_eps t - | Svala (_, s) -> derive_eps s - | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _, _) | Snterm _ | - Snterml (_, _) | Snext | Sself | Scut | Stoken _ -> + | Slist1 _ | Slist1sep (_, _, _) | Snterm _ | + Snterml (_, _) | Snext | Sself | Stoken _ -> false and tree_derive_eps = function @@ -90,38 +83,11 @@ let rec eq_symbol s1 s2 = | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2 | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) -> eq_symbol s1 s2 && eq_symbol sep1 sep2 && b1 = b2 - | Sflag s1, Sflag s2 -> eq_symbol s1 s2 | Sopt s1, Sopt s2 -> eq_symbol s1 s2 - | Svala (ls1, s1), Svala (ls2, s2) -> ls1 = ls2 && eq_symbol s1 s2 | Stree _, Stree _ -> false - | Sfacto (Stree t1), Sfacto (Stree t2) -> - (* The only goal of the node 'Sfacto' is to allow tree comparison - (therefore factorization) without looking at the semantic - actions; allow factorization of rules like "SV foo" which are - actually expanded into a tree. *) - let rec eq_tree t1 t2 = - match t1, t2 with - Node n1, Node n2 -> - eq_symbol n1.node n2.node && eq_tree n1.son n2.son && - eq_tree n1.brother n2.brother - | LocAct (_, _), LocAct (_, _) -> true - | DeadEnd, DeadEnd -> true - | _ -> false - in - eq_tree t1 t2 | _ -> s1 = s2 let is_before s1 s2 = - let s1 = - match s1 with - Svala (_, s) -> s - | _ -> s1 - in - let s2 = - match s2 with - Svala (_, s) -> s - | _ -> s2 - in match s1, s2 with Stoken ("ANY", _), _ -> false | _, Stoken ("ANY", _) -> true @@ -158,9 +124,6 @@ let insert_tree entry_name gsymbols action tree = if eq_symbol s s1 then let t = Node {node = s1; son = insert sl son; brother = bro} in Some t - else if s = Scut then - try_insert s sl (Node {node = s; son = tree; brother = DeadEnd}) - else if s1 = Scut then try_insert s1 (s :: sl) tree else if is_before s1 s || derive_eps s && not (derive_eps s1) then let bro = match try_insert s sl bro with @@ -203,8 +166,6 @@ and token_exists_in_tree f = | LocAct (_, _) | DeadEnd -> false and token_exists_in_symbol f = function - Sfacto sy -> token_exists_in_symbol f sy - | Smeta (_, syl, _) -> List.exists (token_exists_in_symbol f) syl | Slist0 sy -> token_exists_in_symbol f sy | Slist0sep (sy, sep, _) -> token_exists_in_symbol f sy || token_exists_in_symbol f sep @@ -212,11 +173,9 @@ and token_exists_in_symbol f = | Slist1sep (sy, sep, _) -> token_exists_in_symbol f sy || token_exists_in_symbol f sep | Sopt sy -> token_exists_in_symbol f sy - | Sflag sy -> token_exists_in_symbol f sy | Stoken tok -> f tok | Stree t -> token_exists_in_tree f t - | Svala (_, sy) -> token_exists_in_symbol f sy - | Snterm _ | Snterml (_, _) | Snext | Sself | Scut -> false + | Snterm _ | Snterml (_, _) | Snext | Sself -> false let insert_level entry_name e1 symbols action slev = match e1 with @@ -341,17 +300,13 @@ Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" flush stderr; failwith "Grammar.extend error" end - | Sfacto s -> check_gram entry s - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl | Slist0sep (s, t, _) -> check_gram entry t; check_gram entry s | Slist1sep (s, t, _) -> check_gram entry t; check_gram entry s | Slist0 s -> check_gram entry s | Slist1 s -> check_gram entry s | Sopt s -> check_gram entry s - | Sflag s -> check_gram entry s | Stree t -> tree_check_gram entry t - | Svala (_, s) -> check_gram entry s - | Snext | Sself | Scut | Stoken _ -> () + | Snext | Sself | Stoken _ -> () and tree_check_gram entry = function Node {node = n; brother = bro; son = son} -> @@ -371,16 +326,12 @@ let get_initial entry = let insert_tokens gram symbols = let rec insert = function - Sfacto s -> insert s - | Smeta (_, sl, _) -> List.iter insert sl | Slist0 s -> insert s | Slist1 s -> insert s | Slist0sep (s, t, _) -> insert s; insert t | Slist1sep (s, t, _) -> insert s; insert t | Sopt s -> insert s - | Sflag s -> insert s | Stree t -> tinsert t - | Svala (_, s) -> insert s | Stoken ("ANY", _) -> () | Stoken tok -> gram.glexer.Plexing.tok_using tok; @@ -389,7 +340,7 @@ let insert_tokens gram symbols = Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r in incr r - | Snterm _ | Snterml (_, _) | Snext | Sself | Scut -> () + | Snterm _ | Snterml (_, _) | Snext | Sself -> () and tinsert = function Node {node = s; brother = bro; son = son} -> @@ -507,17 +458,13 @@ let rec decr_keyw_use gram = Hashtbl.remove gram.gtokens tok; gram.glexer.Plexing.tok_removing tok end - | Sfacto s -> decr_keyw_use gram s - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl | Slist0 s -> decr_keyw_use gram s | Slist1 s -> decr_keyw_use gram s | Slist0sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 | Slist1sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 | Sopt s -> decr_keyw_use gram s - | Sflag s -> decr_keyw_use gram s | Stree t -> decr_keyw_use_in_tree gram t - | Svala (_, s) -> decr_keyw_use gram s - | Sself | Snext | Scut | Snterm _ | Snterml (_, _) -> () + | Sself | Snext | Snterm _ | Snterml (_, _) -> () and decr_keyw_use_in_tree gram = function DeadEnd | LocAct (_, _) -> () diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli index a76b7da9a2..e888508277 100644 --- a/gramlib/gramext.mli +++ b/gramlib/gramext.mli @@ -25,8 +25,6 @@ and 'te g_level = lprefix : 'te g_tree } and g_assoc = NonA | RightA | LeftA and 'te g_symbol = - Sfacto of 'te g_symbol - | Smeta of string * 'te g_symbol list * Obj.t | Snterm of 'te g_entry | Snterml of 'te g_entry * string | Slist0 of 'te g_symbol @@ -34,13 +32,10 @@ and 'te g_symbol = | Slist1 of 'te g_symbol | Slist1sep of 'te g_symbol * 'te g_symbol * bool | Sopt of 'te g_symbol - | Sflag of 'te g_symbol | Sself | Snext - | Scut | Stoken of Plexing.pattern | Stree of 'te g_tree - | Svala of string list * 'te g_symbol and g_action = Obj.t and 'te g_tree = Node of 'te g_node diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 04ec1049ed..760410894a 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -41,8 +41,6 @@ let print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s) let rec print_symbol ppf = function - Sfacto s -> print_symbol ppf s - | Smeta (n, sl, _) -> print_meta ppf n sl | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s | Slist0sep (s, t, osep) -> fprintf ppf "LIST0 %a SEP %a%s" print_symbol1 s print_symbol1 t @@ -52,42 +50,23 @@ let rec print_symbol ppf = fprintf ppf "LIST1 %a SEP %a%s" print_symbol1 s print_symbol1 t (if osep then " OPT_SEP" else "") | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Sflag s -> fprintf ppf "FLAG %a" print_symbol1 s | Stoken (con, prm) when con <> "" && prm <> "" -> fprintf ppf "%s@ %a" con print_str prm - | Svala (_, s) -> fprintf ppf "V %a" print_symbol s | Snterml (e, l) -> fprintf ppf "%s%s@ LEVEL@ %a" e.ename (if e.elocal then "*" else "") print_str l - | Snterm _ | Snext | Sself | Scut | Stoken _ | Stree _ as s -> + | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s -and print_meta ppf n sl = - let rec loop i = - function - [] -> () - | s :: sl -> - let j = - try String.index_from n i ' ' with Not_found -> String.length n - in - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else - begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end - in - loop 0 sl and print_symbol1 ppf = function - Sfacto s -> print_symbol1 ppf s | Snterm e -> fprintf ppf "%s%s" e.ename (if e.elocal then "*" else "") | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" - | Scut -> pp_print_string ppf "/" | Stoken ("", s) -> print_str ppf s | Stoken (con, "") -> pp_print_string ppf con | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) | - Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Sflag _ | Stoken _ | - Svala (_, _) as s -> + | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) | + Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Stoken _ as s -> fprintf ppf "(%a)" print_symbol s and print_rule ppf symbols = fprintf ppf "@[<hov 0>"; @@ -162,31 +141,24 @@ let name_of_symbol entry = let rec get_token_list entry rev_tokl last_tok tree = match tree with Node {node = Stoken tok; son = son; brother = DeadEnd} -> - get_token_list entry (last_tok :: rev_tokl) (tok, None) son - | Node {node = Svala (ls, Stoken tok); son = son; brother = DeadEnd} -> - get_token_list entry (last_tok :: rev_tokl) (tok, Some ls) son + get_token_list entry (last_tok :: rev_tokl) tok son | _ -> if rev_tokl = [] then None else Some (rev_tokl, last_tok, tree) let rec name_of_symbol_failed entry = function - Sfacto s -> name_of_symbol_failed entry s | Slist0 s -> name_of_symbol_failed entry s | Slist0sep (s, _, _) -> name_of_symbol_failed entry s | Slist1 s -> name_of_symbol_failed entry s | Slist1sep (s, _, _) -> name_of_symbol_failed entry s | Sopt s -> name_of_symbol_failed entry s - | Sflag s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t - | Svala (_, s) -> name_of_symbol_failed entry s - | Smeta (_, s :: _, _) -> name_of_symbol_failed entry s | s -> name_of_symbol entry s and name_of_tree_failed entry = function Node {node = s; brother = bro; son = son} -> let tokl = match s with - Stoken tok -> get_token_list entry [] (tok, None) son - | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son + Stoken tok -> get_token_list entry [] tok son | _ -> None in begin match tokl with @@ -205,7 +177,7 @@ and name_of_tree_failed entry = txt | Some (rev_tokl, last_tok, son) -> List.fold_left - (fun s (tok, _) -> + (fun s tok -> (if s = "" then "" else s ^ " ") ^ entry.egram.glexer.Plexing.tok_text tok) "" (List.rev (last_tok :: rev_tokl)) @@ -318,7 +290,7 @@ let tree_failed entry prev_symb_result prev_symb tree = let txt1 = name_of_symbol_failed entry sep in txt1 ^ " or " ^ txt ^ " expected" end - | Sopt _ | Sflag _ | Stree _ | Svala (_, _) -> txt ^ " expected" + | Sopt _ | Stree _ -> txt ^ " expected" | _ -> txt ^ " expected after " ^ name_of_symbol_failed entry prev_symb in if !error_verbose then @@ -426,29 +398,9 @@ let call_and_push ps al strm = let a = ps strm in let al = if !item_skipped then al else a :: al in item_skipped := false; al -let token_ematch gram (tok, vala) = +let token_ematch gram tok = let tematch = gram.glexer.Plexing.tok_match tok in - match vala with - Some al -> - let pa = - match al with - [] -> - let t = "V " ^ fst tok in gram.glexer.Plexing.tok_match (t, "") - | al -> - let rec loop = - function - a :: al -> - let pa = gram.glexer.Plexing.tok_match ("V", a) in - let pal = loop al in - (fun tok -> try pa tok with Stream.Failure -> pal tok) - | [] -> fun tok -> raise Stream.Failure - in - loop al - in - (fun tok -> - try Obj.repr (Ploc.VaAnt (Obj.magic (pa tok : string))) with - Stream.Failure -> Obj.repr (Ploc.VaVal (tematch tok))) - | None -> fun tok -> Obj.repr (tematch tok : string) + fun tok -> Obj.repr (tematch tok : string) let rec parser_of_tree entry nlevn alevn = function @@ -457,8 +409,6 @@ let rec parser_of_tree entry nlevn alevn = | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> (fun (strm__ : _ Stream.t) -> let a = entry.estart alevn strm__ in app act a) - | Node {node = Scut; son = son; brother = _} -> - parser_of_tree entry nlevn alevn son | Node {node = Sself; son = LocAct (act, _); brother = bro} -> let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> @@ -470,8 +420,7 @@ let rec parser_of_tree entry nlevn alevn = | Node {node = s; son = son; brother = DeadEnd} -> let tokl = match s with - Stoken tok -> get_token_list entry [] (tok, None) son - | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son + Stoken tok -> get_token_list entry [] tok son | _ -> None in begin match tokl with @@ -488,24 +437,18 @@ let rec parser_of_tree entry nlevn alevn = raise (Stream.Error (tree_failed entry a s son)) in app act a) - | Some (rev_tokl, (last_tok, svala), son) -> - let lt = - let t = Stoken last_tok in - match svala with - Some l -> Svala (l, t) - | None -> t - in + | Some (rev_tokl, last_tok, son) -> + let lt = Stoken last_tok in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in parser_of_token_list entry s son p1 (fun (strm__ : _ Stream.t) -> raise Stream.Failure) rev_tokl - (last_tok, svala) + last_tok end | Node {node = s; son = son; brother = bro} -> let tokl = match s with - Stoken tok -> get_token_list entry [] (tok, None) son - | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son + Stoken tok -> get_token_list entry [] tok son | _ -> None in match tokl with @@ -525,18 +468,13 @@ let rec parser_of_tree entry nlevn alevn = | None -> raise (Stream.Error (tree_failed entry a s son)) end | None -> p2 strm) - | Some (rev_tokl, (last_tok, vala), son) -> - let lt = - let t = Stoken last_tok in - match vala with - Some ls -> Svala (ls, t) - | None -> t - in + | Some (rev_tokl, last_tok, son) -> + let lt = Stoken last_tok in let p2 = parser_of_tree entry nlevn alevn bro in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in let p1 = - parser_of_token_list entry lt son p1 p2 rev_tokl (last_tok, vala) + parser_of_token_list entry lt son p1 p2 rev_tokl last_tok in fun (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> p2 strm__ @@ -592,13 +530,6 @@ and parser_of_token_list entry s son p1 p2 rev_tokl last_tok = let a = ps strm__ in let act = p1 strm__ in app act a and parser_of_symbol entry nlevn = function - Sfacto s -> parser_of_symbol entry nlevn s - | Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) | Slist0 s -> let ps = call_and_push (parser_of_symbol entry nlevn s) in let rec loop al (strm__ : _ Stream.t) = @@ -705,12 +636,6 @@ and parser_of_symbol entry nlevn = match try Some (ps strm__) with Stream.Failure -> None with Some a -> Obj.repr (Some a) | _ -> Obj.repr None) - | Sflag s -> - let ps = parser_of_symbol entry nlevn s in - (fun (strm__ : _ Stream.t) -> - match try Some (ps strm__) with Stream.Failure -> None with - Some _ -> Obj.repr true - | _ -> Obj.repr false) | Stree t -> let pt = parser_of_tree entry 1 0 t in (fun (strm__ : _ Stream.t) -> @@ -718,46 +643,11 @@ and parser_of_symbol entry nlevn = let a = pt strm__ in let ep = Stream.count strm__ in let loc = loc_of_token_interval bp ep in app a loc) - | Svala (al, s) -> - let pa = - match al with - [] -> - let t = - match s with - Sflag _ -> Some "V FLAG" - | Sopt _ -> Some "V OPT" - | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST" - | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST" - | Stoken (con, "") -> Some ("V " ^ con) - | _ -> None - in - begin match t with - Some t -> parser_of_token entry (t, "") - | None -> fun (strm__ : _ Stream.t) -> raise Stream.Failure - end - | al -> - let rec loop = - function - a :: al -> - let pa = parser_of_token entry ("V", a) in - let pal = loop al in - (fun (strm__ : _ Stream.t) -> - try pa strm__ with Stream.Failure -> pal strm__) - | [] -> fun (strm__ : _ Stream.t) -> raise Stream.Failure - in - loop al - in - let ps = parser_of_symbol entry nlevn s in - (fun (strm__ : _ Stream.t) -> - match try Some (pa strm__) with Stream.Failure -> None with - Some a -> Obj.repr (Ploc.VaAnt (Obj.magic a : string)) - | _ -> let a = ps strm__ in Obj.repr (Ploc.VaVal a)) | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__) | Snterml (e, l) -> (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__) | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) - | Scut -> (fun (strm__ : _ Stream.t) -> Obj.repr ()) | Stoken tok -> parser_of_token entry tok and parser_of_token entry tok = let f = entry.egram.glexer.Plexing.tok_match tok in @@ -891,13 +781,6 @@ let delete_rule entry sl = (* Normal interface *) -type token = string * string -type g = token Gramext.grammar - -type ('self, 'a) ty_symbol = token Gramext.g_symbol -type ('self, 'f, 'r) ty_rule = ('self, Obj.t) ty_symbol list -type 'a ty_production = ('a, Obj.t, Obj.t) ty_rule * Gramext.g_action - let create_toktab () = Hashtbl.create 301 let gcreate glexer = {gtokens = create_toktab (); glexer = glexer } @@ -916,12 +799,6 @@ type 'te gen_parsable = pa_tok_strm : 'te Stream.t; pa_loc_func : Plexing.location_function } -type parsable = token gen_parsable - -let parsable g cs = - let (ts, lf) = g.glexer.Plexing.tok_func cs in - {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} - let parse_parsable entry p = let efun = entry.estart 0 in let ts = p.pa_tok_strm in @@ -953,105 +830,6 @@ let parse_parsable entry p = let loc = Stream.count cs, Stream.count cs + 1 in restore (); Ploc.raise (Ploc.make_unlined loc) exc -let find_entry e s = - let rec find_levels = - function - [] -> None - | lev :: levs -> - match find_tree lev.lsuffix with - None -> - begin match find_tree lev.lprefix with - None -> find_levels levs - | x -> x - end - | x -> x - and find_symbol = - function - Sfacto s -> find_symbol s - | Snterm e -> if e.ename = s then Some e else None - | Snterml (e, _) -> if e.ename = s then Some e else None - | Smeta (_, sl, _) -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep (s, _, _) -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep (s, _, _) -> find_symbol s - | Sopt s -> find_symbol s - | Sflag s -> find_symbol s - | Stree t -> find_tree t - | Svala (_, s) -> find_symbol s - | Sself | Snext | Scut | Stoken _ -> None - and find_symbol_list = - function - s :: sl -> - begin match find_symbol s with - None -> find_symbol_list sl - | x -> x - end - | [] -> None - and find_tree = - function - Node {node = s; brother = bro; son = son} -> - begin match find_symbol s with - None -> - begin match find_tree bro with - None -> find_tree son - | x -> x - end - | x -> x - end - | LocAct (_, _) | DeadEnd -> None - in - match e.edesc with - Dlevels levs -> - begin match find_levels levs with - Some e -> e - | None -> raise Not_found - end - | Dparser _ -> raise Not_found -module Entry = - struct - type te = token - type 'a e = te g_entry - let create g n = - {egram = g; ename = n; elocal = false; estart = empty_entry n; - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - let parse_parsable (entry : 'a e) p : 'a = - Obj.magic (parse_parsable entry p : Obj.t) - let parse (entry : 'a e) cs : 'a = - let parsable = parsable entry.egram cs in parse_parsable entry parsable - let parse_parsable_all (entry : 'a e) p : 'a = - begin try Obj.magic [(parse_parsable entry p : Obj.t)] with - Stream.Failure | Stream.Error _ -> [] - end - let parse_all (entry : 'a e) cs : 'a = - let parsable = parsable entry.egram cs in - parse_parsable_all entry parsable - let parse_token_stream (entry : 'a e) ts : 'a = - Obj.magic (entry.estart 0 ts : Obj.t) - let _warned_using_parse_token = ref false - let parse_token (entry : 'a e) ts : 'a = - (* commented: too often warned in Coq... - if not warned_using_parse_token.val then do { - eprintf "<W> use of Grammar.Entry.parse_token "; - eprintf "deprecated since 2017-06-16\n%!"; - eprintf "use Grammar.Entry.parse_token_stream instead\n%! "; - warned_using_parse_token.val := True - } - else (); - *) - parse_token_stream entry ts - let name e = e.ename - let of_parser g n (p : te Stream.t -> 'a) : 'a e = - {egram = g; ename = n; elocal = false; - estart = (fun _ -> (Obj.magic p : te Stream.t -> Obj.t)); - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p : te Stream.t -> Obj.t)} - external obj : 'a e -> te Gramext.g_entry = "%identity" - let print ppf e = fprintf ppf "%a@." print_entry (obj e) - let find e s = find_entry (obj e) s - end - (* Unsafe *) let clear_entry e = @@ -1063,12 +841,6 @@ let clear_entry e = let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer -module Unsafe = - struct - let gram_reinit = gram_reinit - let clear_entry = clear_entry - end - (* Functorial interface *) module type GLexerType = sig type te val lexer : te Plexing.lexer end @@ -1095,7 +867,6 @@ module type S = type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule type 'a ty_production - val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol @@ -1107,18 +878,14 @@ module type S = ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> ('self, 'a list) ty_symbol val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_flag : ('self, 'a) ty_symbol -> ('self, bool) ty_symbol val s_self : ('self, 'self) ty_symbol val s_next : ('self, 'self) ty_symbol val s_token : Plexing.pattern -> ('self, string) ty_symbol val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol - val s_vala : - string list -> ('self, 'a) ty_symbol -> ('self, 'a Ploc.vala) ty_symbol val r_stop : ('self, 'r, 'r) ty_rule val r_next : ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - val r_cut : ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig @@ -1187,7 +954,6 @@ module GMake (L : GLexerType) = type ('self, 'a) ty_symbol = te Gramext.g_symbol type ('self, 'f, 'r) ty_rule = ('self, Obj.t) ty_symbol list type 'a ty_production = ('a, Obj.t, Obj.t) ty_rule * Gramext.g_action - let s_facto s = Sfacto s let s_nterm e = Snterm e let s_nterml e l = Snterml (e, l) let s_list0 s = Slist0 s @@ -1195,15 +961,12 @@ module GMake (L : GLexerType) = let s_list1 s = Slist1 s let s_list1sep s sep b = Slist1sep (s, sep, b) let s_opt s = Sopt s - let s_flag s = Sflag s let s_self = Sself let s_next = Snext let s_token tok = Stoken tok let s_rules (t : Obj.t ty_production list) = Gramext.srules (Obj.magic t) - let s_vala sl s = Svala (sl, s) let r_stop = [] let r_next r s = r @ [s] - let r_cut r = r @ [Scut] let production (p : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f) : 'a ty_production = Obj.magic p diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 54b7eb5539..244ab710dc 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -8,77 +8,6 @@ Grammars entries can be extended using the [EXTEND] statement, added by loading the Camlp5 [pa_extend.cmo] file. *) -type g - (** The type for grammars, holding entries. *) -type token = string * string - -type parsable -val parsable : g -> char Stream.t -> parsable - (** Type and value allowing to keep the same token stream between - several calls of entries of the same grammar, to prevent possible - loss of tokens. To be used with [Entry.parse_parsable] below *) - -module Entry : - sig - type 'a e - val create : g -> string -> 'a e - val parse : 'a e -> char Stream.t -> 'a - val parse_all : 'a e -> char Stream.t -> 'a list - val parse_parsable : 'a e -> parsable -> 'a - val name : 'a e -> string - val of_parser : g -> string -> (token Stream.t -> 'a) -> 'a e - val parse_token_stream : 'a e -> token Stream.t -> 'a - val print : Format.formatter -> 'a e -> unit - val find : 'a e -> string -> Obj.t e - external obj : 'a e -> token Gramext.g_entry = "%identity" - val parse_token : 'a e -> token Stream.t -> 'a - end - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_all e] returns the stream parser returning all possible - values while parsing with the entry [e]: may return more than one - value when the parsing algorithm is [Backtracking] -- [Entry.parse_all e] returns the parser returning all possible values. -- [Entry.parse_parsable e] returns the parsable parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.parse_token_stream e] returns the token stream parser of the - entry [e]. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in the rules of [e]. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing - to see what it holds. -- [Entry.parse_token]: deprecated since 2017-06-16; old name for - [Entry.parse_token_stream] *) - -type ('self, 'a) ty_symbol -(** Type of grammar symbols. A type-safe wrapper around Gramext.symbol. The - first type argument is the type of the ambient entry, the second one is the - type of the produced value. *) - -type ('self, 'f, 'r) ty_rule - -type 'a ty_production - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - val gram_reinit : g -> token Plexing.lexer -> unit - val clear_entry : 'a Entry.e -> unit - end - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if there - are keywords; 2) clearing an entry does not destroy the tokens - used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - (** {6 Functorial interface} *) (** Alternative for grammars use. Grammars are no more Ocaml values: @@ -112,7 +41,6 @@ module type S = type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule type 'a ty_production - val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol @@ -124,18 +52,14 @@ module type S = ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> ('self, 'a list) ty_symbol val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_flag : ('self, 'a) ty_symbol -> ('self, bool) ty_symbol val s_self : ('self, 'self) ty_symbol val s_next : ('self, 'self) ty_symbol val s_token : Plexing.pattern -> ('self, string) ty_symbol val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol - val s_vala : - string list -> ('self, 'a) ty_symbol -> ('self, 'a Ploc.vala) ty_symbol val r_stop : ('self, 'r, 'r) ty_rule val r_next : ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - val r_cut : ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index beebcd016e..986363ec1f 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -17,201 +17,3 @@ type 'te lexer = mutable tok_match : pattern -> 'te -> string; tok_text : pattern -> string; mutable tok_comm : location list option } - -let make_loc = Ploc.make_unlined -let dummy_loc = Ploc.dummy - -let lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" - -let locerr () = failwith "Lexer: location function" -let loct_create () = ref (Array.make 1024 None), ref false -let loct_func (loct, ov) i = - match - if i < 0 || i >= Array.length !loct then - if !ov then Some dummy_loc else None - else Array.unsafe_get !loct i - with - Some loc -> loc - | None -> locerr () -let loct_add (loct, ov) i loc = - if i >= Array.length !loct then - let new_tmax = Array.length !loct * 2 in - if new_tmax < Sys.max_array_length then - let new_loct = Array.make new_tmax None in - Array.blit !loct 0 new_loct 0 (Array.length !loct); - loct := new_loct; - !loct.(i) <- Some loc - else ov := true - else !loct.(i) <- Some loc - -let make_stream_and_location next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok) - in - ts, loct_func loct - -let lexer_func_of_parser next_token_loc cs = - let line_nb = ref 1 in - let bolpos = ref 0 in - make_stream_and_location (fun () -> next_token_loc (cs, line_nb, bolpos)) - -let lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try Bytes.set s 0 (Stream.next cs); 1 with Stream.Failure -> 0) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = make_loc (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in - tok, loc - in - make_stream_and_location next_token_loc - -(* Char and string tokens to real chars and string *) - -let buff = ref (Bytes.create 80) -let store len x = - if len >= Bytes.length !buff then - buff := Bytes.(cat !buff (create (length !buff))); - Bytes.set !buff len x; - succ len -let get_buff len = Bytes.sub !buff 0 len - -let valch x = Char.code x - Char.code '0' -let valch_a x = Char.code x - Char.code 'a' + 10 -let valch_A x = Char.code x - Char.code 'A' + 10 - -let rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - 'n' -> '\n', i + 1 - | 'r' -> '\r', i + 1 - | 't' -> '\t', i + 1 - | 'b' -> '\b', i + 1 - | '\\' -> '\\', i + 1 - | '"' -> '"', i + 1 - | '\'' -> '\'', i + 1 - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found -and backslash1 cod s i = - if i = String.length s then '\\', i - 1 - else - match s.[i] with - '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> '\\', i - 1 -and backslash2 cod s i = - if i = String.length s then '\\', i - 2 - else - match s.[i] with - '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 - | _ -> '\\', i - 2 -and backslash1h s i = - if i = String.length s then '\\', i - 1 - else - match s.[i] with - '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> '\\', i - 1 -and backslash2h cod s i = - if i = String.length s then '\\', i - 2 - else - match s.[i] with - '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1 - | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1 - | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1 - | _ -> '\\', i - 2 - -let rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i - -let skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i - -let eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = '\'' then '\'' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with Not_found -> failwith "invalid char token" - else failwith "invalid char token" - -let eval_string loc s = - let rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then store len '"', i + 1 - else - match s.[i] with - '\010' -> len, skip_indent s (i + 1) - | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1)) - | c -> - try let (c, i) = backslash s i in store len c, i with - Not_found -> store (store len '\\') c, i + 1 - else store len s.[i], i + 1 - in - loop len i - in - Bytes.to_string (loop 0 0) - -let default_match = - function - "ANY", "" -> (fun (con, prm) -> prm) - | "ANY", v -> - (fun (con, prm) -> if v = prm then v else raise Stream.Failure) - | p_con, "" -> - (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure) - | p_con, p_prm -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure - -let input_file = ref "" -let line_nb = ref (ref 0) -let bol_pos = ref (ref 0) -let restore_lexing_info = ref None - -(* The lexing buffer used by pa_lexer.cmo *) - -let rev_implode l = - let s = Bytes.create (List.length l) in - let rec loop i = - function - c :: l -> Bytes.unsafe_set s i c; loop (i - 1) l - | [] -> s - in - Bytes.to_string (loop (Bytes.length s - 1) l) - -module Lexbuf : - sig - type t - val empty : t - val add : char -> t -> t - val get : t -> string - end = - struct - type t = char list - let empty = [] - let add c l = c :: l - let get = rev_implode - end diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 6b5f718bc3..96b432a8ad 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -35,74 +35,3 @@ and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function and location_function = int -> Ploc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) - -val lexer_text : pattern -> string - (** A simple [tok_text] function. *) - -val default_match : pattern -> string * string -> string - (** A simple [tok_match] function, appling to the token type - [(string * string)] *) - -(** Lexers from parsers or ocamllex - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - it is possible to get a simple lexer (of the type [Plexing.glexer] above): - {[ - { Plexing.tok_func = f; - Plexing.tok_using = (fun _ -> ()); - Plexing.tok_removing = (fun _ -> ()); - Plexing.tok_match = Plexing.default_match; - Plexing.tok_text = Plexing.lexer_text; - Plexing.tok_comm = None } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Plexing.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -val lexer_func_of_parser : - (char Stream.t * int ref * int ref -> 'te * Ploc.t) -> 'te lexer_func - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. The two references - with the char stream contain the current line number and the - position of the beginning of the current line. *) -val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func - (** A lexer function from a lexer created by [ocamllex] *) - -(** Function to build a stream and a location function *) - -val make_stream_and_location : - (unit -> 'te * Ploc.t) -> 'te Stream.t * location_function - (** General function *) - -(** Useful functions and values *) - -val eval_char : string -> char -val eval_string : Ploc.t -> string -> string - (** Convert a char or a string token, where the backslashes had not - been interpreted into a real char or string; raise [Failure] if - bad backslash sequence found; [Plexing.eval_char (Char.escaped c)] - would return [c] and [Plexing.eval_string (String.escaped s)] would - return [s] *) - -val restore_lexing_info : (int * int) option ref -val input_file : string ref -val line_nb : int ref ref -val bol_pos : int ref ref - (** Special variables used to reinitialize line numbers and position - of beginning of line with their correct current values when a parser - is called several times with the same character stream. Necessary - for directives (e.g. #load or #use) which interrupt the parsing. - Without usage of these variables, locations after the directives - can be wrong. *) - -(** The lexing buffer used by streams lexers *) - -module Lexbuf : - sig - type t - val empty : t - val add : char -> t -> t - val get : t -> string - end diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml index cb71f72678..082686db01 100644 --- a/gramlib/ploc.ml +++ b/gramlib/ploc.ml @@ -55,122 +55,9 @@ let sub loc sh len = {loc with bp = loc.bp + sh; ep = loc.bp + sh + len} let after loc sh len = {loc with bp = loc.ep + sh; ep = loc.ep + sh + len} let with_comment loc comm = {loc with comm = comm} -let name = ref "loc" - -let from_file fname loc = - let (bp, ep) = first_pos loc, last_pos loc in - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col (strm__ : _ Stream.t) = - let cnt = Stream.count strm__ in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let s = strm__ in - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp - | _ -> fname, lin, col, col + 1 - in - let rec a_line_dir str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\n' -> Stream.junk strm__; loop str n - | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__ - | _ -> raise Stream.Failure - in - let rec spaces col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__ - | _ -> col - in - let rec check_string str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '"' -> - Stream.junk strm__; - let col = - try spaces (col + 1) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - a_line_dir str n col strm__ - | Some c when c <> '\n' -> - Stream.junk strm__; - check_string (str ^ String.make 1 c) n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let check_quote n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '"' -> Stream.junk strm__; check_string "" n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let rec check_num n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; - check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__ - | _ -> let col = spaces col strm__ in check_quote n col strm__ - in - let begin_line (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '#' -> - Stream.junk strm__; - let col = - try spaces 1 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - check_num 0 col strm__ - | _ -> not_a_line_dir 0 strm__ - in - begin_line strm - in - let r = - try loop fname 1 with - Stream.Failure -> - let bol = bol_pos loc in fname, line_nb loc, bp - bol, ep - bol - in - close_in ic; r - with Sys_error _ -> fname, 1, bp, ep - -let second_line fname ep0 (line, bp) ep = - let ic = open_in fname in - seek_in ic bp; - let rec loop line bol p = - if p = ep then - begin close_in ic; if bol = bp then line, ep0 else line, ep - bol end - else - let (line, bol) = - match input_char ic with - '\n' -> line + 1, p + 1 - | _ -> line, bol - in - loop line bol (p + 1) - in - loop line bp bp - -let get loc = - if loc.fname = "" || loc.fname = "-" then - loc.line_nb, loc.bp - loc.bol_pos, loc.line_nb, loc.ep - loc.bol_pos, - loc.ep - loc.bp - else - let (bl, bc, ec) = - loc.line_nb, loc.bp - loc.bol_pos, loc.ep - loc.bol_pos - in - let (el, eep) = second_line loc.fname ec (bl, loc.bp) loc.ep in - bl, bc, el, eep, ec - bc - -let call_with r v f a = - let saved = !r in - try r := v; let b = f a in r := saved; b with e -> r := saved; raise e - exception Exc of t * exn let raise loc exc = match exc with Exc (_, _) -> raise exc | _ -> raise (Exc (loc, exc)) - -type 'a vala = - VaAnt of string - | VaVal of 'a diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli index d2ab62db06..2ce6382183 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -84,39 +84,3 @@ val after : t -> int -> int -> t [len]. *) val with_comment : t -> string -> t (** Change the comment part of the given location *) - -(* miscellaneous *) - -val name : string ref - (** [Ploc.name.val] is the name of the location variable used in grammars - and in the predefined quotations for OCaml syntax trees. Default: - ["loc"] *) - -val get : t -> int * int * int * int * int - (** [Ploc.get loc] returns in order: 1/ the line number of the begin - of the location, 2/ its column, 3/ the line number of the first - character not in the location, 4/ its column and 5/ the length - of the location. The file where the location occurs (if any) may - be read during this operation. *) - -val from_file : string -> t -> string * int * int * int - (** [Ploc.from_file fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -(* pervasives *) - -type 'a vala = - VaAnt of string - | VaVal of 'a - (** Encloser of many abstract syntax tree nodes types, in "strict" mode. - This allow the system of antiquotations of abstract syntax tree - quotations to work when using the quotation kit [q_ast.cmo]. *) - -val call_with : 'a ref -> 'a -> ('b -> 'c) -> 'b -> 'c - (** [Ploc.call_with r v f a] sets the reference [r] to the value [v], - then call [f a], and resets [r] to its initial value. If [f a] raises - an exception, its initial value is also reset and the exception is - re-raised. The result is the result of [f a]. *) diff --git a/gramlib/token.ml b/gramlib/token.ml deleted file mode 100644 index 77c737b880..0000000000 --- a/gramlib/token.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp5r *) -(* token.ml,v *) -(* Copyright (c) INRIA 2007-2017 *) - -type pattern = Plexing.pattern - -exception Error of string - -type location = Ploc.t -type location_function = int -> location -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function - -type 'te glexer = - 'te Plexing.lexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - mutable tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : location list option } - -let make_loc = Ploc.make_unlined -let dummy_loc = Ploc.dummy - -let make_stream_and_location = Plexing.make_stream_and_location -let lexer_func_of_parser = Plexing.lexer_func_of_parser -let lexer_func_of_ocamllex = Plexing.lexer_func_of_ocamllex - -let eval_char = Plexing.eval_char -let eval_string = Plexing.eval_string - -let lexer_text = Plexing.lexer_text -let default_match = Plexing.default_match - -let line_nb = Plexing.line_nb -let bol_pos = Plexing.bol_pos -let restore_lexing_info = Plexing.restore_lexing_info diff --git a/gramlib/token.mli b/gramlib/token.mli deleted file mode 100644 index c1de5cefff..0000000000 --- a/gramlib/token.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* camlp5r *) -(* token.mli,v *) -(* Copyright (c) INRIA 2007-2017 *) - -(** Module deprecated since Camlp5 version 5.00. Use now module Plexing. - Compatibility assumed. *) - -type pattern = Plexing.pattern - -exception Error of string - (** Use now [Plexing.Error] *) - -type 'te glexer = - 'te Plexing.lexer = - { tok_func : 'te Plexing.lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - mutable tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : Ploc.t list option } - -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function -and location_function = int -> Ploc.t - -val lexer_text : pattern -> string - (** Use now [Plexing.lexer_text] *) -val default_match : pattern -> string * string -> string - (** Use now [Plexing.default_match] *) - -val lexer_func_of_parser : - (char Stream.t * int ref * int ref -> 'te * Ploc.t) -> 'te lexer_func - (** Use now [Plexing.lexer_func_of_parser] *) -val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func - (** Use now [Plexing.lexer_func_of_ocamllex] *) - -val make_stream_and_location : - (unit -> 'te * Ploc.t) -> 'te Stream.t * location_function - (** Use now [Plexing.make_stream_and_location] *) - -val eval_char : string -> char - (** Use now [Plexing.eval_char] *) -val eval_string : Ploc.t -> string -> string - (** Use now [Plexing.eval_string] *) - -val restore_lexing_info : (int * int) option ref - (** Use now [Plexing.restore_lexing_info] *) -val line_nb : int ref ref - (** Use now [Plexing.line_nb] *) -val bol_pos : int ref ref - (** Use now [Plexing.bol_pos] *) - -(* deprecated since version 4.08 *) - -type location = Ploc.t -val make_loc : int * int -> Ploc.t -val dummy_loc : Ploc.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/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/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/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/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 1acc8fd8fd..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 = Libobject.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 c6c6a307d4..d1b4977dd5 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -19,11 +19,13 @@ 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 = (Libobject.object_name * node) list @@ -31,10 +33,10 @@ 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,7 +48,7 @@ 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 ... } *) @@ -105,20 +107,20 @@ 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 -> - Libobject.object_name * Libnames.object_prefix * + Libobject.object_name * Nametab.object_prefix * Summary.frozen * library_segment val end_modtype : unit -> - Libobject.object_name * Libnames.object_prefix * + Libobject.object_name * Nametab.object_prefix * Summary.frozen * library_segment (** {6 Compilation units } *) @@ -126,7 +128,7 @@ val end_modtype : val start_compilation : DirPath.t -> ModPath.t -> unit val end_compilation_checks : DirPath.t -> Libobject.object_name val end_compilation : - Libobject.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 f6fc5ed4b7..87c4de42e8 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -162,31 +162,6 @@ let qualid_basename qid = let qualid_path qid = qid.CAst.v.dirpath -type object_prefix = { - obj_dir : DirPath.t; - obj_mp : ModPath.t; - obj_sec : DirPath.t; -} - -(* 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 9d75ec6e40..9960603cbb 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -88,38 +88,6 @@ val qualid_is_ident : qualid -> bool val qualid_path : qualid -> DirPath.t val qualid_basename : qualid -> Id.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 - -(** 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 ea19fbb90b..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 () @@ -18,10 +17,6 @@ type 'a substitutivity = type object_name = Libnames.full_path * Names.KerName.t -(* let make_oname (dirpath,(mp,dir)) id = *) -let make_oname { obj_dir; obj_mp } id = - Names.(make_path obj_dir id, KerName.make obj_mp (Label.of_id id)) - type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; @@ -71,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 c53537e654..32ffc5b79e 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -71,7 +71,6 @@ type 'a substitutivity = *) type object_name = full_path * Names.KerName.t -val make_oname : object_prefix -> Names.Id.t -> object_name type 'a object_declaration = { object_name : string; 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/parsing/cLexer.ml b/parsing/cLexer.ml index 2230dfc47c..619718f723 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -767,15 +767,15 @@ let func cs = (ts, loct_func loct) let lexer = { - Token.tok_func = func; - Token.tok_using = + Plexing.tok_func = func; + Plexing.tok_using = (fun pat -> match Tok.of_pattern pat with | KEYWORD s -> add_keyword s | _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Tok.match_pattern; - Token.tok_comm = None; - Token.tok_text = token_text } + Plexing.tok_removing = (fun _ -> ()); + Plexing.tok_match = Tok.match_pattern; + Plexing.tok_comm = None; + Plexing.tok_text = token_text } (** Terminal symbols interpretation *) 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 d4e410bd69..651895aa08 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1004,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 96eb7fbc60..d1a227d517 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -804,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 _ _ -> ())); @@ -866,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/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 8b2721ae4e..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 = @@ -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.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 fcbcfae115..ebec3c887c 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -44,6 +44,7 @@ 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 make_empty_glob_sign () = Genintern.empty_glob_sign (Global.env ()) @@ -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 a9f2d76e30..178f6af71d 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -21,6 +21,7 @@ type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } val make_empty_glob_sign : unit -> glob_sign diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 5828494454..2a046a3e65 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -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) -> 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/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 dd38ec6f64..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 -> 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/pretyping.ml b/pretyping/pretyping.ml index 55817f1b76..cba1533da5 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -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/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/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/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/logic.ml b/proofs/logic.ml index b8612cd2c0..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) 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/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/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/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 92c124ec32..d319ed1029 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -422,6 +422,25 @@ Proof. unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H. Qed. +Lemma double_lt_mono n m : n < m -> double n < double m. +Proof. + destruct n as [|n], m as [|m]; intros H; try easy. +Qed. + +Lemma double_le_mono n m : n <= m -> double n <= double m. +Proof. + destruct n as [|n], m as [|m]; intros H; try easy. +Qed. + +Lemma succ_double_lt_mono n m : n < m -> succ_double n < succ_double m. +Proof. + destruct n as [|n], m as [|m]; intros H; try easy. +Qed. + +Lemma succ_double_le_mono n m : n <= m -> succ_double n <= succ_double m. +Proof. + destruct n as [|n], m as [|m]; intros H; try easy. +Qed. (** 0 is the least natural number *) diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index a2a2430e91..fb1cef1ddd 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -8,9 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Bool Morphisms Setoid Bvector BinPos BinNat PeanoNat Pnat Nnat. +Require Import Bool Morphisms Setoid Bvector BinPos BinNat PeanoNat Pnat Nnat + Basics ByteVector. Local Open Scope N_scope. +Local Open Scope program_scope. (** This file is mostly obsolete, see directly [BinNat] now. *) @@ -534,6 +536,9 @@ Definition N2Bv_sized (m : nat) (n : N) : Bvector m := | Npos p => P2Bv_sized m p end. +Definition N2ByteV_sized (m : nat) : N -> ByteVector m := + of_Bvector ∘ N2Bv_sized (m * 8). + Fixpoint Bv2N (n:nat)(bv:Bvector n) : N := match bv with | Vector.nil _ => N0 @@ -541,6 +546,11 @@ Fixpoint Bv2N (n:nat)(bv:Bvector n) : N := | Vector.cons _ true n bv => N.succ_double (Bv2N n bv) end. +Arguments Bv2N {n} bv, n bv. + +Definition ByteV2N {n : nat} : ByteVector n -> N := + Bv2N ∘ to_Bvector. + Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. Proof. destruct n. @@ -575,6 +585,23 @@ destruct a ; compute ; split ; intros x ; now inversion x. simpl ;intuition ; try discriminate. Qed. +Lemma Bv2N_upper_bound (n : nat) (bv : Bvector n) : + (Bv2N bv < N.shiftl_nat 1 n)%N. +Proof with simpl; auto. + induction bv... + - constructor. + - destruct h. + + apply N.succ_double_lt... + + apply N.double_lt_mono... +Qed. + +Corollary ByteV2N_upper_bound (n : nat) (v : ByteVector n) : + (ByteV2N v < N.shiftl_nat 1 (n * 8))%N. +Proof. + unfold ByteV2N, compose. + apply Bv2N_upper_bound. +Qed. + (** To state nonetheless a second result about composition of conversions, we define a conversion on a given number of bits : *) diff --git a/theories/Strings/ByteVector.v b/theories/Strings/ByteVector.v index 16f26002d2..3588aaca3f 100644 --- a/theories/Strings/ByteVector.v +++ b/theories/Strings/ByteVector.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Ascii Basics Bvector Psatz String Vector. +Require Import Ascii Basics Bvector String Vector. Export VectorNotations. Open Scope program_scope. Open Scope string_scope. 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/coqloop.ml b/toplevel/coqloop.ml index 59a464a22e..cbc5c124c8 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -255,7 +255,7 @@ let rec discard_to_dot () = try Pcoq.Entry.parse parse_to_dot top_buffer.tokens with - | Token.Error _ | CLexer.Error.E _ -> discard_to_dot () + | Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () 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/explainErr.ml b/vernac/explainErr.ml index b37fce645a..e6803443b3 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -29,7 +29,7 @@ exception EvaluatedError of Pp.t * exn option let explain_exn_default = function (* Basic interaction exceptions *) | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | Plexing.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) | Out_of_memory -> hov 0 (str "Out of memory.") 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 844caf5a3e..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 *) 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 |