diff options
126 files changed, 1060 insertions, 512 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 18ea50d77b..99ae4c23ce 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -78,7 +78,6 @@ before_script: - config/Makefile - config/coq_config.py - config/coq_config.ml - - test-suite/misc/universes/all_stdlib.v - dmesg.txt expire_in: 1 week script: @@ -95,7 +94,6 @@ before_script: - echo 'start:coq.build' - make -j "$NJOBS" byte - make -j "$NJOBS" world $EXTRA_TARGET - - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' - echo 'start:coq.install' diff --git a/Makefile.build b/Makefile.build index 526a8c5831..b307bde5df 100644 --- a/Makefile.build +++ b/Makefile.build @@ -603,7 +603,7 @@ $(CSDPCERTBYTE): $(CSDPCERTCMO) # tests ########################################################################### -.PHONY: validate check test-suite $(ALLSTDLIB).v +.PHONY: validate check test-suite VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -coqlib . @@ -611,15 +611,11 @@ validate: $(CHICKEN) | $(ALLVO:.$(VO)=.vo) $(SHOW)'COQCHK <theories & plugins>' $(HIDE)$(CHICKEN) $(VALIDOPTS) $(ALLVO) -$(ALLSTDLIB).v: - $(SHOW)'MAKE $(notdir $@)' - $(HIDE)echo "Require $(ALLMODS)." > $@ - MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) check: validate test-suite -test-suite: world byte $(ALLSTDLIB).v +test-suite: world byte $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all diff --git a/Makefile.common b/Makefile.common index 1f59bff183..82d9b89c4f 100644 --- a/Makefile.common +++ b/Makefile.common @@ -179,8 +179,6 @@ PLUGINSOPT:=$(PLUGINSCMO:.cmo=.cmxs) LINKCMO:=$(CORECMA) $(STATICPLUGINS) LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) -ALLSTDLIB := test-suite/misc/universes/all_stdlib - PLUGINTUTO := doc/plugin_tutorial # For emacs: diff --git a/Makefile.make b/Makefile.make index 34f5707ae8..2f6781439c 100644 --- a/Makefile.make +++ b/Makefile.make @@ -253,7 +253,6 @@ docclean: archclean: clean-ide optclean voclean plugin-tutorialclean rm -rf _build _build_boot - rm -f $(ALLSTDLIB).* optclean: rm -f $(COQTOPEXE) $(CHICKEN) $(TOPBINOPT) diff --git a/config/coq_config.mli b/config/coq_config.mli index 12856cb6e6..809fa3d758 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -57,4 +57,5 @@ val wwwstdlib : string val localwwwrefman : string val bytecode_compiler : bool -val native_compiler : bool +type native_compiler = NativeOff | NativeOn of { ondemand : bool } +val native_compiler : native_compiler diff --git a/configure.ml b/configure.ml index 6a4b1f9a75..e32f780a3d 100644 --- a/configure.ml +++ b/configure.ml @@ -225,6 +225,8 @@ let short_date, full_date = get_date () type ide = Opt | Byte | No +type nativecompiler = NativeYes | NativeNo | NativeOndemand + type preferences = { prefix : string option; local : bool; @@ -252,7 +254,7 @@ type preferences = { bin_annot : bool; annot : bool; bytecodecompiler : bool; - nativecompiler : bool; + nativecompiler : nativecompiler; coqwebsite : string; force_caml_version : bool; force_findlib_version : bool; @@ -288,7 +290,8 @@ let default = { bin_annot = false; annot = false; bytecodecompiler = true; - nativecompiler = not (os_type_win32 || os_type_cygwin); + nativecompiler = + if os_type_win32 || os_type_cygwin then NativeNo else NativeOndemand; coqwebsite = "http://coq.inria.fr/"; force_caml_version = false; force_findlib_version = false; @@ -332,6 +335,12 @@ let get_ide = function | "no" -> No | s -> raise (Arg.Bad ("(opt|byte|no) argument expected instead of "^s)) +let get_native = function + | "yes" -> NativeYes + | "no" -> NativeNo + | "ondemand" -> NativeOndemand + | s -> raise (Arg.Bad ("(yes|no|ondemand) argument expected instead of "^s)) + let arg_bool f = Arg.String (fun s -> prefs := f !prefs (get_bool s)) let arg_string f = Arg.String (fun s -> prefs := f !prefs s) @@ -346,6 +355,8 @@ let arg_clear_option f = Arg.Unit (fun () -> prefs := f !prefs (Some false)) let arg_ide f = Arg.String (fun s -> prefs := f !prefs (Some (get_ide s))) +let arg_native f = Arg.String (fun s -> prefs := f !prefs (get_native s)) + let arg_profile = Arg.String (fun s -> prefs := Profiles.get s !prefs) (* TODO : earlier any option -foo was also available as --foo *) @@ -407,8 +418,11 @@ let args_options = Arg.align [ " Dumps ml binary annotation files while compiling Coq (e.g. for Merlin)"; "-bytecode-compiler", arg_bool (fun p bytecodecompiler -> { p with bytecodecompiler }), "(yes|no) Enable Coq's bytecode reduction machine (VM)"; - "-native-compiler", arg_bool (fun p nativecompiler -> { p with nativecompiler }), - "(yes|no) Compilation to native code for conversion and normalization"; + "-native-compiler", arg_native (fun p nativecompiler -> { p with nativecompiler }), + "(yes|no|ondemand) Compilation to native code for conversion and normalization + yes: -native-compiler option of coqc will default to 'yes', stdlib will be precompiled + no: no native compilation available at all + ondemand (default): -native-compiler option of coqc will default to 'ondemand', stdlib will not be precompiled"; "-coqwebsite", arg_string (fun p coqwebsite -> { p with coqwebsite }), " URL of the coq website"; "-force-caml-version", arg_set (fun p force_caml_version -> { p with force_caml_version }), @@ -991,6 +1005,9 @@ let esc s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s (** * Summary of the configuration *) +let pr_native = function + | NativeYes -> "yes" | NativeNo -> "no" | NativeOndemand -> "ondemand" + let print_summary () = let pr s = printf s in pr "\n"; @@ -1016,7 +1033,7 @@ let print_summary () = pr " Web browser : %s\n" browser; pr " Coq web site : %s\n" !prefs.coqwebsite; pr " Bytecode VM enabled : %B\n" !prefs.bytecodecompiler; - pr " Native Compiler enabled : %B\n\n" !prefs.nativecompiler; + pr " Native Compiler enabled : %s\n\n" (pr_native !prefs.nativecompiler); if !prefs.local then pr " Local build, no installation...\n" else @@ -1095,7 +1112,11 @@ let write_configml f = pr_s "wwwstdlib" (!prefs.coqwebsite ^ "distrib/V" ^ coq_version ^ "/stdlib/"); pr_s "localwwwrefman" ("file:/" ^ docdir ^ "/html/refman"); pr_b "bytecode_compiler" !prefs.bytecodecompiler; - pr_b "native_compiler" !prefs.nativecompiler; + pr "type native_compiler = NativeOff | NativeOn of { ondemand : bool }\n"; + pr "let native_compiler = %s\n" + (match !prefs.nativecompiler with + | NativeYes -> "NativeOn {ondemand=false}" | NativeNo -> "NativeOff" + | NativeOndemand -> "NativeOn {ondemand=true}"); let core_src_dirs = [ "config"; "lib"; "clib"; "kernel"; "library"; "engine"; "pretyping"; "interp"; "gramlib"; "gramlib/.pack"; "parsing"; "proofs"; @@ -1217,7 +1238,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 yes" else ""); + pr "NATIVECOMPUTE=%s\n" (if !prefs.nativecompiler = NativeYes 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/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 8570c34194..524555b69c 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,5 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make && make install ) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index a0094b1006..72fc613c43 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download color +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/color" && make ) diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 9cb7a65ab5..6b09726606 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -5,6 +5,7 @@ ci_dir="$(dirname "$0")" git_download compcert +export COQCOPTS='-native-compiler no -w -undeclared-scope -w -omega-is-deprecated' ( cd "${CI_BUILD_DIR}/compcert" && \ ./configure -ignore-coq-version x86_32-linux && \ make && \ diff --git a/dev/ci/ci-coqprime.sh b/dev/ci/ci-coqprime.sh index a4fd296896..e12c36e6a7 100755 --- a/dev/ci/ci-coqprime.sh +++ b/dev/ci/ci-coqprime.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download coqprime +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/coqprime" && make && make install) diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh index ac3978dc8d..785ff4c2ad 100755 --- a/dev/ci/ci-corn.sh +++ b/dev/ci/ci-corn.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download corn +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/corn" && ./configure.sh && make && make install ) diff --git a/dev/ci/ci-engine_bench.sh b/dev/ci/ci-engine_bench.sh index fda7649f88..d976356dd4 100755 --- a/dev/ci/ci-engine_bench.sh +++ b/dev/ci/ci-engine_bench.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download engine_bench +export COQEXTRAFLAGS='-native-compiler ondemand' ( cd "${CI_BUILD_DIR}/engine_bench" && make coq && make coq-perf-Sanity ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index 30047e624b..3eda7161c1 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download equations +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/equations" && ./configure.sh coq && make ci && make install ) diff --git a/dev/ci/ci-fiat_crypto.sh b/dev/ci/ci-fiat_crypto.sh index 3ecdb32a51..e8fa8c0be4 100755 --- a/dev/ci/ci-fiat_crypto.sh +++ b/dev/ci/ci-fiat_crypto.sh @@ -18,6 +18,7 @@ fiat_crypto_CI_MAKE_ARGS="EXTERNAL_REWRITER=1 EXTERNAL_COQPRIME=1" fiat_crypto_CI_TARGETS1="${fiat_crypto_CI_MAKE_ARGS} pre-standalone-extracted printlite lite" fiat_crypto_CI_TARGETS2="${fiat_crypto_CI_MAKE_ARGS} all-except-compiled" +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ ulimit -s ${fiat_crypto_CI_STACKSIZE} && \ make ${fiat_crypto_CI_TARGETS1} && make -j 1 ${fiat_crypto_CI_TARGETS2} ) diff --git a/dev/ci/ci-fiat_crypto_legacy.sh b/dev/ci/ci-fiat_crypto_legacy.sh index 6d0a803401..57cc121bb4 100755 --- a/dev/ci/ci-fiat_crypto_legacy.sh +++ b/dev/ci/ci-fiat_crypto_legacy.sh @@ -9,5 +9,6 @@ git_download fiat_crypto_legacy fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite-hardcoded old-pipeline-lite-hardcoded lite-display-hardcoded" fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem-hardcoded old-pipeline-nobigmem-hardcoded nonautogenerated-specific nonautogenerated-specific-display selected-specific selected-specific-display" +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/fiat_crypto_legacy" && git submodule update --init --recursive && \ make ${fiat_crypto_legacy_CI_TARGETS1} && make -j 1 ${fiat_crypto_legacy_CI_TARGETS2} ) diff --git a/dev/ci/ci-fiat_crypto_ocaml.sh b/dev/ci/ci-fiat_crypto_ocaml.sh index 20d3deb14f..c63690d5c9 100755 --- a/dev/ci/ci-fiat_crypto_ocaml.sh +++ b/dev/ci/ci-fiat_crypto_ocaml.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" fiat_crypto_CI_MAKE_ARGS="EXTERNAL_REWRITER=1 EXTERNAL_COQPRIME=1" +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/fiat_crypto" && make ${fiat_crypto_CI_MAKE_ARGS} standalone-ocaml lite-generated-files ) diff --git a/dev/ci/ci-fiat_parsers.sh b/dev/ci/ci-fiat_parsers.sh index ac74ebf667..8409e25bdc 100755 --- a/dev/ci/ci-fiat_parsers.sh +++ b/dev/ci/ci-fiat_parsers.sh @@ -6,4 +6,5 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download fiat_parsers +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/fiat_parsers" && make parsers parsers-examples && make fiat-core ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 4b92c8cb4d..679bef3b5e 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -5,4 +5,6 @@ ci_dir="$(dirname "$0")" git_download hott -( cd "${CI_BUILD_DIR}/hott" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) +( cd "${CI_BUILD_DIR}/hott" && ./autogen.sh -skip-submodules && ./configure \ + && sed -i.bak 's/\(HOQC =.*\)/\1 -native-compiler no/' Makefile \ + && make && make validate ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 27876d68de..813ea9b07a 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download metacoq +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make .merlin && make ci-local && make install ) diff --git a/dev/ci/ci-perennial.sh b/dev/ci/ci-perennial.sh index 306cbdf63c..43add8254a 100755 --- a/dev/ci/ci-perennial.sh +++ b/dev/ci/ci-perennial.sh @@ -6,4 +6,5 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download perennial +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false lite ) diff --git a/dev/ci/ci-rewriter.sh b/dev/ci/ci-rewriter.sh index 235482ffeb..ec7ac5bddc 100755 --- a/dev/ci/ci-rewriter.sh +++ b/dev/ci/ci-rewriter.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download rewriter +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/rewriter" && make && make install) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 704e278a4b..3d320617f2 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -5,4 +5,5 @@ ci_dir="$(dirname "$0")" git_download unimath +export COQEXTRAFLAGS='-native-compiler no' ( cd "${CI_BUILD_DIR}/unimath" && make BUILD_COQ=no ) diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 4a332406a2..a151cf0ba6 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -7,4 +7,5 @@ git_download vst export COMPCERT=bundled +sed -i.bak 's/\(COQC=.*\)/\1 -native-compiler no/' ${CI_BUILD_DIR}/vst/Makefile ( cd "${CI_BUILD_DIR}/vst" && make IGNORECOQVERSION=true ) diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 37619833ac..79c2155823 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -312,6 +312,26 @@ Conversion machines risk: none without using -allow-sprop (off by default in 8.10.0), otherwise could be exploited by mistake + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow on large accumulators + introduced: 8.1 + impacted released versions: 8.1-8.12.1 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.0 + found by: Dolan, Roux, Melquiond + GH issue number: ocaml/ocaml#6385, #11170 + risk: medium, as it can happen for large irreducible applications + + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow on large records and closures + introduced: 8.1 + impacted released versions: 8.1-now + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: + found by: Dolan, Roux, Melquiond + GH issue number: ocaml/ocaml#6385, #11170 + risk: unlikely to be activated by chance, might happen for autogenerated code + Side-effects component: side-effects diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index 21d6fbe9aa..bfc186c862 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -46,6 +46,7 @@ install_printer Top_printers.pp_idpred install_printer Top_printers.pp_cpred install_printer Top_printers.pp_transparent_state install_printer Top_printers.pp_stack_t +install_printer Top_printers.pp_estack_t install_printer Top_printers.pp_state_t install_printer Top_printers.ppmetas install_printer Top_printers.ppevm diff --git a/dev/top_printers.ml b/dev/top_printers.ml index e4dd7ef52c..a9438c4aca 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -165,6 +165,7 @@ let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) let pp_transparent_state s = pp (pr_transparent_state s) let pp_stack_t n = pp (Reductionops.Stack.pr (EConstr.of_constr %> pr_econstr) n) +let pp_estack_t n = pp (Reductionops.Stack.pr pr_econstr n) let pp_state_t n = pp (Reductionops.pr_state Global.(env()) Evd.empty n) (* proof printers *) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 712f66112c..50495dc0a4 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -108,6 +108,7 @@ val pp_cpred : Names.Cpred.t -> unit val pp_transparent_state : TransparentState.t -> unit val pp_stack_t : Constr.t Reductionops.Stack.t -> unit +val pp_estack_t : EConstr.t Reductionops.Stack.t -> unit val pp_state_t : Reductionops.state -> unit val ppmetas : Evd.Metaset.t -> unit diff --git a/doc/changelog/03-notations/11841-master+distinguishing-ident-name-in-grammar-entries.rst b/doc/changelog/03-notations/11841-master+distinguishing-ident-name-in-grammar-entries.rst new file mode 100644 index 0000000000..8d681361e8 --- /dev/null +++ b/doc/changelog/03-notations/11841-master+distinguishing-ident-name-in-grammar-entries.rst @@ -0,0 +1,13 @@ +- **Changed:** + In notations (except in custom entries), the misleading :n:`@syntax_modifier` + :n:`@ident ident` (which accepted either an identifier or + a :g:`_`) is deprecated and should be replaced by :n:`@ident name`. If + the intent was really to only parse identifiers, this will + eventually become possible, but only as of Coq 8.15. + In custom entries, the meaning of :n:`@ident ident` is silently changed + from parsing identifiers or :g:`_` to parsing only identifiers + without warning, but this presumably affects only rare, recent and + relatively experimental code + (`#11841 <https://github.com/coq/coq/pull/11841>`_, + fixes `#9514 <https://github.com/coq/coq/pull/9514>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst b/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst new file mode 100644 index 0000000000..c973e157dd --- /dev/null +++ b/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst @@ -0,0 +1,6 @@ +- **Added:** + The :n:`@binder` entry of :cmd:`Notation` can now be used in + notations expecting a single (non-recursive) binder + (`#13265 <https://github.com/coq/coq/pull/13265>`_, + by Hugo Herbelin, see section :n:`notations-and-binders` of the + reference manual). diff --git a/doc/changelog/04-tactics/12246-master+apply-in-many-hyps.rst b/doc/changelog/04-tactics/12246-master+apply-in-many-hyps.rst new file mode 100644 index 0000000000..15ab18dcf1 --- /dev/null +++ b/doc/changelog/04-tactics/12246-master+apply-in-many-hyps.rst @@ -0,0 +1,5 @@ +- **Added:** + `apply in` supports several hypotheses + (`#12246 <https://github.com/coq/coq/pull/12246>`_, + by Hugo Herbelin; grants + `#9816 <https://github.com/coq/coq/pull/9816>`_). diff --git a/doc/changelog/04-tactics/13417-no_int_or_var.rst b/doc/changelog/04-tactics/13417-no_int_or_var.rst new file mode 100644 index 0000000000..667ee28eea --- /dev/null +++ b/doc/changelog/04-tactics/13417-no_int_or_var.rst @@ -0,0 +1,7 @@ +- **Removed:** + A number of tactics that formerly accepted negative + numbers as parameters now give syntax errors for negative + values. These include {e}constructor, do, timeout, + 9 {e}auto tactics and psatz*. + (`#13417 <https://github.com/coq/coq/pull/13417>`_, + by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/13352-cep-48.rst b/doc/changelog/07-commands-and-options/13352-cep-48.rst new file mode 100644 index 0000000000..cb2eeea74b --- /dev/null +++ b/doc/changelog/07-commands-and-options/13352-cep-48.rst @@ -0,0 +1,12 @@ +- **Changed:** + Option -native-compiler of the configure script now impacts the + default value of the option -native-compiler of coqc. The + -native-compiler option of the configure script is added an ondemand + value, which becomes the default, thus preserving the previous default + behavior. + The stdlib is still precompiled when configuring with -native-compiler + yes. It is not precompiled otherwise. + This an implementation of point 2 of + `CEP #48 <https://github.com/coq/ceps/pull/48>`_ + (`#13352 <https://github.com/coq/coq/pull/13352>`_, + by Pierre Roux). diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index fb9965e43a..28b60878d2 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -250,11 +250,11 @@ proof by abstracting monomials by variables. `psatz`: a proof procedure for non-linear arithmetic ---------------------------------------------------- -.. tacn:: psatz @one_term {? @int_or_var } +.. tacn:: psatz @one_term {? @nat_or_var } :name: psatz This tactic explores the *Cone* by increasing degrees – hence the - depth parameter *n*. In theory, such a proof search is complete – if the + depth parameter :token:`nat_or_var`. In theory, such a proof search is complete – if the goal is provable the search eventually stops. Unfortunately, the external oracle is using numeric (approximate) optimization techniques that might miss a refutation. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 22527dc379..98445fca1a 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -405,7 +405,7 @@ Summary of the commands Shows the list of instances associated with the typeclass :token:`reference`. -.. tacn:: typeclasses eauto {? bfs } {? @int_or_var } {? with {+ @ident } } +.. tacn:: typeclasses eauto {? bfs } {? @nat_or_var } {? with {+ @ident } } This proof search tactic uses the resolution engine that is run implicitly during type checking. This tactic uses a different resolution @@ -445,11 +445,11 @@ Summary of the commands + Use the :cmd:`Typeclasses eauto` command to customize the behavior of this tactic. - :n:`@int_or_var` + :n:`@nat_or_var` Specifies the maximum depth of the search. .. warning:: - The semantics for the limit :n:`@int_or_var` + The semantics for the limit :n:`@nat_or_var` are different than for :tacn:`auto`. By default, if no limit is given, the search is unbounded. Unlike :tacn:`auto`, introduction steps count against the limit, which might result in larger limits being necessary when diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index f7ce7f1c6c..aa754ab63d 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -490,10 +490,10 @@ We need some infrastructure for that. Definition id {T} {t : T} (x : phantom t) := x. Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p) - (at level 50, v ident, only parsing). + (at level 50, v name, only parsing). Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p) - (at level 50, v ident, only parsing). + (at level 50, v name, only parsing). Notation "'Error : t : s" := (unify _ t (Some s)) (at level 50, format "''Error' : t : s"). diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 6464f085b8..2fc3c9f748 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -480,15 +480,15 @@ separately. They succeed only if there is a success for each goal. For example Do loop ~~~~~~~ -.. tacn:: do @int_or_var @ltac_expr3 +.. tacn:: do @nat_or_var @ltac_expr3 :name: do - The do loop repeats a tactic :token:`int_or_var` times: + The do loop repeats a tactic :token:`nat_or_var` times: - :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. This tactic - value ``v`` is applied :token:`int_or_var` times. Supposing :token:`int_or_var` > 1, after the + :n:`@ltac_expr` is evaluated to ``v``, which must be a tactic value. This tactic + value ``v`` is applied :token:`nat_or_var` times. If :token:`nat_or_var` > 1, after the first application of ``v``, ``v`` is applied, at least once, to the generated - subgoals and so on. It fails if the application of ``v`` fails before :token:`int_or_var` + subgoals and so on. It fails if the application of ``v`` fails before :token:`nat_or_var` applications have been completed. :tacn:`do` is an :token:`l3_tactic`. @@ -973,11 +973,11 @@ Timeout We can force a tactic to stop if it has not finished after a certain amount of time: -.. tacn:: timeout @int_or_var @ltac_expr3 +.. tacn:: timeout @nat_or_var @ltac_expr3 :name: timeout :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value - ``v`` is applied normally, except that it is interrupted after :n:`@natural` seconds + ``v`` is applied normally, except that it is interrupted after :n:`@nat_or_var` seconds if it is still running. In this case the outcome is a failure. :tacn:`timeout` is an :token:`l3_tactic`. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 26a56005c1..4f01559cad 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -878,38 +878,38 @@ Applying theorems This happens if the conclusion of :token:`ident` does not match any of the non-dependent premises of the type of :token:`term`. - .. tacv:: apply {+, @term} in @ident + .. tacv:: apply {+, @term} in {+, @ident} - This applies each :token:`term` in sequence in :token:`ident`. + This applies each :token:`term` in sequence in each hypothesis :token:`ident`. - .. tacv:: apply {+, @term with @bindings} in @ident + .. tacv:: apply {+, @term with @bindings} in {+, @ident} - This does the same but uses the bindings in each :n:`(@ident := @term)` to - instantiate the parameters of the corresponding type of :token:`term` - (see :ref:`bindings`). + This does the same but uses the bindings to instantiate + parameters of :token:`term` (see :ref:`bindings`). - .. tacv:: eapply {+, @term {? with @bindings } } in @ident + .. tacv:: eapply {+, @term {? with @bindings } } in {+, @ident} This works as :tacn:`apply … in` but turns unresolved bindings into existential variables, if any, instead of failing. - .. tacv:: apply {+, @term {? with @bindings } } in @ident as @simple_intropattern + .. tacv:: apply {+, @term {? with @bindings } } in {+, @ident {? as @simple_intropattern}} :name: apply … in … as - This works as :tacn:`apply … in` then applies the :token:`simple_intropattern` - to the hypothesis :token:`ident`. + This works as :tacn:`apply … in` but applying an associated + :token:`simple_intropattern` to each hypothesis :token:`ident` + that comes with such clause. - .. tacv:: simple apply @term in @ident + .. tacv:: simple apply @term in {+, @ident} This behaves like :tacn:`apply … in` but it reasons modulo conversion only on subterms that contain no variables to instantiate and does not traverse tuples. See :ref:`the corresponding example <simple_apply_ex>`. - .. tacv:: {? simple} apply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} - {? simple} eapply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} + .. tacv:: {? simple} apply {+, @term {? with @bindings}} in {+, @ident {? as @simple_intropattern}} + {? simple} eapply {+, @term {? with @bindings}} in {+, @ident {? as @simple_intropattern}} - This summarizes the different syntactic variants of :n:`apply @term in @ident` - and :n:`eapply @term in @ident`. + This summarizes the different syntactic variants of :n:`apply @term in {+, @ident}` + and :n:`eapply @term in {+, @ident}`. .. tacn:: constructor @natural :name: constructor diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 5283f60b11..9ec568c2c7 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -323,10 +323,12 @@ Performing computations | delta {? @delta_flag } ref_or_pattern_occ ::= @reference {? at @occs_nums } | @one_term {? at @occs_nums } - occs_nums ::= {+ {| @natural | @ident } } - | - {+ {| @natural | @ident } } + occs_nums ::= {+ @nat_or_var } + | - {+ @nat_or_var } int_or_var ::= @integer | @ident + nat_or_var ::= @natural + | @ident unfold_occ ::= @reference {? at @occs_nums } pattern_occ ::= @one_term {? at @occs_nums } diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 16c8586a9f..df73de846f 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -603,7 +603,7 @@ Here is the basic example of a notation using a binder: .. coqtop:: in Notation "'sigma' x : A , B" := (sigT (fun x : A => B)) - (at level 200, x ident, A at level 200, right associativity). + (at level 200, x name, A at level 200, right associativity). The binding variables in the right-hand side that occur as a parameter of the notation (here :g:`x`) dynamically bind all the occurrences @@ -616,8 +616,9 @@ application of the notation: Check sigma z : nat, z = 0. -Note the :n:`@syntax_modifier x ident` in the declaration of the -notation. It tells to parse :g:`x` as a single identifier. +Note the :n:`@syntax_modifier x name` in the declaration of the +notation. It tells to parse :g:`x` as a single identifier (or as the +unnamed variable :g:`_`). Binders bound in the notation and parsed as patterns ++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -655,7 +656,7 @@ variable. Here is an example showing the difference: Notation "'subset_bis' ' p , P" := (sig (fun p => P)) (at level 200, p strict pattern). Notation "'subset_bis' p , P " := (sig (fun p => P)) - (at level 200, p ident). + (at level 200, p name). .. coqtop:: all @@ -675,18 +676,19 @@ the following: .. coqdoc:: Notation "{ x : A | P }" := (sig (fun x : A => P)) - (at level 0, x at level 99 as ident). + (at level 0, x at level 99 as name). This is so because the grammar also contains rules starting with :g:`{}` and followed by a term, such as the rule for the notation :g:`{ A } + { B }` for the constant :g:`sumbool` (see :ref:`specification`). -Then, in the rule, ``x ident`` is replaced by ``x at level 99 as ident`` meaning +Then, in the rule, ``x name`` is replaced by ``x at level 99 as name`` meaning that ``x`` is parsed as a term at level 99 (as done in the notation for -:g:`sumbool`), but that this term has actually to be an identifier. +:g:`sumbool`), but that this term has actually to be a name, i.e. an +identifier or :g:`_`. The notation :g:`{ x | P }` is already defined in the standard -library with the ``as ident`` :n:`@syntax_modifier`. We cannot redefine it but +library with the ``as name`` :n:`@syntax_modifier`. We cannot redefine it but one can define an alternative notation, say :g:`{ p such that P }`, using instead ``as pattern``. @@ -702,12 +704,36 @@ Then, the following works: Check {(x,y) such that x+y=0}. To enforce that the pattern should not be used for printing when it -is just an identifier, one could have said +is just a name, one could have said ``p at level 99 as strict pattern``. -Note also that in the absence of a ``as ident``, ``as strict pattern`` or +Note also that in the absence of a ``as name``, ``as strict pattern`` or ``as pattern`` :n:`@syntax_modifier`\s, the default is to consider sub-expressions occurring -in binding position and parsed as terms to be ``as ident``. +in binding position and parsed as terms to be ``as name``. + +Binders bound in the notation and parsed as general binders ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +It is also possible to rely on Coq's syntax of binders using the +`binder` modifier as follows: + +.. coqtop:: in + + Notation "'myforall' p , [ P , Q ] " := (forall p, P -> Q) + (at level 200, p binder). + +In this case, all of :n:`@ident`, :n:`{@ident}`, :n:`[@ident]`, :n:`@ident:@type`, +:n:`{@ident:@type}`, :n:`[@ident:@type]`, :n:`'@pattern` can be used in place of +the corresponding notation variable. In particular, the binder can +declare implicit arguments: + +.. coqtop:: all + + Check fun (f : myforall {a}, [a=0, Prop]) => f eq_refl. + Check myforall '((x,y):nat*nat), [ x = y, True ]. + +By using instead `closed binder`, the same list of binders is allowed +except that :n:`@ident:@type` requires parentheses around. .. _NotationsWithBinders: @@ -744,7 +770,7 @@ binding position. Here is an example: Definition force n (P:nat -> Prop) := forall n', n' >= n -> P n'. Notation "▢_ n P" := (force n (fun n => P)) - (at level 0, n ident, P at level 9, format "▢_ n P"). + (at level 0, n name, P at level 9, format "▢_ n P"). .. coqtop:: all @@ -922,16 +948,31 @@ position of :g:`x`: (at level 10, f global, a1, an at level 9). In addition to ``global``, one can restrict the syntax of a -sub-expression by using the entry names ``ident`` or ``pattern`` +sub-expression by using the entry names ``ident``, ``name`` or ``pattern`` already seen in :ref:`NotationsWithBinders`, even when the corresponding expression is not used as a binder in the right-hand side. E.g.: + .. todo: these two Set Warnings and the note should be removed when + ident is reactivated with its literal meaning. + +.. coqtop:: none + + Set Warnings "-deprecated-ident-entry". + .. coqtop:: in Notation "'apply_id' f a1 .. an" := (.. (f a1) .. an) (at level 10, f ident, a1, an at level 9). +.. coqtop:: none + + Set Warnings "+deprecated-ident-entry". + +.. note:: As of version 8.13, the entry ``ident`` is a deprecated + alias for ``name``. In the future, it is planned to strictly + parse an identifier (excluding :g:`_`). + .. _custom-entries: Custom entries @@ -1089,6 +1130,31 @@ gives a way to let any arbitrary expression which is not handled by the custom entry ``expr`` be parsed or printed by the main grammar of term up to the insertion of a pair of curly brackets. +Another special situation is when parsing global references or +identifiers. To indicate that a custom entry should parse identifiers, +use the following form: + +.. coqtop:: none + + Reset Initial. + Declare Custom Entry expr. + +.. coqtop:: in + + Notation "x" := x (in custom expr at level 0, x ident). + +Similarly, to indicate that a custom entry should parse global references +(i.e. qualified or non qualified identifiers), use the following form: + +.. coqtop:: none + + Reset Initial. + Declare Custom Entry expr. + +.. coqtop:: in + + Notation "x" := x (in custom expr at level 0, x global). + .. cmd:: Print Custom Grammar @ident :name: Print Custom Grammar @@ -1118,6 +1184,7 @@ Here are the syntax elements used by the various notation commands. | only printing | format @string {? @string } explicit_subentry ::= ident + | name | global | bigint | strict pattern {? at level @natural } @@ -1127,6 +1194,7 @@ Here are the syntax elements used by the various notation commands. | custom @ident {? at @level } {? @binder_interp } | pattern {? at level @natural } binder_interp ::= as ident + | as name | as pattern | as strict pattern level ::= level @natural @@ -1164,6 +1232,27 @@ Here are the syntax elements used by the various notation commands. due to legacy notation in the Coq standard library. It can be turned on with the ``-w disj-pattern-notation`` flag. +.. note:: + + As of version 8.13, the entry ``ident`` is a deprecated alias for + ``name``. In the future, it is planned to strictly parse an + identifier (to the exclusion of :g:`_`). If the intent was to use + ``ident`` as an identifier (excluding :g:`_`), just silence the warning with + :n:`Set Warnings "-deprecated-ident-entry"` and it should automatically + get its intended meaning in version 8.15. + + Similarly, ``as ident`` is a deprecated alias for ``as name``, which + will only accept an identifier in the future. If the + intent was to use ``as ident`` as an identifier + (excluding :g:`_`), just silence the warning with + :n:`Set Warnings "-deprecated-as-ident-kind"`. + + However, this deprecation does not apply to custom entries, where it + already denotes an identifier, as expected. + + .. todo: the note above should be removed at the end of deprecation + phase of ident + .. .. _Scopes: Notation scopes diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 816acba4c1..4080eaae08 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -815,7 +815,10 @@ ltac_expr3: [ | REPLACE "abstract" ltac_expr2 "using" ident | WITH "abstract" ltac_expr2 OPT ( "using" ident ) | l3_tactic -| EDIT "do" ADD_OPT int_or_var ssrmmod ssrdotac ssrclauses TAG SSR +(* | EDIT "do" ADD_OPT nat_or_var ssrmmod ssrdotac ssrclauses TAG SSR *) +| DELETE "do" ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| DELETE "do" ssrortacarg ssrclauses (* SSR plugin *) +| DELETE "do" nat_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) | MOVEALLBUT ltac_builtins | l3_tactic | ltac_expr2 @@ -917,13 +920,13 @@ simple_tactic: [ | REPLACE "cofix" ident "with" LIST1 cofixdecl | WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) | DELETE "constructor" -| DELETE "constructor" int_or_var -| REPLACE "constructor" int_or_var "with" bindings -| WITH "constructor" OPT int_or_var OPT ( "with" bindings ) +| DELETE "constructor" nat_or_var +| REPLACE "constructor" nat_or_var "with" bindings +| WITH "constructor" OPT nat_or_var OPT ( "with" bindings ) | DELETE "econstructor" -| DELETE "econstructor" int_or_var -| REPLACE "econstructor" int_or_var "with" bindings -| WITH "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| DELETE "econstructor" nat_or_var +| REPLACE "econstructor" nat_or_var "with" bindings +| WITH "econstructor" OPT ( nat_or_var OPT ( "with" bindings ) ) | DELETE "dependent" "rewrite" orient constr | REPLACE "dependent" "rewrite" orient constr "in" hyp | WITH "dependent" "rewrite" orient constr OPT ( "in" hyp ) @@ -1042,12 +1045,12 @@ simple_tactic: [ | DELETE "finish_timing" OPT string | REPLACE "finish_timing" "(" string ")" OPT string | WITH "finish_timing" OPT ( "(" string ")" ) OPT string -| REPLACE "hresolve_core" "(" ident ":=" constr ")" "at" int_or_var "in" constr -| WITH "hresolve_core" "(" ident ":=" constr ")" OPT ( "at" int_or_var ) "in" constr +| REPLACE "hresolve_core" "(" ident ":=" constr ")" "at" nat_or_var "in" constr +| WITH "hresolve_core" "(" ident ":=" constr ")" OPT ( "at" nat_or_var ) "in" constr | DELETE "hresolve_core" "(" ident ":=" constr ")" "in" constr -| EDIT "psatz_R" ADD_OPT int_or_var tactic -| EDIT "psatz_Q" ADD_OPT int_or_var tactic -| EDIT "psatz_Z" ADD_OPT int_or_var tactic +| EDIT "psatz_R" ADD_OPT nat_or_var tactic +| EDIT "psatz_Q" ADD_OPT nat_or_var tactic +| EDIT "psatz_Z" ADD_OPT nat_or_var tactic | REPLACE "subst" LIST1 hyp | WITH "subst" LIST0 hyp | DELETE "subst" @@ -1064,11 +1067,11 @@ simple_tactic: [ | DELETE "transparent_abstract" tactic3 | REPLACE "transparent_abstract" tactic3 "using" ident | WITH "transparent_abstract" ltac_expr3 OPT ( "using" ident ) -| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 preident ) -| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident -| DELETE "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident -| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var -| DELETE "typeclasses" "eauto" OPT int_or_var +| "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 preident ) +| DELETE "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" "bfs" OPT nat_or_var +| DELETE "typeclasses" "eauto" OPT nat_or_var (* in Tactic Notation: *) | "setoid_replace" constr "with" constr OPT ( "using" "relation" constr ) OPT ( "in" hyp ) OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) @@ -1789,7 +1792,7 @@ tactic_notation_tactics: [ | "field_simplify_eq" OPT ( "[" LIST1 constr "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr5 (* todo: Not too keen on things like "with_power_flags" in tauto.ml, not easy to follow *) | "nsatz" OPT ( "with" "radicalmax" ":=" constr "strategy" ":=" constr "parameters" ":=" constr "variables" ":=" constr ) -| "psatz" constr OPT int_or_var +| "psatz" constr OPT nat_or_var | "ring" OPT ( "[" LIST1 constr "]" ) | "ring_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) (* todo: ident was "hyp", worth keeping? *) ] @@ -2536,7 +2539,6 @@ SPLICE: [ | by_arg_tac | by_tactic | quantified_hypothesis -| nat_or_var | in_hyp_list | rename | export_token diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 03a20d621b..d01f66c6d7 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1420,6 +1420,7 @@ syntax_modifiers: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "binder" @@ -1440,6 +1441,7 @@ at_level_opt: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1479,11 +1481,11 @@ simple_tactic: [ | "right" "with" bindings | "eright" "with" bindings | "constructor" -| "constructor" int_or_var -| "constructor" int_or_var "with" bindings +| "constructor" nat_or_var +| "constructor" nat_or_var "with" bindings | "econstructor" -| "econstructor" int_or_var -| "econstructor" int_or_var "with" bindings +| "econstructor" nat_or_var +| "econstructor" nat_or_var "with" bindings | "specialize" constr_with_bindings | "specialize" constr_with_bindings "as" simple_intropattern | "symmetry" @@ -1582,9 +1584,9 @@ simple_tactic: [ | "generalize_eqs_vars" hyp | "dependent" "generalize_eqs_vars" hyp | "specialize_eqs" hyp -| "hresolve_core" "(" ident ":=" constr ")" "at" int_or_var "in" constr +| "hresolve_core" "(" ident ":=" constr ")" "at" nat_or_var "in" constr | "hresolve_core" "(" ident ":=" constr ")" "in" constr -| "hget_evar" int_or_var +| "hget_evar" nat_or_var | "destauto" | "destauto" "in" hyp | "transparent_abstract" tactic3 @@ -1617,25 +1619,25 @@ simple_tactic: [ | "trivial" auto_using hintbases | "info_trivial" auto_using hintbases | "debug" "trivial" auto_using hintbases -| "auto" OPT int_or_var auto_using hintbases -| "info_auto" OPT int_or_var auto_using hintbases -| "debug" "auto" OPT int_or_var auto_using hintbases -| "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "new" "auto" OPT int_or_var auto_using hintbases -| "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "dfs" "eauto" OPT int_or_var auto_using hintbases -| "bfs" "eauto" OPT int_or_var auto_using hintbases +| "auto" OPT nat_or_var auto_using hintbases +| "info_auto" OPT nat_or_var auto_using hintbases +| "debug" "auto" OPT nat_or_var auto_using hintbases +| "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "new" "auto" OPT nat_or_var auto_using hintbases +| "debug" "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "info_eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "dfs" "eauto" OPT nat_or_var auto_using hintbases +| "bfs" "eauto" OPT nat_or_var auto_using hintbases | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" hyp | "autounfold_one" hintbases | "unify" constr constr | "unify" constr constr "with" preident | "convert_concl_no_check" constr -| "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident -| "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident -| "typeclasses" "eauto" "bfs" OPT int_or_var -| "typeclasses" "eauto" OPT int_or_var +| "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident +| "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident +| "typeclasses" "eauto" "bfs" OPT nat_or_var +| "typeclasses" "eauto" OPT nat_or_var | "head_of_constr" ident constr | "not_evar" constr | "is_ground" constr @@ -1734,7 +1736,7 @@ simple_tactic: [ | "restart_timer" OPT string | "finish_timing" OPT string | "finish_timing" "(" string ")" OPT string -| "psatz_Z" int_or_var tactic (* micromega plugin *) +| "psatz_Z" nat_or_var tactic (* micromega plugin *) | "psatz_Z" tactic (* micromega plugin *) | "xlia" tactic (* micromega plugin *) | "xnlia" tactic (* micromega plugin *) @@ -1745,9 +1747,9 @@ simple_tactic: [ | "sos_R" tactic (* micromega plugin *) | "lra_Q" tactic (* micromega plugin *) | "lra_R" tactic (* micromega plugin *) -| "psatz_R" int_or_var tactic (* micromega plugin *) +| "psatz_R" nat_or_var tactic (* micromega plugin *) | "psatz_R" tactic (* micromega plugin *) -| "psatz_Q" int_or_var tactic (* micromega plugin *) +| "psatz_Q" nat_or_var tactic (* micromega plugin *) | "psatz_Q" tactic (* micromega plugin *) | "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) @@ -2022,8 +2024,8 @@ ltac_expr4: [ ltac_expr3: [ | "try" ltac_expr3 -| "do" int_or_var ltac_expr3 -| "timeout" int_or_var ltac_expr3 +| "do" nat_or_var ltac_expr3 +| "timeout" nat_or_var ltac_expr3 | "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 @@ -2036,7 +2038,7 @@ ltac_expr3: [ | ltac_expr2 | "do" ssrmmod ssrdotac ssrclauses (* SSR plugin *) | "do" ssrortacarg ssrclauses (* SSR plugin *) -| "do" int_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| "do" nat_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) | "abstract" ssrdgens (* SSR plugin *) ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 0209cf762a..f62dd8f731 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -652,8 +652,8 @@ ref_or_pattern_occ: [ ] occs_nums: [ -| LIST1 [ natural | ident ] -| "-" LIST1 [ natural | ident ] +| LIST1 nat_or_var +| "-" LIST1 nat_or_var ] int_or_var: [ @@ -661,6 +661,11 @@ int_or_var: [ | ident ] +nat_or_var: [ +| natural +| ident +] + unfold_occ: [ | reference OPT ( "at" occs_nums ) ] @@ -1574,6 +1579,7 @@ syntax_modifier: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "strict" "pattern" OPT ( "at" "level" natural ) @@ -1586,6 +1592,7 @@ explicit_subentry: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1620,8 +1627,8 @@ simple_tactic: [ | "eleft" OPT ( "with" bindings ) | "right" OPT ( "with" bindings ) | "eright" OPT ( "with" bindings ) -| "constructor" OPT int_or_var OPT ( "with" bindings ) -| "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| "constructor" OPT nat_or_var OPT ( "with" bindings ) +| "econstructor" OPT ( nat_or_var OPT ( "with" bindings ) ) | "specialize" one_term OPT ( "with" bindings ) OPT ( "as" simple_intropattern ) | "symmetry" OPT ( "in" in_clause ) | "split" OPT ( "with" bindings ) @@ -1648,8 +1655,8 @@ simple_tactic: [ | bullet | "}" | "try" ltac_expr3 -| "do" int_or_var ltac_expr3 -| "timeout" int_or_var ltac_expr3 +| "do" nat_or_var ltac_expr3 +| "timeout" nat_or_var ltac_expr3 | "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 @@ -1658,8 +1665,6 @@ simple_tactic: [ | "infoH" ltac_expr3 | "abstract" ltac_expr2 OPT ( "using" ident ) | "only" selector ":" ltac_expr3 -| "do" "[" ssrortacs "]" OPT ssr_in (* SSR plugin *) -| "do" OPT int_or_var ssrmmod [ ltac_expr3 | "[" ssrortacs "]" (* SSR plugin *) ] OPT ssr_in (* SSR plugin *) | "tryif" ltac_expr "then" ltac_expr "else" ltac_expr2 | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" @@ -1718,8 +1723,8 @@ simple_tactic: [ | "generalize_eqs_vars" ident | "dependent" "generalize_eqs_vars" ident | "specialize_eqs" ident -| "hresolve_core" "(" ident ":=" one_term ")" OPT ( "at" int_or_var ) "in" one_term -| "hget_evar" int_or_var +| "hresolve_core" "(" ident ":=" one_term ")" OPT ( "at" nat_or_var ) "in" one_term +| "hget_evar" nat_or_var | "destauto" OPT ( "in" ident ) | "transparent_abstract" ltac_expr3 OPT ( "using" ident ) | "constr_eq" one_term one_term @@ -1756,20 +1761,20 @@ simple_tactic: [ | "trivial" OPT auto_using OPT hintbases | "info_trivial" OPT auto_using OPT hintbases | "debug" "trivial" OPT auto_using OPT hintbases -| "auto" OPT int_or_var OPT auto_using OPT hintbases -| "info_auto" OPT int_or_var OPT auto_using OPT hintbases -| "debug" "auto" OPT int_or_var OPT auto_using OPT hintbases -| "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "new" "auto" OPT int_or_var OPT auto_using OPT hintbases -| "debug" "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "info_eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "dfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases -| "bfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases +| "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "info_auto" OPT nat_or_var OPT auto_using OPT hintbases +| "debug" "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "new" "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "debug" "eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "info_eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "dfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "bfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases | "autounfold" OPT hintbases OPT clause_dft_concl | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) | "convert_concl_no_check" one_term -| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 ident ) +| "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 ident ) | "head_of_constr" ident one_term | "not_evar" one_term | "is_ground" one_term @@ -1859,7 +1864,7 @@ simple_tactic: [ | "functional" "inversion" [ ident | natural ] OPT qualid (* funind plugin *) | "functional" "induction" term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) | "soft" "functional" "induction" LIST1 one_term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) -| "psatz_Z" OPT int_or_var ltac_expr +| "psatz_Z" OPT nat_or_var ltac_expr | "xlia" ltac_expr (* micromega plugin *) | "xnlia" ltac_expr (* micromega plugin *) | "xnra" ltac_expr (* micromega plugin *) @@ -1869,8 +1874,8 @@ simple_tactic: [ | "sos_R" ltac_expr (* micromega plugin *) | "lra_Q" ltac_expr (* micromega plugin *) | "lra_R" ltac_expr (* micromega plugin *) -| "psatz_R" OPT int_or_var ltac_expr -| "psatz_Q" OPT int_or_var ltac_expr +| "psatz_R" OPT nat_or_var ltac_expr +| "psatz_Q" OPT nat_or_var ltac_expr | "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) | "zify_saturate" (* micromega plugin *) @@ -1942,7 +1947,7 @@ simple_tactic: [ | "field_simplify_eq" OPT ( "[" LIST1 one_term "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr | "nsatz" OPT ( "with" "radicalmax" ":=" one_term "strategy" ":=" one_term "parameters" ":=" one_term "variables" ":=" one_term ) -| "psatz" one_term OPT int_or_var +| "psatz" one_term OPT nat_or_var | "ring" OPT ( "[" LIST1 one_term "]" ) | "ring_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) | "match" ltac2_expr5 "with" OPT ltac2_branches "end" diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 4c7ed9047d..38ec668884 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -99,7 +99,7 @@ struct let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> - Control.timeout n t () (Exception Tac_Timeout) + Control.timeout n t () let make f = (); fun () -> try f () diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 7df29c6653..7784b38c80 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -74,7 +74,7 @@ module NonLogical : sig (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t - val timeout : int -> 'a t -> 'a t + val timeout : int -> 'a t -> 'a option t (** Construct a monadified side-effect. Exceptions raised by the argument are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index 978088872c..22863f451d 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -937,22 +937,12 @@ let tclTIMEOUT n t = Proof.get >>= fun initial -> Proof.current >>= fun envvar -> Proof.lift begin - Logic_monad.NonLogical.catch - begin - let open Logic_monad.NonLogical in - timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> - match r with - | Logic_monad.Nil e -> return (Util.Inr e) - | Logic_monad.Cons (r, _) -> return (Util.Inl r) - end - begin let open Logic_monad.NonLogical in function (e, info) -> - match e with - | Logic_monad.Tac_Timeout -> - return (Util.Inr (Logic_monad.Tac_Timeout, info)) - | Logic_monad.TacticFailure e -> - return (Util.Inr (e, info)) - | e -> Logic_monad.NonLogical.raise (e, info) - end + let open Logic_monad.NonLogical in + timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> + match r with + | None -> return (Util.Inr (Logic_monad.Tac_Timeout, Exninfo.null)) + | Some (Logic_monad.Nil e) -> return (Util.Inr e) + | Some (Logic_monad.Cons (r, _)) -> return (Util.Inl r) end >>= function | Util.Inl (res,s,m,i) -> Proof.set s >> diff --git a/engine/proofview.mli b/engine/proofview.mli index 816b45984b..fe0d7ae51e 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -417,7 +417,7 @@ end val tclCHECKINTERRUPT : unit tactic (** [tclTIMEOUT n t] can have only one success. - In case of timeout if fails with [tclZERO Timeout]. *) + In case of timeout it fails with [tclZERO Tac_Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 977cbbccf2..b3f06faa1c 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -83,6 +83,8 @@ type cases_pattern_expr_r = | CPatCast of cases_pattern_expr * constr_expr and cases_pattern_expr = cases_pattern_expr_r CAst.t +and kinded_cases_pattern_expr = cases_pattern_expr * Glob_term.binding_kind + and cases_pattern_notation_substitution = cases_pattern_expr list * (* for constr subterms *) cases_pattern_expr list list (* for recursive notations *) @@ -145,12 +147,12 @@ and recursion_order_expr = recursion_order_expr_r CAst.t and local_binder_expr = | CLocalAssum of lname list * binder_kind * constr_expr | CLocalDef of lname * constr_expr * constr_expr option - | CLocalPattern of (cases_pattern_expr * constr_expr option) CAst.t + | CLocalPattern of cases_pattern_expr and constr_notation_substitution = constr_expr list * (* for constr subterms *) constr_expr list list * (* for recursive notations *) - cases_pattern_expr list * (* for binders *) + kinded_cases_pattern_expr list * (* for binders *) local_binder_expr list list (* for binder lists (recursive notations) *) type constr_pattern_expr = constr_expr diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index efc2a35b65..a60dc11b57 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -94,6 +94,9 @@ and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = List.equal cases_pattern_expr_eq s1 s2 && List.equal (List.equal cases_pattern_expr_eq) n1 n2 +let kinded_cases_pattern_expr_eq (p1,bk1) (p2,bk2) = + cases_pattern_expr_eq p1 p2 && Glob_ops.binding_kind_eq bk1 bk2 + let eq_universes u1 u2 = match u1, u2 with | None, None -> true @@ -231,7 +234,7 @@ and local_binder_eq l1 l2 = match l1, l2 with and constr_notation_substitution_eq (e1, el1, b1, bl1) (e2, el2, b2, bl2) = List.equal constr_expr_eq e1 e2 && List.equal (List.equal constr_expr_eq) el1 el2 && - List.equal cases_pattern_expr_eq b1 b2 && + List.equal kinded_cases_pattern_expr_eq b1 b2 && List.equal (List.equal local_binder_eq) bl1 bl2 and instance_eq (x1,c1) (x2,c2) = @@ -268,39 +271,37 @@ let is_constructor id = (Nametab.locate_extended (qualid_of_ident id))) with Not_found -> false -let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with +let rec cases_pattern_fold_names f h nacc pt = match CAst.(pt.v) with | CPatRecord l -> - List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l - | CPatAlias (pat,{CAst.v=na}) -> Name.fold_right f na (cases_pattern_fold_names f a pat) + List.fold_left (fun nacc (r, cp) -> cases_pattern_fold_names f h nacc cp) nacc l + | CPatAlias (pat,{CAst.v=na}) -> Name.fold_right (fun na (n,acc) -> (f na n,acc)) na (cases_pattern_fold_names f h nacc pat) | CPatOr (patl) -> - List.fold_left (cases_pattern_fold_names f) a patl + List.fold_left (cases_pattern_fold_names f h) nacc patl | CPatCstr (_,patl1,patl2) -> - List.fold_left (cases_pattern_fold_names f) - (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 + List.fold_left (cases_pattern_fold_names f h) + (Option.fold_left (List.fold_left (cases_pattern_fold_names f h)) nacc patl1) patl2 | CPatNotation (_,_,(patl,patll),patl') -> - List.fold_left (cases_pattern_fold_names f) - (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' - | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat + List.fold_left (cases_pattern_fold_names f h) + (List.fold_left (cases_pattern_fold_names f h) nacc (patl@List.flatten patll)) patl' + | CPatDelimiters (_,pat) -> cases_pattern_fold_names f h nacc pat | CPatAtom (Some qid) when qualid_is_ident qid && not (is_constructor @@ qualid_basename qid) -> - f (qualid_basename qid) a - | CPatPrim _ | CPatAtom _ -> a - | CPatCast ({CAst.loc},_) -> - CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" - (Pp.strbrk "Casts are not supported here.") - -let ids_of_pattern = - cases_pattern_fold_names Id.Set.add Id.Set.empty - -let ids_of_pattern_list = - List.fold_left - (List.fold_left (cases_pattern_fold_names Id.Set.add)) - Id.Set.empty + let (n, acc) = nacc in + (f (qualid_basename qid) n, acc) + | CPatPrim _ | CPatAtom _ -> nacc + | CPatCast (p,t) -> + let (n, acc) = nacc in + cases_pattern_fold_names f h (n, h acc t) p + +let ids_of_pattern_list p = + fst (List.fold_left + (List.fold_left (cases_pattern_fold_names Id.Set.add (fun () _ -> ()))) + (Id.Set.empty,()) p) let ids_of_cases_tomatch tms = List.fold_right (fun (_, ona, indnal) l -> - Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + Option.fold_right (fun t ids -> fst (cases_pattern_fold_names Id.Set.add (fun () _ -> ()) (ids,()) t)) indnal (Option.fold_right (CAst.with_val (Name.fold_right Id.Set.add)) ona l)) tms Id.Set.empty @@ -312,9 +313,9 @@ let rec fold_local_binders g f n acc b = let open CAst in function f n (fold_local_binders g f n' acc b l) t | CLocalDef ( { v = na },c,t)::l -> Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t - | CLocalPattern { v = pat,t }::l -> - let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in - Option.fold_left (f n) acc t + | CLocalPattern pat :: l -> + let n, acc = cases_pattern_fold_names g (f n) (n,acc) pat in + fold_local_binders g f n acc b l | [] -> f n acc b @@ -378,10 +379,42 @@ let names_of_constr_expr c = let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) +let rec fold_map_cases_pattern f h acc (CAst.{v=pt;loc} as p) = match pt with + | CPatRecord l -> + let acc, l = List.fold_left_map (fun acc (r, cp) -> let acc, cp = fold_map_cases_pattern f h acc cp in acc, (r, cp)) acc l in + acc, CAst.make ?loc (CPatRecord l) + | CPatAlias (pat,({CAst.v=na} as lna)) -> + let acc, p = fold_map_cases_pattern f h acc pat in + let acc = Name.fold_right f na acc in + acc, CAst.make ?loc (CPatAlias (pat,lna)) + | CPatOr patl -> + let acc, patl = List.fold_left_map (fold_map_cases_pattern f h) acc patl in + acc, CAst.make ?loc (CPatOr patl) + | CPatCstr (c,patl1,patl2) -> + let acc, patl1 = Option.fold_left_map (List.fold_left_map (fold_map_cases_pattern f h)) acc patl1 in + let acc, patl2 = List.fold_left_map (fold_map_cases_pattern f h) acc patl2 in + acc, CAst.make ?loc (CPatCstr (c,patl1,patl2)) + | CPatNotation (sc,ntn,(patl,patll),patl') -> + let acc, patl = List.fold_left_map (fold_map_cases_pattern f h) acc patl in + let acc, patll = List.fold_left_map (List.fold_left_map (fold_map_cases_pattern f h)) acc patll in + let acc, patl' = List.fold_left_map (fold_map_cases_pattern f h) acc patl' in + acc, CAst.make ?loc (CPatNotation (sc,ntn,(patl,patll),patl')) + | CPatDelimiters (d,pat) -> + let acc, p = fold_map_cases_pattern f h acc pat in + acc, CAst.make ?loc (CPatDelimiters (d,pat)) + | CPatAtom (Some qid) + when qualid_is_ident qid && not (is_constructor @@ qualid_basename qid) -> + f (qualid_basename qid) acc, p + | CPatPrim _ | CPatAtom _ -> (acc,p) + | CPatCast (pat,t) -> + let acc, pat = fold_map_cases_pattern f h acc pat in + let t = h acc t in + acc, CAst.make ?loc (CPatCast (pat,t)) + (* Used in correctness and interface *) let map_binder g e nal = List.fold_right (CAst.with_val (Name.fold_right g)) nal e -let map_local_binders f g e bl = +let fold_map_local_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) let open CAst in let h (e,bl) = function @@ -389,9 +422,9 @@ let map_local_binders f g e bl = (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) | CLocalDef( { loc ; v = na } as cna ,c,ty) -> (Name.fold_right g na e, CLocalDef(cna,f e c,Option.map (f e) ty)::bl) - | CLocalPattern { loc; v = pat,t } -> - let ids = ids_of_pattern pat in - (Id.Set.fold g ids e, CLocalPattern (make ?loc (pat,Option.map (f e) t))::bl) in + | CLocalPattern pat -> + let e, pat = fold_map_cases_pattern g f e pat in + (e, CLocalPattern pat::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) @@ -400,16 +433,16 @@ let map_constr_expr_with_binders g f e = CAst.map (function | CApp ((p,a),l) -> CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) | CProdN (bl,b) -> - let (e,bl) = map_local_binders f g e bl in CProdN (bl,f e b) + let (e,bl) = fold_map_local_binders f g e bl in CProdN (bl,f e b) | CLambdaN (bl,b) -> - let (e,bl) = map_local_binders f g e bl in CLambdaN (bl,f e b) + let (e,bl) = fold_map_local_binders f g e bl in CLambdaN (bl,f e b) | CLetIn (na,a,t,b) -> CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (na.CAst.v) e) b) | CCast (a,c) -> CCast (f e a, Glob_ops.map_cast_type (f e) c) | CNotation (inscope,n,(l,ll,bl,bll)) -> (* This is an approximation because we don't know what binds what *) CNotation (inscope,n,(List.map (f e) l,List.map (List.map (f e)) ll, bl, - List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) + List.map (fun bl -> snd (fold_map_local_binders f g e bl)) bll)) | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) | CDelimiters (s,a) -> CDelimiters (s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ @@ -431,7 +464,7 @@ let map_constr_expr_with_binders g f e = CAst.map (function CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (id,dl) -> CFix (id,List.map (fun (id,n,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in + let (e',bl') = fold_map_local_binders f g e bl in let t' = f e' t in (* Note: fix names should be inserted before the arguments... *) let e'' = List.fold_left (fun e ({ CAst.v = id },_,_,_,_) -> g id e) e' dl in @@ -439,7 +472,7 @@ let map_constr_expr_with_binders g f e = CAst.map (function (id,n,bl',t',d')) dl) | CCoFix (id,dl) -> CCoFix (id,List.map (fun (id,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in + let (e',bl') = fold_map_local_binders f g e bl in let t' = f e' t in let e'' = List.fold_left (fun e ({ CAst.v = id },_,_,_) -> g id e) e' dl in let d' = f e'' d in @@ -472,7 +505,7 @@ let locs_of_notation ?loc locs ntn = let ntn_loc ?loc (args,argslist,binders,binderslist) = locs_of_notation ?loc (List.map constr_loc (args@List.flatten argslist)@ - List.map cases_pattern_expr_loc binders@ + List.map (fun (x,_) -> cases_pattern_expr_loc x) binders@ List.map local_binders_loc binderslist) let patntn_loc ?loc (args,argslist) = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8d3cf7274a..cf88036f73 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1126,7 +1126,7 @@ and factorize_prod ?impargs scopes vars na bk t c = let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = extern_typ scopes vars b in let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in - let binder = CLocalPattern (make ?loc:c.loc (p,None)) in + let binder = CLocalPattern p in (match b.v with | CProdN (bl,b) -> CProdN (binder::bl,b) | _ -> CProdN ([binder],b)) @@ -1167,7 +1167,7 @@ and factorize_lambda inctx scopes vars na bk t c = let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = sub_extern inctx scopes vars b in let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in - let binder = CLocalPattern (make ?loc:c.loc (p,None)) in + let binder = CLocalPattern p in (match b.v with | CLambdaN (bl,b) -> CLambdaN (binder::bl,b) | _ -> CLambdaN ([binder],b)) @@ -1219,7 +1219,10 @@ and extern_local_binder scopes vars = function if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in let p = mkCPatOr (List.map (extern_cases_pattern vars) p) in let (assums,ids,l) = extern_local_binder scopes vars l in - (assums,ids, CLocalPattern(CAst.make @@ (p,ty)) :: l) + let p = match ty with + | None -> p + | Some ty -> CAst.make @@ (CPatCast (p,ty)) in + (assums,ids, CLocalPattern p :: l) and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in @@ -1303,7 +1306,8 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = termlists in let bl = List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> - mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)) + (mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)), + Explicit) binders in let bll = List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c7ed066f7e..0645636255 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -298,21 +298,20 @@ let error_expect_binder_notation_type ?loc id = let set_var_scope ?loc id istermvar (tmp_scope,subscopes as scopes) ntnvars = try let used_as_binder,idscopes,typ = Id.Map.find id ntnvars in - if not istermvar then used_as_binder := true; - let () = if istermvar then + if istermvar then begin (* scopes have no effect on the interpretation of identifiers *) - begin match !idscopes with + (match !idscopes with | None -> idscopes := Some scopes | Some (tmp_scope', subscopes') -> let s' = make_current_scope tmp_scope' subscopes' in let s = make_current_scope tmp_scope subscopes in - if not (List.equal String.equal s' s) then error_inconsistent_scope ?loc id s' s + if not (List.equal String.equal s' s) then error_inconsistent_scope ?loc id s' s); + (match typ with + | Notation_term.NtnInternTypeOnlyBinder -> error_expect_binder_notation_type ?loc id + | Notation_term.NtnInternTypeAny -> ()) end - in - match typ with - | Notation_term.NtnInternTypeOnlyBinder -> - if istermvar then error_expect_binder_notation_type ?loc id - | Notation_term.NtnInternTypeAny -> () + else + used_as_binder := true with Not_found -> (* Not in a notation *) () @@ -587,7 +586,10 @@ let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = (push_name_env ntnvars impls env locna, (na,Explicit,term,ty)) -let intern_cases_pattern_as_binder ?loc test_kind ntnvars env p = +let intern_cases_pattern_as_binder intern test_kind ntnvars env bk (CAst.{v=p;loc} as pv) = + let p,t = match p with + | CPatCast (p, t) -> (p, Some t) + | _ -> (pv, None) in let il,disjpat = let (il, subst_disjpat) = !intern_cases_pattern_fwd test_kind ntnvars (env_for_pattern (reset_tmp_scope env)) p in let substl,disjpat = List.split subst_disjpat in @@ -595,12 +597,17 @@ let intern_cases_pattern_as_binder ?loc test_kind ntnvars env p = user_err ?loc (str "Unsupported nested \"as\" clause."); il,disjpat in - let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars [] env (make ?loc @@ Name id)) il env in let na = alias_of_pat (List.hd disjpat) in + let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars [] env (make ?loc @@ Name id)) il env in let ienv = Name.fold_right Id.Set.remove na env.ids in let id = Namegen.next_name_away_with_default "pat" na ienv in let na = make ?loc @@ Name id in - env,((disjpat,il),id),na + let t = match t with + | Some t -> t + | None -> CAst.make ?loc @@ CHole(Some (Evar_kinds.BinderType na.v),IntroAnonymous,None) in + let _, bl' = intern_assumption intern ntnvars env [na] (Default bk) t in + let {v=(_,bk,t)} = List.hd bl' in + env,((disjpat,il),id),na,bk,t let intern_local_binder_aux intern ntnvars (env,bl) = function | CLocalAssum(nal,bk,ty) -> @@ -610,17 +617,9 @@ let intern_local_binder_aux intern ntnvars (env,bl) = function | CLocalDef( {loc; v=na} as locna,def,ty) -> let env,(na,bk,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in env, (DAst.make ?loc @@ GLocalDef (na,bk,def,ty)) :: bl - | CLocalPattern {loc;v=(p,ty)} -> - let tyc = - match ty with - | Some ty -> ty - | None -> CAst.make ?loc @@ CHole(None,IntroAnonymous,None) - in - let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc test_kind_tolerant ntnvars env p in - let bk = Default Explicit in - let _, bl' = intern_assumption intern ntnvars env [na] bk tyc in - let {v=(_,bk,t)} = List.hd bl' in - (env, (DAst.make ?loc @@ GLocalPattern((disjpat,List.map (fun x -> x.v) il),id,bk,t)) :: bl) + | CLocalPattern p -> + let env, ((disjpat,il),id),na,bk,t = intern_cases_pattern_as_binder intern test_kind_tolerant ntnvars env Explicit p in + (env, (DAst.make ?loc:p.CAst.loc @@ GLocalPattern((disjpat,List.map (fun x -> x.v) il),id,bk,t)) :: bl) let intern_generalization intern env ntnvars loc bk ak c = let c = intern {env with unb = true} c in @@ -706,7 +705,7 @@ let is_patvar c = let is_patvar_store store pat = match DAst.get pat with - | PatVar na -> ignore(store na); true + | PatVar na -> ignore(store (CAst.make ?loc:pat.loc na)); true | _ -> false let out_patvar = CAst.map_with_loc (fun ?loc -> function @@ -715,37 +714,57 @@ let out_patvar = CAst.map_with_loc (fun ?loc -> function | CPatAtom None -> Anonymous | _ -> assert false) -let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function - | Anonymous -> (renaming,env), None, Anonymous +let canonize_type = function + | None -> None + | Some t as t' -> + match DAst.get t with + | GHole (Evar_kinds.BinderType _,IntroAnonymous,None) -> None + | _ -> t' + +let set_type ty1 ty2 = + match canonize_type ty1, canonize_type ty2 with + (* Not a meta-binding binder, we use the type given in the notation *) + | _, None -> ty1 + (* A meta-binding binder meta-bound to a possibly-typed pattern *) + (* the binder is supposed to come w/o an explicit type in the notation *) + | None, Some _ -> ty2 + | Some ty1, Some t2 -> + (* An explicitly typed meta-binding binder, not supposed to be a pattern; checked in interp_notation *) + user_err ?loc:t2.CAst.loc Pp.(str "Unexpected type constraint in notation already providing a type constraint.") + +let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) na ty = + match na with + | Anonymous -> (renaming,env), None, Anonymous, Explicit, set_type ty None | Name id -> let store,get = set_temporary_memory () in let test_kind = test_kind_tolerant in try (* We instantiate binder name with patterns which may be parsed as terms *) let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in - let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars env pat in + let env,((disjpat,ids),id),na,bk,t = intern_pat test_kind ntnvars env Explicit pat in let pat, na = match disjpat with | [pat] when is_patvar_store store pat -> let na = get () in None, na - | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in - (renaming,env), pat, na + | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na in + (renaming,env), pat, na.v, bk, set_type ty (Some t) with Not_found -> try (* Trying to associate a pattern *) - let pat,(onlyident,scopes) = Id.Map.find id binders in + let (pat,bk),(onlyident,scopes) = Id.Map.find id binders in let env = set_env_scopes env scopes in if onlyident then (* Do not try to interpret a variable as a constructor *) let na = out_patvar pat in let env = push_name_env ntnvars [] env na in - (renaming,env), None, na.v + let ty' = DAst.make @@ GHole (Evar_kinds.BinderType na.CAst.v,IntroAnonymous,None) in + (renaming,env), None, na.v, bk, set_type ty (Some ty') else (* Interpret as a pattern *) - let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars env pat in + let env,((disjpat,ids),id),na,bk,t = intern_pat test_kind ntnvars env bk pat in let pat, na = match disjpat with | [pat] when is_patvar_store store pat -> let na = get () in None, na - | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in - (renaming,env), pat, na + | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na in + (renaming,env), pat, na.v, bk, set_type ty (Some t) with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) @@ -753,7 +772,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let renaming' = if Id.equal id id' then renaming else Id.Map.add id id' renaming in - (renaming',env), None, Name id' + (renaming',env), None, Name id', Explicit, set_type ty None type binder_action = | AddLetIn of lname * constr_expr * constr_expr option @@ -878,12 +897,13 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = Id.Map.add id (gc, None) map with Nametab.GlobalizationError _ -> map in - let mk_env' (c, (onlyident,scopes)) = - let nenv = set_env_scopes env scopes in + let mk_env' ((c,_bk), (onlyident,(tmp_scope,subscopes))) = + let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in let test_kind = if onlyident then test_kind_ident_in_notation else test_kind_pattern_in_notation in - let _,((disjpat,_),_),_ = intern_pat test_kind ntnvars nenv c in + let _,((disjpat,_),_),_,_,_ty = intern_pat test_kind ntnvars nenv Explicit c in + (* TODO: use cast? *) match disjpat with | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () @@ -908,26 +928,15 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = aux (terms,None,Some (l,terminator,iter)) subinfos (NVar ldots_var) with Not_found -> anomaly (Pp.str "Inconsistent substitution of recursive notation.")) - | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> + | NProd (Name id, None, c') when option_mem_assoc id binderopt -> let binder = snd (Option.get binderopt) in expand_binders ?loc mkGProd [binder] (aux subst' (renaming,env) c') - | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> + | NLambda (Name id, None, c') when option_mem_assoc id binderopt -> let binder = snd (Option.get binderopt) in expand_binders ?loc mkGLambda [binder] (aux subst' (renaming,env) c') - (* Two special cases to keep binder name synchronous with BinderType *) - | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') - when Name.equal na na' -> - let subinfos,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in - let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - DAst.make ?loc @@ GProd (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) - | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') - when Name.equal na na' -> - let subinfos,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in - let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - DAst.make ?loc @@ GLambda (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) | t -> glob_constr_of_notation_constr_with_binders ?loc - (traverse_binder intern_pat ntnvars subst avoid) (aux subst') ~h:binder_status_fun subinfos t + (traverse_binder intern_pat ntnvars subst avoid) (aux subst') ~h:binder_status_fun subinfos t and subst_var (terms, binderopt, _terminopt) (renaming, env) id = (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) @@ -936,12 +945,13 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = intern (set_env_scopes env scopes) a with Not_found -> try - let pat,(onlyident,scopes) = Id.Map.find id binders in - let nenv = set_env_scopes env scopes in + let (pat,bk),(onlyident,scopes) = Id.Map.find id binders in + let env = set_env_scopes env scopes in let test_kind = if onlyident then test_kind_ident_in_notation else test_kind_pattern_in_notation in - let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars nenv pat in + let env,((disjpat,ids),id),na,bk,_ty = intern_pat test_kind ntnvars env bk pat in + (* TODO: use cast? *) match disjpat with | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") @@ -966,6 +976,9 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = into a substitution for interpretation and based on binding/constr distinction *) +let cases_pattern_of_id {loc;v=id} = + CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + let cases_pattern_of_name {loc;v=na} = let atom = match na with Name id -> Some (qualid_of_ident ?loc id) | Anonymous -> None in CAst.make ?loc (CPatAtom atom) @@ -981,16 +994,20 @@ let split_by_type ids subst = | NtnTypeConstr -> let terms,terms' = bind id scl terms terms' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder NtnBinderParsedAsConstr (AsIdentOrPattern | AsStrictPattern) -> + | NtnTypeBinder NtnBinderParsedAsConstr (AsNameOrPattern | AsStrictPattern) -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in - let binders' = Id.Map.add id (coerce_to_cases_pattern_expr a,(false,scl)) binders' in + let binders' = Id.Map.add id ((coerce_to_cases_pattern_expr a,Explicit),(false,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') | NtnTypeBinder NtnBinderParsedAsConstr AsIdent -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in - let binders' = Id.Map.add id (cases_pattern_of_name (coerce_to_name a),(true,scl)) binders' in + let binders' = Id.Map.add id ((cases_pattern_of_id (coerce_to_id a),Explicit),(true,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr AsName -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id ((cases_pattern_of_name (coerce_to_name a),Explicit),(true,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _ as x) -> - let onlyident = (x = NtnParsedAsIdent) in + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnParsedAsBinder as x) -> + let onlyident = (x = NtnParsedAsIdent || x = NtnParsedAsName) in let binders,binders' = bind id (onlyident,scl) binders binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') | NtnTypeConstrList -> @@ -1031,7 +1048,7 @@ let intern_notation intern env ntnvars loc ntn fullargs = (* Dispatch parsing substitution to an interpretation substitution *) let subst = split_by_type ids fullargs in (* Instantiate the notation *) - instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst (Id.Map.empty, env) c + instantiate_notation_constr loc intern (intern_cases_pattern_as_binder intern) ntnvars subst (Id.Map.empty, env) c (**********************************************************************) (* Discriminating between bound variables and global references *) @@ -1159,7 +1176,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = check_no_explicitation args1; let subst = split_by_type ids (List.map fst args1,[],[],[]) in let infos = (Id.Map.empty, env) in - let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in + let c = instantiate_notation_constr loc intern (intern_cases_pattern_as_binder intern) ntnvars subst infos c in let loc = c.loc in let err () = user_err ?loc (str "Notation " ++ pr_qualid qid diff --git a/interp/notation.ml b/interp/notation.ml index 286ece6cb6..c35ba44aa5 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -62,9 +62,11 @@ let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 let notation_binder_source_eq s1 s2 = match s1, s2 with | NtnParsedAsIdent, NtnParsedAsIdent -> true +| NtnParsedAsName, NtnParsedAsName -> true | NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 | NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 -| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _), _ -> false +| NtnParsedAsBinder, NtnParsedAsBinder -> true +| (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _ | NtnParsedAsBinder), _ -> false let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeConstr, NtnTypeConstr -> true diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index c4d2a2a496..036970ce37 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -131,7 +131,11 @@ let compare_notation_constr lt (vars1,vars2) t1 t2 = | NApp (t1, a1), NApp (t2, a2) -> aux vars renaming t1 t2; List.iter2 (aux vars renaming) a1 a2 | NLambda (na1, t1, u1), NLambda (na2, t2, u2) | NProd (na1, t1, u1), NProd (na2, t2, u2) -> - aux vars renaming t1 t2; + (match t1, t2 with + | None, None -> () + | Some _, None -> if lt then strictly_lt := true + | Some t1, Some t2 -> aux vars renaming t1 t2 + | None, Some _ -> raise Exit); let renaming = check_eq_name vars renaming na1 na2 in aux vars renaming u1 u2 | NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> @@ -272,11 +276,25 @@ let default_binder_status_fun = { slide = (fun x -> x); } +let test_implicit_argument_mark bk = + if not (Glob_ops.binding_kind_eq bk Explicit) then + user_err (Pp.str "Unexpected implicit argument mark.") + +let test_pattern_cast = function + | None -> () + | Some t -> user_err ?loc:t.CAst.loc (Pp.str "Unsupported pattern cast.") + let protect g e na = - let e',disjpat,na = g e na in + let e',disjpat,na,bk,t = g e na None in if disjpat <> None then user_err (Pp.str "Unsupported substitution of an arbitrary pattern."); + test_implicit_argument_mark bk; + test_pattern_cast t; e',na +let set_anonymous_type na = function + | None -> DAst.make @@ GHole (Evar_kinds.BinderType na, IntroAnonymous, None) + | Some t -> t + let apply_cases_pattern_term ?loc (ids,disjpat) tm c = let eqns = List.map (fun pat -> (CAst.make ?loc (ids,[pat],c))) disjpat in DAst.make ?loc @@ GCases (Constr.LetPatternStyle, None, [tm,(Anonymous,None)], eqns) @@ -302,15 +320,21 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> let e = h.switch_lambda e in - let e',disjpat,na = g e na in GLambda (na,Explicit,f (h.restart_prod e) ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + let ty = Option.map (f (h.restart_prod e)) ty in + let e',disjpat,na',bk,ty = g e na ty in + GLambda (na',bk,set_anonymous_type na ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NProd (na,ty,c) -> let e = h.switch_prod e in - let e',disjpat,na = g e na in GProd (na,Explicit,f (h.restart_prod e) ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + let ty = Option.map (f (h.restart_prod e)) ty in + let e',disjpat,na',bk,ty = g e na ty in + GProd (na',bk,set_anonymous_type na ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NLetIn (na,b,t,c) -> - let e',disjpat,na = g e na in + let t = Option.map (f (h.restart_prod e)) t in + let e',disjpat,na,bk,t = g e na t in + test_implicit_argument_mark bk; (match disjpat with - | None -> GLetIn (na,f (h.restart_lambda e) b,Option.map (f (h.restart_prod e)) t,f e' c) - | Some (disjpat,_id) -> DAst.get (apply_cases_pattern_term ?loc disjpat (f e b) (f e' c))) + | None -> GLetIn (na,f (h.restart_lambda e) b,t,f e' c) + | Some (disjpat,_id) -> test_pattern_cast t; DAst.get (apply_cases_pattern_term ?loc disjpat (f e b) (f e' c))) | NCases (sty,rtntypopt,tml,eqnl) -> let e = h.no e in let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> @@ -323,7 +347,11 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat e',Some (CAst.make ?loc (ind,nal')) in let e',na' = protect g e' na in (e',(f e tm,(na',t'))::tml')) tml (e,[]) in - let fold (idl,e) na = let (e,disjpat,na) = g e na in ((Name.cons na idl,e),disjpat,na) in + let fold (idl,e) na = + let (e,disjpat,na,bk,t) = g e na None in + test_implicit_argument_mark bk; + test_pattern_cast t; + ((Name.cons na idl,e),disjpat,na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in @@ -356,7 +384,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat let glob_constr_of_notation_constr ?loc x = let rec aux () x = - glob_constr_of_notation_constr_with_binders ?loc (fun () id -> ((),None,id)) aux () x + glob_constr_of_notation_constr_with_binders ?loc (fun () id t -> ((),None,id,Explicit,t)) aux () x in aux () x (******************************************************************************) @@ -551,8 +579,8 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GApp (g,args) -> (* Treat applicative notes as binary nodes *) let a,args = List.sep_last args in mkNApp1 (aux (DAst.make (GApp (g, args))), aux a) - | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) - | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) + | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux_type ty,aux c) + | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux_type ty,aux c) | GLetIn (na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) | GCases (sty,rtntypopt,tml,eqnl) -> let f {CAst.v=(idl,pat,rhs)} = List.iter (add_id found) idl; (pat,aux rhs) in @@ -589,6 +617,9 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") ) x + and aux_type t = DAst.with_val (function + | GHole (Evar_kinds.BinderType _,IntroAnonymous,None) -> None + | _ -> Some (aux t)) t in let t = aux a in (* Side effect *) @@ -697,13 +728,13 @@ let rec subst_notation_constr subst bound raw = NList (id1,id2,r1',r2',b) | NLambda (n,r1,r2) -> - let r1' = subst_notation_constr subst bound r1 + let r1' = Option.Smart.map (subst_notation_constr subst bound) r1 and r2' = subst_notation_constr subst bound r2 in if r1' == r1 && r2' == r2 then raw else NLambda (n,r1',r2') | NProd (n,r1,r2) -> - let r1' = subst_notation_constr subst bound r1 + let r1' = Option.Smart.map (subst_notation_constr subst bound) r1 and r2' = subst_notation_constr subst bound r2 in if r1' == r1 && r2' == r2 then raw else NProd (n,r1',r2') @@ -819,7 +850,7 @@ let abstract_return_type_context_glob_constr tml rtn = let abstract_return_type_context_notation_constr tml rtn = abstract_return_type_context snd - (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, IntroAnonymous, None),c)) tml rtn + (fun na c -> NLambda(na,None,c)) tml rtn let rec push_pattern_binders vars pat = match DAst.get pat with @@ -850,8 +881,9 @@ let is_onlybinding_meta id metas = let is_onlybinding_pattern_like_meta isvar id metas = try match Id.List.assoc id metas with | _,NtnTypeBinder (NtnBinderParsedAsConstr - (AsIdentOrPattern | AsStrictPattern)) -> true + (AsNameOrPattern | AsStrictPattern)) -> true | _,NtnTypeBinder (NtnParsedAsPattern strict) -> not (strict && isvar) + | _,NtnTypeBinder NtnParsedAsBinder -> not isvar | _ -> false with Not_found -> false @@ -1325,9 +1357,9 @@ let rec match_ inner u alp metas sigma a1 a2 = List.fold_left2 (match_ may_use_eta u alp metas) (match_hd u alp metas sigma f1 f2) l1 l2 | GLambda (na1,bk1,t1,b1), NLambda (na2,t2,b2) -> - match_extended_binders false u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 + match_extended_binders false u alp metas na1 na2 bk1 t1 (match_in_type u alp metas sigma t1 t2) b1 b2 | GProd (na1,bk1,t1,b1), NProd (na2,t2,b2) -> - match_extended_binders true u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 + match_extended_binders true u alp metas na1 na2 bk1 t1 (match_in_type u alp metas sigma t1 t2) b1 b2 | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) | GLetIn (na1,b1,None,c1), NLetIn (na2,b2,_,c2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma b1 b2) c1 c2 @@ -1396,14 +1428,14 @@ let rec match_ inner u alp metas sigma a1 a2 = otherwise how to ensure it corresponds to a well-typed eta-expansion; we make an exception for types which are metavariables: this is useful e.g. to print "{x:_ & P x}" knowing that notation "{x & P x}" is not defined. *) - | _b1, NLambda (Name id as na,(NHole _ | NVar _ as t2),b2) when inner -> + | _b1, NLambda (Name id as na,(None | Some (NVar _) as t2),b2) when inner -> let avoid = Id.Set.union (free_glob_vars a1) (* as in Namegen: *) (glob_visible_short_qualid a1) in let id' = Namegen.next_ident_away id avoid in let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),IntroAnonymous,None) in let sigma = match t2 with - | NHole _ -> sigma - | NVar id2 -> bind_term_env alp sigma id2 t1 + | None -> sigma + | Some (NVar id2) -> bind_term_env alp sigma id2 t1 | _ -> assert false in let (alp,sigma) = if is_bindinglist_meta id metas then @@ -1423,6 +1455,10 @@ let rec match_ inner u alp metas sigma a1 a2 = | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | GInt _ | GFloat _ | GArray _), _ -> raise No_match +and match_in_type u alp metas sigma t = function + | None -> sigma + | Some t' -> match_in u alp metas sigma t t' + and match_in u = match_ true u and match_hd u = match_ false u @@ -1497,7 +1533,7 @@ let match_notation_constr ~print_univ c ~vars (metas,pat) = let v = glob_constr_of_cases_pattern (Global.env()) pat in (((vars,v),scl)::terms',termlists',binders',binderlists') | _ -> raise No_match) - | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _) -> + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnParsedAsBinder) -> (terms',termlists',(Id.List.assoc x binders,scl)::binders',binderlists') | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists',binders',binderlists') diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 9d451a5bb9..e7a0429b35 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -53,7 +53,7 @@ val apply_cases_pattern : ?loc:Loc.t -> (Id.t list * cases_pattern_disjunction) * Id.t -> glob_constr -> glob_constr val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> - ('a -> Name.t -> 'a * ((Id.t list * cases_pattern_disjunction) * Id.t) option * Name.t) -> + ('a -> Name.t -> glob_constr option -> 'a * ((Id.t list * cases_pattern_disjunction) * Id.t) option * Name.t * Glob_term.binding_kind * glob_constr option) -> ('a -> notation_constr -> glob_constr) -> ?h:'a binder_status_fun -> 'a -> notation_constr -> glob_constr diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 82238b71b7..c541a19bfd 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -27,8 +27,8 @@ type notation_constr = | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool (* Part only in [glob_constr] *) - | NLambda of Name.t * notation_constr * notation_constr - | NProd of Name.t * notation_constr * notation_constr + | NLambda of Name.t * notation_constr option * notation_constr + | NProd of Name.t * notation_constr option * notation_constr | NBinderList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool | NLetIn of Name.t * notation_constr * notation_constr option * notation_constr | NCases of Constr.case_style * notation_constr option * @@ -67,7 +67,8 @@ type extended_subscopes = Constrexpr.notation_entry_level * subscopes type constr_as_binder_kind = | AsIdent - | AsIdentOrPattern + | AsName + | AsNameOrPattern | AsStrictPattern type notation_binder_source = @@ -76,8 +77,12 @@ type notation_binder_source = | NtnParsedAsPattern of bool (* This accepts only ident *) | NtnParsedAsIdent + (* This accepts only name *) + | NtnParsedAsName (* This accepts ident, or pattern, or both *) | NtnBinderParsedAsConstr of constr_as_binder_kind + (* This accepts ident, _, and quoted pattern *) + | NtnParsedAsBinder type notation_var_instance_type = | NtnTypeConstr | NtnTypeBinder of notation_binder_source | NtnTypeConstrList | NtnTypeBinderList diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 70be55f843..a953ca8898 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -37,6 +37,9 @@ let wit_pre_ident : string uniform_genarg_type = let wit_int_or_var = make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" +let wit_nat_or_var = + make0 ~dyn:(val_tag (topwit wit_nat)) "nat_or_var" + let wit_ident = make0 "ident" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index bd34af5543..0a8fdf53b1 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -35,6 +35,8 @@ val wit_pre_ident : string uniform_genarg_type val wit_int_or_var : (int or_var, int or_var, int) genarg_type +val wit_nat_or_var : (int or_var, int or_var, int) genarg_type + val wit_ident : Id.t uniform_genarg_type val wit_hyp : (lident, lident, Id.t) genarg_type diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 8990743de2..6255250218 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -716,8 +716,8 @@ value coq_interprete coq_extra_args = Long_val(sp[2]); sp += 3; } else { - /* The recursif argument is an accumulator */ - mlsize_t num_args, i; + /* The recursive argument is an accumulator */ + mlsize_t num_args, sz, i; value block; /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ Alloc_small(accu, rec_pos + 3, Closure_tag); @@ -732,11 +732,22 @@ value coq_interprete accu = block; /* Construction of the accumulator */ num_args = coq_extra_args - rec_pos; - Alloc_small(block, 3 + num_args, Closure_tag); + sz = 3 + num_args; + if (sz <= Max_young_wosize) { + Alloc_small(block, sz, Closure_tag); + Field(block, 2) = accu; + for (i = 3; i < sz; ++i) + Field(block, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + block = caml_alloc_shr(sz, Closure_tag); + caml_initialize(&Field(block, 2), accu); + for (i = 3; i < sz; ++i) + caml_initialize(&Field(block, i), *sp++); + } Code_val(block) = accumulate; Field(block, 1) = Val_int(2); - Field(block, 2) = accu; - for (i = 0; i < num_args; i++) Field(block, i + 3) = *sp++; accu = block; pc = (code_t)(sp[0]); coq_env = sp[1]; @@ -1130,13 +1141,25 @@ value coq_interprete /* Special operations for reduction of open term */ Instruct(ACCUMULATE) { - mlsize_t i, size; + mlsize_t i, size, sz; print_instr("ACCUMULATE"); size = Wosize_val(coq_env); - Alloc_small(accu, size + coq_extra_args + 1, Closure_tag); - for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); - for(i = size; i <= coq_extra_args + size; i++) - Field(accu, i) = *sp++; + sz = size + coq_extra_args + 1; + if (sz <= Max_young_wosize) { + Alloc_small(accu, sz, Closure_tag); + for (i = 0; i < size; ++i) + Field(accu, i) = Field(coq_env, i); + for (i = size; i < sz; ++i) + Field(accu, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + accu = caml_alloc_shr(sz, Closure_tag); + for (i = 0; i < size; ++i) + caml_initialize(&Field(accu, i), Field(coq_env, i)); + for (i = size; i < sz; ++i) + caml_initialize(&Field(accu, i), *sp++); + } pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -1240,13 +1263,24 @@ value coq_interprete Instruct(MAKEACCU) { - int i; + mlsize_t i, sz; print_instr("MAKEACCU"); - Alloc_small(accu, coq_extra_args + 4, Closure_tag); + sz = coq_extra_args + 4; + if (sz <= Max_young_wosize) { + Alloc_small(accu, sz, Closure_tag); + Field(accu, 2) = Field(coq_atom_tbl, *pc); + for (i = 3; i < sz; ++i) + Field(accu, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + accu = caml_alloc_shr(sz, Closure_tag); + caml_initialize(&Field(accu, 2), Field(coq_atom_tbl, *pc)); + for (i = 3; i < sz; ++i) + caml_initialize(&Field(accu, i), *sp++); + } Code_val(accu) = accumulate; Field(accu, 1) = Val_int(2); - Field(accu, 2) = Field(coq_atom_tbl, *pc); - for (i = 2; i < coq_extra_args + 3; i++) Field(accu, i + 1) = *sp++; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); diff --git a/lib/cErrors.ml b/lib/cErrors.ml index cb64e36755..760c07783b 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -37,7 +37,7 @@ let user_err ?loc ?info ?hdr strm = let info = Option.cata (Loc.add_loc info) info loc in Exninfo.iraise (UserError (hdr, strm), info) -exception Timeout +exception Timeout = Control.Timeout (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always @@ -135,7 +135,7 @@ let _ = register_handler begin function | UserError(s, pps) -> Some (where s ++ pps) | _ -> None -end + end (** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled @@ -145,7 +145,7 @@ end let noncritical = function | Sys.Break | Out_of_memory | Stack_overflow | Assert_failure _ | Match_failure _ | Anomaly _ - | Timeout -> false + | Control.Timeout -> false | Invalid_argument "equal: functional value" -> false | _ -> true [@@@ocaml.warning "+52"] diff --git a/lib/control.ml b/lib/control.ml index 95ea3935a7..7da95ff3dd 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -16,6 +16,8 @@ let steps = ref 0 let enable_thread_delay = ref false +exception Timeout + let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end; if !enable_thread_delay then begin @@ -27,8 +29,8 @@ let check_for_interrupt () = end (** This function does not work on windows, sigh... *) -let unix_timeout n f x e = - let timeout_handler _ = raise e in +let unix_timeout n f x = + let timeout_handler _ = raise Timeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in let _ = Unix.alarm n in let restore_timeout () = @@ -38,13 +40,13 @@ let unix_timeout n f x e = try let res = f x in restore_timeout (); - res - with e -> - let e = Exninfo.capture e in + Some res + with Timeout -> restore_timeout (); - Exninfo.iraise e + None + -let windows_timeout n f x e = +let windows_timeout n f x = let killed = ref false in let exited = ref false in let thread init = @@ -70,18 +72,18 @@ let windows_timeout n f x e = exited := true; raise Sys.Break end in - res + Some res with | Sys.Break -> (* Just in case, it could be a regular Ctrl+C *) if not !exited then begin killed := true; raise Sys.Break end - else raise e + else None | e -> let e = Exninfo.capture e in let () = killed := true in Exninfo.iraise e -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } @@ -90,7 +92,7 @@ let timeout_fun = match Sys.os_type with let timeout_fun_ref = ref timeout_fun let set_timeout f = timeout_fun_ref := f -let timeout n f e = !timeout_fun_ref.timeout n f e +let timeout n f = !timeout_fun_ref.timeout n f let protect_sigalrm f x = let timed_out = ref false in diff --git a/lib/control.mli b/lib/control.mli index 25135934bc..9465d8f0d5 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -10,6 +10,9 @@ (** Global control of Coq. *) +(** Used to convert signals to exceptions *) +exception Timeout + (** Will periodically call [Thread.delay] if set to true *) val enable_thread_delay : bool ref @@ -21,13 +24,13 @@ val check_for_interrupt : unit -> unit (** Use this function as a potential yield function. If {!interrupt} has been set, il will raise [Sys.Break]. *) -val timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b -(** [timeout n f x e] tries to compute [f x], and if it fails to do so - before [n] seconds, it raises [e] instead. *) +val timeout : int -> ('a -> 'b) -> 'a -> 'b option +(** [timeout n f x] tries to compute [Some (f x)], and if it fails to do so + before [n] seconds, returns [None] instead. *) (** Set a particular timeout function; warning, this is an internal API and it is scheduled to go away. *) -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } val set_timeout : timeout -> unit (** [protect_sigalrm f x] computes [f x], but if SIGALRM is received during that diff --git a/lib/envars.ml b/lib/envars.ml index c9c97eaa97..585d5185b4 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -181,5 +181,9 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sWARN=%s\n" prefix_var_name "-warn-error +a-3"; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); - fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) - + fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs); + fprintf f "%sCOQ_NATIVE_COMPILER_DEFAULT=%s\n" prefix_var_name + (match Coq_config.native_compiler with + | Coq_config.NativeOn {ondemand=false} -> "yes" + | Coq_config.NativeOff -> "no" + | Coq_config.NativeOn {ondemand=true} -> "ondemand") diff --git a/parsing/extend.ml b/parsing/extend.ml index a6fa6edad5..7d2ed9aed0 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -32,6 +32,7 @@ let production_level_eq lev1 lev2 = type 'a constr_entry_key_gen = | ETIdent + | ETName of bool (* Temporary: true = user told "name", false = user wrote "ident" *) | ETGlobal | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) @@ -55,9 +56,11 @@ type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm type constr_prod_entry_key = + | ETProdIdent (* Parsed as an ident *) | ETProdName (* Parsed as a name (ident or _) *) | ETProdReference (* Parsed as a global reference *) | ETProdBigint (* Parsed as an (unbounded) integer *) + | ETProdOneBinder of bool (* Parsed as name, or name:type or 'pattern, possibly in closed form *) | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) | ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *) diff --git a/parsing/extend.mli b/parsing/extend.mli index 057fdb3841..3cea45c3f5 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -27,6 +27,7 @@ val production_level_eq : production_level -> production_level -> bool type 'a constr_entry_key_gen = | ETIdent + | ETName of bool (* Temporary: true = user told "name", false = user wrote "ident" *) | ETGlobal | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) @@ -50,9 +51,11 @@ type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm type constr_prod_entry_key = + | ETProdIdent (* Parsed as an ident *) | ETProdName (* Parsed as a name (ident or _) *) | ETProdReference (* Parsed as a global reference *) | ETProdBigint (* Parsed as an (unbounded) integer *) + | ETProdOneBinder of bool (* Parsed as name, or name:type or 'pattern, possibly in closed form *) | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) | ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 67a061175a..68530178f8 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -39,6 +39,10 @@ let binder_of_name expl { CAst.loc = loc; v = na } = let binders_of_names l = List.map (binder_of_name Explicit) l +let pat_of_name CAst.{loc;v} = match v with +| Anonymous -> CAst.make ?loc @@ CPatAtom None +| Name id -> CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident id)) + let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) @@ -84,7 +88,8 @@ GRAMMAR EXTEND Gram universe_level universe_name sort sort_family global constr_pattern cpattern Constr.ident closed_binder open_binders binder binders binders_fixannot - record_declaration typeclass_constraint pattern arg type_cstr; + record_declaration typeclass_constraint pattern arg type_cstr + one_closed_binder one_open_binder; Constr.ident: [ [ id = Prim.ident -> { id } ] ] ; @@ -438,13 +443,20 @@ GRAMMAR EXTEND Gram { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (MaxImplicit, b), t)) tc } | "`["; tc = LIST1 typeclass_constraint SEP "," ; "]" -> { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (NonMaxImplicit, b), t)) tc } - | "'"; p = pattern LEVEL "0" -> - { let (p, ty) = - match p.CAst.v with - | CPatCast (p, ty) -> (p, Some ty) - | _ -> (p, None) - in - [CLocalPattern (CAst.make ~loc (p, ty))] } ] ] + | "'"; p = pattern LEVEL "0" -> { [CLocalPattern p] } ] ] + ; + one_open_binder: + [ [ na = name -> { (pat_of_name na, Explicit) } + | na = name; ":"; t = lconstr -> { (CAst.make ~loc @@ CPatCast (pat_of_name na, t), Explicit) } + | b = one_closed_binder -> { b } ] ] + ; + one_closed_binder: + [ [ "("; na = name; ":"; t = lconstr; ")" -> { (CAst.make ~loc @@ CPatCast (pat_of_name na, t), Explicit) } + | "{"; na = name; "}" -> { (pat_of_name na, MaxImplicit) } + | "{"; na = name; ":"; t = lconstr; "}" -> { (CAst.make ~loc @@ CPatCast (pat_of_name na, t), MaxImplicit) } + | "["; na = name; "]" -> { (pat_of_name na, NonMaxImplicit) } + | "["; na = name; ":"; t = lconstr; "]" -> { (CAst.make ~loc @@ CPatCast (pat_of_name na, t), NonMaxImplicit) } + | "'"; p = pattern LEVEL "0" -> { (p, Explicit) } ] ] ; typeclass_constraint: [ [ "!" ; c = term LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 22b5e70311..d49a49d242 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -327,6 +327,8 @@ module Constr = let binder = Entry.create "binder" let binders = Entry.create "binders" let open_binders = Entry.create "open_binders" + let one_open_binder = Entry.create "one_open_binder" + let one_closed_binder = Entry.create "one_closed_binder" let binders_fixannot = Entry.create "binders_fixannot" let typeclass_constraint = Entry.create "typeclass_constraint" let record_declaration = Entry.create "record_declaration" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index ce4c91d51f..d0ae594db1 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -203,6 +203,8 @@ module Constr : val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) val open_binders : local_binder_expr list Entry.t + val one_open_binder : kinded_cases_pattern_expr Entry.t + val one_closed_binder : kinded_cases_pattern_expr Entry.t val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t diff --git a/parsing/ppextend.ml b/parsing/ppextend.ml index aab385a707..b64c2b956a 100644 --- a/parsing/ppextend.ml +++ b/parsing/ppextend.ml @@ -36,9 +36,11 @@ let ppcmd_of_cut = function | PpFnl -> fnl () | PpBrk(n1,n2) -> brk(n1,n2) +type pattern_quote_style = QuotedPattern | NotQuotedPattern + type unparsing = | UnpMetaVar of entry_relative_level * Extend.side option - | UnpBinderMetaVar of entry_relative_level + | UnpBinderMetaVar of entry_relative_level * pattern_quote_style | UnpListMetaVar of entry_relative_level * unparsing list * Extend.side option | UnpBinderListMetaVar of bool * unparsing list | UnpTerminal of string @@ -50,7 +52,7 @@ type extra_unparsing_rules = (string * string) list let rec unparsing_eq unp1 unp2 = match (unp1,unp2) with | UnpMetaVar (p1,s1), UnpMetaVar (p2,s2) -> entry_relative_level_eq p1 p2 && s1 = s2 - | UnpBinderMetaVar p1, UnpBinderMetaVar p2 -> entry_relative_level_eq p1 p2 + | UnpBinderMetaVar (p1,s1), UnpBinderMetaVar (p2,s2) -> entry_relative_level_eq p1 p2 && s1 = s2 | UnpListMetaVar (p1,l1,s1), UnpListMetaVar (p2,l2,s2) -> entry_relative_level_eq p1 p2 && List.for_all2eq unparsing_eq l1 l2 && s1 = s2 | UnpBinderListMetaVar (b1,l1), UnpBinderListMetaVar (b2,l2) -> b1 = b2 && List.for_all2eq unparsing_eq l1 l2 | UnpTerminal s1, UnpTerminal s2 -> String.equal s1 s2 diff --git a/parsing/ppextend.mli b/parsing/ppextend.mli index 56a3fc8e3c..ca22aacacf 100644 --- a/parsing/ppextend.mli +++ b/parsing/ppextend.mli @@ -28,10 +28,12 @@ val ppcmd_of_cut : ppcut -> Pp.t (** {6 Printing rules for notations} *) +type pattern_quote_style = QuotedPattern | NotQuotedPattern + (** Declare and look for the printing rule for symbolic notations *) type unparsing = | UnpMetaVar of entry_relative_level * Extend.side option - | UnpBinderMetaVar of entry_relative_level + | UnpBinderMetaVar of entry_relative_level * pattern_quote_style | UnpListMetaVar of entry_relative_level * unparsing list * Extend.side option | UnpBinderListMetaVar of bool * unparsing list | UnpTerminal of string diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index b7ac71181a..e39c066c95 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -122,10 +122,10 @@ END TACTIC EXTEND constructor | [ "constructor" ] -> { Tactics.any_constructor false None } -| [ "constructor" int_or_var(i) ] -> { +| [ "constructor" nat_or_var(i) ] -> { Tactics.constructor_tac false None i NoBindings } -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "constructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac false None i bl in Tacticals.New.tclDELAYEDWITHHOLES false bl tac } @@ -133,10 +133,10 @@ END TACTIC EXTEND econstructor | [ "econstructor" ] -> { Tactics.any_constructor true None } -| [ "econstructor" int_or_var(i) ] -> { +| [ "econstructor" nat_or_var(i) ] -> { Tactics.constructor_tac true None i NoBindings } -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "econstructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac true None i bl in Tacticals.New.tclDELAYEDWITHHOLES true bl tac } diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index a2a47c0bf4..6ab82b1253 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -686,7 +686,7 @@ let hResolve_auto id c t = } TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" nat_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> { hResolve_auto id c t } END @@ -695,7 +695,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } +| [ "hget_evar" nat_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 7e8400910c..eed9419946 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -96,17 +96,17 @@ TACTIC EXTEND debug_trivial END TACTIC EXTEND auto -| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto n (eval_uconstrs ist lems) db } END TACTIC EXTEND info_auto -| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "info_auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_auto -| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "debug" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END @@ -130,15 +130,15 @@ let deprecated_bfs tacname = } TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> deprecated_eauto_bfs () | _ -> () ); Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) +TACTIC EXTEND new_eauto (* todo: name doesn't match syntax *) +| [ "new" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) @@ -146,7 +146,7 @@ TACTIC EXTEND new_eauto END TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "debug" "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> (deprecated_bfs "debug eauto") () | _ -> () ); @@ -154,7 +154,7 @@ TACTIC EXTEND debug_eauto END TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "info_eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> (deprecated_bfs "info_eauto") () | _ -> () ); @@ -162,13 +162,13 @@ TACTIC EXTEND info_eauto END TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "dfs" "eauto" nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END TACTIC EXTEND bfs_eauto -| [ "bfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "bfs" "eauto" nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { Eauto.gen_eauto (true, Eauto.make_depth p) (eval_uconstrs ist lems) db } END diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 8c2e633be5..0f59ac07b4 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -86,13 +86,13 @@ END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + | [ "typeclasses" "eauto" "bfs" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs l } - | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + | [ "typeclasses" "eauto" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d l } - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" "bfs" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs ~only_classes:true [Class_tactics.typeclasses_db] } - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~only_classes:true [Class_tactics.typeclasses_db] } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index c2e95c45f9..b1b96ea9a7 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -112,8 +112,8 @@ GRAMMAR EXTEND Gram | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA [ IDENT "try"; ta = ltac_expr -> { TacTry ta } - | IDENT "do"; n = int_or_var; ta = ltac_expr -> { TacDo (n,ta) } - | IDENT "timeout"; n = int_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } + | IDENT "do"; n = nat_or_var; ta = ltac_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = nat_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) } | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta } | IDENT "progress"; ta = ltac_expr -> { TacProgress ta } diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 072206c39c..43957bbde5 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -190,7 +190,7 @@ open Pvernac.Vernac_ GRAMMAR EXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr uconstr + bindings red_expr int_or_var nat_or_var open_constr uconstr simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: @@ -407,8 +407,8 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> { Some (id,ipat) } - | -> { None } ] ] + [ [ "in"; l = LIST1 [id = id_or_meta; ipat = as_ipat -> { (id,ipat) } ] SEP "," -> { l } + | -> { [] } ] ] ; orient_rw: [ [ "->" -> { true } diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 94e398fe5d..196a68e67c 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -29,6 +29,7 @@ let quantified_hypothesis = Entry.create "quantified_hypothesis" let destruction_arg = Entry.create "destruction_arg" let int_or_var = Entry.create "int_or_var" +let nat_or_var = Entry.create "nat_or_var" let simple_intropattern = Entry.create "simple_intropattern" let in_clause = Entry.create "in_clause" @@ -52,6 +53,7 @@ let () = let open Stdarg in let open Tacarg in register_grammar wit_int_or_var (int_or_var); + register_grammar wit_nat_or_var (nat_or_var); register_grammar wit_intro_pattern (simple_intropattern); (* To remove at end of deprecation phase *) (* register_grammar wit_intropattern (intropattern); *) (* To be added at end of deprecation phase *) register_grammar wit_simple_intropattern (simple_intropattern); diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 3a4a081c93..c0bf6b9f76 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -27,6 +27,7 @@ val uconstr : constr_expr Entry.t val quantified_hypothesis : quantified_hypothesis Entry.t val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Entry.t val int_or_var : int Locus.or_var Entry.t +val nat_or_var : int Locus.or_var Entry.t val simple_tactic : raw_tactic_expr Entry.t val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t val in_clause : Names.lident Locus.clause_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index edd56ee0f7..cd7b1f7f28 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -458,8 +458,7 @@ let string_of_genarg_arg (ArgumentType arg) = | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) let pr_in_hyp_as prc pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + | (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat let pr_in_clause pr_id = function | { onhyps=None; concl_occs=NoOccurrences } -> @@ -756,7 +755,7 @@ let pr_goal_selector ~toplevel s = (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp + prlist_with_sep spc (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index eaedf8d9c1..7b2c8e1d04 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -108,7 +108,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 50767821e4..2382dcfbb9 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -107,7 +107,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 47f1d3bf66..8bee7afa2c 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -444,11 +444,11 @@ let intern_red_expr ist = function | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (id,ipat) = - (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) - let intern_hyp_list ist = List.map (intern_hyp ist) +let intern_in_hyp_as ist lf (idl,ipat) = + (intern_hyp ist idl, Option.map (intern_intro_pattern lf ist) ipat) + let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,intern_hyp_list ist idl, @@ -527,7 +527,7 @@ let rec intern_atomic lf ist x = TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) | TacApply (a,ev,cb,inhyp) -> TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, - Option.map (intern_in_hyp_as ist lf) inhyp) + List.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -799,6 +799,7 @@ let intern_ltac ist tac = let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_nat_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_smart_global (lift intern_smart_global); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 3d734d3a66..00ac155f0e 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1667,10 +1667,10 @@ and interp_atomic ist tac : unit Proofview.tactic = (k,(make ?loc f))) cb in let sigma,tac = match cl with - | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l - | Some cl -> - let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev id l cl in + | [] -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | cl -> + let sigma,cl = List.fold_left_map (interp_in_hyp_as ist env) sigma cl in + sigma, List.fold_right (fun (id,ipat) -> Tactics.apply_delayed_in a ev id l ipat) cl Tacticals.New.tclIDTAC in Tacticals.New.tclWITHHOLES ev tac sigma end end @@ -2099,6 +2099,7 @@ let interp_pre_ident ist env sigma s = let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_nat_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_smart_global (lift interp_reference); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_pre_ident (lift interp_pre_ident); diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index ec44ae4698..90546ea939 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -128,7 +128,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb, + List.map (on_snd (Option.map (subst_intro_pattern subst))) cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) @@ -278,6 +279,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_nat_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_smart_global subst_global_reference; Genintern.register_subst0 wit_pre_ident (fun _ v -> v); diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 40eea91b31..852a485329 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -29,7 +29,7 @@ open Tacarg DECLARE PLUGIN "micromega_plugin" TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i +| [ "psatz_Z" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Z" tactic(t)] -> { (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) } @@ -74,12 +74,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_R" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_R" tactic(t) ] -> { (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_Q" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } END diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index ccdf5fa68e..f06b460ee9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1792,7 +1792,7 @@ GRAMMAR EXTEND Gram { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex Once tac clauses } - | IDENT "do"; n = int_or_var; m = ssrmmod; + | IDENT "do"; n = nat_or_var; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc (mk_index ~loc n) m tac clauses } ] ]; diff --git a/plugins/ssrsearch/g_search.mlg b/plugins/ssrsearch/g_search.mlg index 54fdea0860..74535a10d3 100644 --- a/plugins/ssrsearch/g_search.mlg +++ b/plugins/ssrsearch/g_search.mlg @@ -141,7 +141,7 @@ let interp_search_notation ?loc tag okey = let rec sub () = function | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) | c -> - glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in + glob_constr_of_notation_constr_with_binders ?loc (fun _ x t -> (), None, x, Explicit, t) sub () c in let _, npat = Patternops.pattern_of_glob_constr (sub () body) in Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,npat) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c352a6ac1f..1c24578a1c 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1944,7 +1944,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = try (* First try finding a subterm w/o conversion on open terms *) let flags = set_no_delta_open_flags flags in w_unify_to_subterm env evd ~flags t' - with e -> + with e when CErrors.noncritical e -> (* If this fails, try with full conversion *) w_unify_to_subterm env evd ~flags t' else w_unify_to_subterm env evd ~flags t' diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index e312c68b7d..8942bc7805 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -98,10 +98,10 @@ let tag_var = tag Tag.variable let pp2 = aux l in let pp1 = pr (if parens && side <> None then LevelLe 0 else prec) c in return unp pp1 pp2 - | UnpBinderMetaVar prec as unp :: l -> - let c = pop bl in + | UnpBinderMetaVar (prec,style) as unp :: l -> + let c,bk = pop bl in let pp2 = aux l in - let pp1 = pr_patt prec c in + let pp1 = pr_patt prec style bk c in return unp pp1 pp2 | UnpListMetaVar (prec, sl, side) as unp :: l -> let cl = pop envlist in @@ -273,28 +273,29 @@ let tag_var = tag Tag.variable let las = lapp let lpator = 0 let lpatrec = 0 + let lpatcast = LevelLe 100 let lpattop = LevelLe 200 - let rec pr_patt sep inh p = + let rec pr_patt sep pr inh p = let (strm,prec) = match CAst.(p.v) with | CPatRecord l -> - pr_record_body "{|" "|}" (pr_patt spc lpattop) l, lpatrec + pr_record_body "{|" "|}" (pr_patt spc pr lpattop) l, lpatrec | CPatAlias (p, na) -> - pr_patt mt (LevelLe las) p ++ str " as " ++ pr_lname na, las + pr_patt mt pr (LevelLe las) p ++ str " as " ++ pr_lname na, las | CPatCstr (c, None, []) -> pr_reference c, latom | CPatCstr (c, None, args) -> - pr_reference c ++ prlist (pr_patt spc (LevelLt lapp)) args, lapp + pr_reference c ++ prlist (pr_patt spc pr (LevelLt lapp)) args, lapp | CPatCstr (c, Some args, []) -> - str "@" ++ pr_reference c ++ prlist (pr_patt spc (LevelLt lapp)) args, lapp + str "@" ++ pr_reference c ++ prlist (pr_patt spc pr (LevelLt lapp)) args, lapp | CPatCstr (c, Some expl_args, extra_args) -> - surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (LevelLt lapp)) expl_args) - ++ prlist (pr_patt spc (LevelLt lapp)) extra_args, lapp + surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc pr (LevelLt lapp)) expl_args) + ++ prlist (pr_patt spc pr (LevelLt lapp)) extra_args, lapp | CPatAtom (None) -> str "_", latom @@ -303,25 +304,25 @@ let tag_var = tag Tag.variable pr_reference r, latom | CPatOr pl -> - let pp p = hov 0 (pr_patt mt lpattop p) in + let pp p = hov 0 (pr_patt mt pr lpattop p) in surround (hov 0 (prlist_with_sep pr_spcbar pp pl)), lpator | CPatNotation (_,(_,"( _ )"),([p],[]),[]) -> - pr_patt (fun()->str"(") lpattop p ++ str")", latom + pr_patt (fun()->str"(") pr lpattop p ++ str")", latom | CPatNotation (which,s,(l,ll),args) -> - let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ -> mt ()) (fun _ _ _ -> mt()) which s (l,ll,[],[]) in + let strm_not, l_not = pr_notation (pr_patt mt pr) (fun _ _ _ _ -> mt ()) (fun _ _ _ -> mt()) which s (l,ll,[],[]) in (if List.is_empty args||prec_less l_not (LevelLt lapp) then strm_not else surround strm_not) - ++ prlist (pr_patt spc (LevelLt lapp)) args, if not (List.is_empty args) then lapp else l_not + ++ prlist (pr_patt spc pr (LevelLt lapp)) args, if not (List.is_empty args) then lapp else l_not | CPatPrim p -> pr_prim_token p, latom | CPatDelimiters (k,p) -> - pr_delimiters k (pr_patt mt lsimplepatt p), 1 + pr_delimiters k (pr_patt mt pr lsimplepatt p), 1 - | CPatCast _ -> - assert false + | CPatCast (p,t) -> + (pr_patt mt pr lpatcast p ++ spc () ++ str ":" ++ ws 1 ++ pr t), 1 in let loc = p.CAst.loc in pr_with_comments ?loc @@ -329,12 +330,21 @@ let tag_var = tag Tag.variable let pr_patt = pr_patt mt + let pr_patt_binder pr prec style bk c = + match bk with + | MaxImplicit -> str "{" ++ pr_patt pr lpattop c ++ str "}" + | NonMaxImplicit -> str "[" ++ pr_patt pr lpattop c ++ str "]" + | Explicit -> + match style, c with + | NotQuotedPattern, _ | _, {v=CPatAtom _} -> pr_patt pr prec c + | QuotedPattern, _ -> str "'" ++ pr_patt pr prec c + let pr_eqn pr {loc;v=(pl,rhs)} = spc() ++ hov 4 (pr_with_comments ?loc (str "| " ++ hov 0 (prlist_with_sep pr_spcbar - (fun p -> hov 0 (prlist_with_sep sep_v (pr_patt ltop) p)) pl + (fun p -> hov 0 (prlist_with_sep sep_v (pr_patt (pr ltop) ltop) p)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) @@ -391,13 +401,8 @@ let tag_var = tag Tag.variable surround (pr_lname na ++ pr_opt_no_spc (fun t -> str " :" ++ ws 1 ++ pr_c t) topt ++ str" :=" ++ spc() ++ pr_c c) - | CLocalPattern {CAst.loc; v = p,tyo} -> - let p = pr_patt lsimplepatt p in - match tyo with - | None -> - str "'" ++ p - | Some ty -> - str "'" ++ surround (p ++ spc () ++ str ":" ++ ws 1 ++ pr_c ty) + | CLocalPattern p -> + str "'" ++ pr_patt pr_c lsimplepatt p let pr_undelimited_binders sep pr_c = prlist_with_sep sep (pr_binder_among_many pr_c) @@ -459,16 +464,16 @@ let tag_var = tag Tag.variable (pr_decl "with" true) dl ++ fnl() ++ keyword "for" ++ spc () ++ pr_id id - let pr_asin pr na indnalopt = + let pr_as_in pr na indnalopt = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) | Some na -> spc () ++ keyword "as" ++ spc () ++ pr_lname na | None -> mt ()) ++ (match indnalopt with | None -> mt () - | Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt lsimplepatt t) + | Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt pr lsimplepatt t) let pr_case_item pr (tm,as_clause, in_clause) = - hov 0 (pr (LevelLe lcast) tm ++ pr_asin pr as_clause in_clause) + hov 0 (pr (LevelLe lcast) tm ++ pr_as_in (pr ltop) as_clause in_clause) let pr_case_type pr po = match po with @@ -601,8 +606,8 @@ let tag_var = tag Tag.variable return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ - hov 0 (pr_patt ltop p ++ - pr_asin (pr_dangling_with_for mt pr) as_clause in_clause ++ + hov 0 (pr_patt (pr mt ltop) ltop p ++ + pr_as_in (pr mt ltop) as_clause in_clause ++ str " :=" ++ pr spc ltop c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ spc () ++ keyword "in" ++ pr spc ltop b)), @@ -673,7 +678,7 @@ let tag_var = tag Tag.variable | CNotation (_,(_,"( _ )"),([t],[],[],[])) -> return (pr (fun()->str"(") ltop t ++ str")", latom) | CNotation (which,s,env) -> - pr_notation (pr mt) pr_patt (pr_binders_gen (pr mt ltop)) which s env + pr_notation (pr mt) (pr_patt_binder (pr mt ltop)) (pr_binders_gen (pr mt ltop)) which s env | CGeneralization (bk,ak,c) -> return (pr_generalization bk ak (pr mt ltop c), latom) | CPrim p -> @@ -737,7 +742,7 @@ let tag_var = tag Tag.variable let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c - let pr_cases_pattern_expr = pr_patt ltop + let pr_cases_pattern_expr = pr_patt (pr ltop) ltop let pr_binders env sigma = pr_undelimited_binders spc (pr_expr env sigma ltop) diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index b2ebc61b4e..9bf765717f 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -433,7 +433,8 @@ let match_goals ot nt = constr_expr ogname c c2; constr_expr_opt ogname t t2 | CLocalPattern p, CLocalPattern p2 -> - let (p,ty), (p2,ty2) = p.v,p2.v in + let ty = match p.v with CPatCast (_,ty) -> Some ty | _ -> None in + let ty2 = match p2.v with CPatCast (_,ty) -> Some ty | _ -> None in constr_expr_opt ogname ty ty2 | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (2)") in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e3369bc9be..8b38bc1b0a 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2635,7 +2635,7 @@ let assert_as first hd ipat t = (* apply in as *) let general_apply_in ?(respect_opaque=false) with_delta - with_destruct with_evars id lemmas ipat = + with_destruct with_evars id lemmas ipat then_tac = let tac (naming,lemma) tac id = apply_in_delayed_once ~respect_opaque with_delta with_destruct with_evars naming id lemma tac in @@ -2653,7 +2653,8 @@ let general_apply_in ?(respect_opaque=false) with_delta List.map (fun lem -> (NamingMustBe (CAst.make id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) - List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id + List.fold_right tac lemmas_target + (tac last_lemma_target (fun id -> Tacticals.New.tclTHEN (ipat_tac id) then_tac)) id end (* @@ -2666,10 +2667,10 @@ let general_apply_in ?(respect_opaque=false) with_delta let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in - general_apply_in simple simple with_evars id lemmas ipat + general_apply_in simple simple with_evars id lemmas ipat Tacticals.New.tclIDTAC -let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat +let apply_delayed_in simple with_evars id lemmas ipat then_tac = + general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat then_tac (*****************************) (* Tactics abstracting terms *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 54c781af5c..0fd2f1253f 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -233,7 +233,7 @@ val apply_in : val apply_delayed_in : advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> - intro_pattern option -> unit Proofview.tactic + intro_pattern option -> unit Proofview.tactic -> unit Proofview.tactic (** {6 Elimination tactics. } *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 279f32c903..245c717d42 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -144,6 +144,7 @@ bugs: $(BUGS) clean: rm -f trace .csdp.cache .nia.cache .lia.cache output/MExtraction.out rm -f vos/Makefile vos/Makefile.conf + rm -f misc/universes/all_stdlib.v $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.log' -o -name '*.glob' \ @@ -252,7 +253,12 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + (echo "\ + bugs/closed/bug_3783.v \ + bugs/closed/bug_4157.v \ + bugs/closed/bug_5127.v \ + " | grep -q "$<") && no_native="-native-compiler no"; \ + $(coqc) $$no_native "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -649,7 +655,7 @@ misc: $(patsubst %.sh,%.log,$(wildcard misc/*.sh)) misc/universes.log: misc/universes/all_stdlib.v misc/universes/all_stdlib.v: - cd .. && $(MAKE) test-suite/$@ + cd misc/universes && ./build_all_stdlib.sh > all_stdlib.v $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) @echo "TEST $<" diff --git a/test-suite/bugs/closed/bug_9517.v b/test-suite/bugs/closed/bug_9517.v index bb43edbe74..93ed94df39 100644 --- a/test-suite/bugs/closed/bug_9517.v +++ b/test-suite/bugs/closed/bug_9517.v @@ -2,6 +2,7 @@ Declare Custom Entry expr. Declare Custom Entry stmt. Notation "x" := x (in custom stmt, x ident). Notation "x" := x (in custom expr, x ident). +Notation "'_'" := _ (in custom expr). Notation "1" := 1 (in custom expr). diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh index 88237815b1..d878b13ce6 100755 --- a/test-suite/coq-makefile/coqdoc1/run.sh +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -21,6 +21,10 @@ make install-doc DSTROOT="$PWD/tmp" sort -u > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test_plugin.cmi ./test/test_plugin.cmx ./test/test_plugin.cmxa @@ -29,6 +33,10 @@ sort -u > desired <<EOT ./test/test.v ./test/test.vo ./test/sub +./test/sub/.coq-native +./test/sub/.coq-native/Ntest_sub_testsub.cmi +./test/sub/.coq-native/Ntest_sub_testsub.cmx +./test/sub/.coq-native/Ntest_sub_testsub.cmxs ./test/sub/testsub.glob ./test/sub/testsub.v ./test/sub/testsub.vo @@ -56,4 +64,5 @@ sort -u > desired <<EOT ./test/html/coqdoc.css ./test/html/test.test.html EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh index 5811dd17e4..757667e8bd 100755 --- a/test-suite/coq-makefile/coqdoc2/run.sh +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -19,6 +19,10 @@ make install-doc DSTROOT="$PWD/tmp" sort -u > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test_plugin.cmi ./test/test_plugin.cmx ./test/test_plugin.cmxa @@ -27,6 +31,10 @@ sort -u > desired <<EOT ./test/test.v ./test/test.vo ./test/sub +./test/sub/.coq-native +./test/sub/.coq-native/Ntest_sub_testsub.cmi +./test/sub/.coq-native/Ntest_sub_testsub.cmx +./test/sub/.coq-native/Ntest_sub_testsub.cmxs ./test/sub/testsub.glob ./test/sub/testsub.v ./test/sub/testsub.vo @@ -54,4 +62,5 @@ sort -u > desired <<EOT ./test/html/coqdoc.css ./test/html/test.test.html EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh index bbd2fc460c..113a862d97 100755 --- a/test-suite/coq-makefile/mlpack1/run.sh +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -12,6 +12,10 @@ make install DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test_plugin.cmi ./test/test_plugin.cmx @@ -20,4 +24,5 @@ sort > desired <<EOT ./test/test.v ./test/test.vo EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh index bbd2fc460c..113a862d97 100755 --- a/test-suite/coq-makefile/mlpack2/run.sh +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -12,6 +12,10 @@ make install DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test_plugin.cmi ./test/test_plugin.cmx @@ -20,4 +24,5 @@ sort > desired <<EOT ./test/test.v ./test/test.vo EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/multiroot/run.sh b/test-suite/coq-makefile/multiroot/run.sh index 45bf1481df..be0d04f93d 100755 --- a/test-suite/coq-makefile/multiroot/run.sh +++ b/test-suite/coq-makefile/multiroot/run.sh @@ -20,6 +20,10 @@ make install-doc DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test.cmi ./test/test.cmx @@ -30,6 +34,10 @@ sort > desired <<EOT ./test/test.v ./test/test.vo ./test2 +./test2/.coq-native +./test2/.coq-native/Ntest2_test.cmi +./test2/.coq-native/Ntest2_test.cmx +./test2/.coq-native/Ntest2_test.cmxs ./test2/test.glob ./test2/test.v ./test2/test.vo @@ -58,4 +66,5 @@ sort > desired <<EOT ./orphan_test_test2_test/mlihtml/type_Test_aux.html ./orphan_test_test2_test/mlihtml/type_Test.html EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 3ffe831b3c..5dd36757be 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -1,6 +1,6 @@ #!/usr/bin/env bash -NONATIVECOMP=$(grep "let native_compiler = false" ../../../config/coq_config.ml)||true +NONATIVECOMP=$(grep "let native_compiler = NativeOff" ../../../config/coq_config.ml)||true if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then . ../template/init.sh diff --git a/test-suite/coq-makefile/native2/run.sh b/test-suite/coq-makefile/native2/run.sh index aaae81630f..47befc50c3 100755 --- a/test-suite/coq-makefile/native2/run.sh +++ b/test-suite/coq-makefile/native2/run.sh @@ -1,6 +1,6 @@ #!/usr/bin/env bash -NONATIVECOMP=$(grep "let native_compiler = false" ../../../config/coq_config.ml)||true +NONATIVECOMP=$(grep "let native_compiler = NativeOff" ../../../config/coq_config.ml)||true if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then . ../template/init.sh diff --git a/test-suite/coq-makefile/plugin1/run.sh b/test-suite/coq-makefile/plugin1/run.sh index 1e2bd979b3..f69e8c1b8c 100755 --- a/test-suite/coq-makefile/plugin1/run.sh +++ b/test-suite/coq-makefile/plugin1/run.sh @@ -13,6 +13,10 @@ make install DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test.cmi ./test/test.cmx @@ -23,4 +27,5 @@ sort > desired <<EOT ./test/test.v ./test/test.vo EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin2/run.sh b/test-suite/coq-makefile/plugin2/run.sh index 1e2bd979b3..f69e8c1b8c 100755 --- a/test-suite/coq-makefile/plugin2/run.sh +++ b/test-suite/coq-makefile/plugin2/run.sh @@ -13,6 +13,10 @@ make install DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test.cmi ./test/test.cmx @@ -23,4 +27,5 @@ sort > desired <<EOT ./test/test.v ./test/test.vo EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin3/run.sh b/test-suite/coq-makefile/plugin3/run.sh index 1e2bd979b3..f69e8c1b8c 100755 --- a/test-suite/coq-makefile/plugin3/run.sh +++ b/test-suite/coq-makefile/plugin3/run.sh @@ -13,6 +13,10 @@ make install DSTROOT="$PWD/tmp" sort > desired <<EOT . ./test +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs ./test/test.glob ./test/test.cmi ./test/test.cmx @@ -23,4 +27,5 @@ sort > desired <<EOT ./test/test.v ./test/test.vo EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/\.coq-native/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index ed5a4f93f5..426c9ea53f 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -3,6 +3,9 @@ #set -x set -e +NONATIVECOMP=$(grep "let native_compiler = NativeOff" ../../../config/coq_config.ml)||true +if [[ ! $NONATIVECOMP ]]; then exit 0 ; fi + . ../template/path-init.sh # reset MAKEFLAGS so that, e.g., `make -C test-suite -B coq-makefile` doesn't give us issues diff --git a/test-suite/coq-makefile/uninstall1/run.sh b/test-suite/coq-makefile/uninstall1/run.sh index fc95d84b9a..0f05acd072 100755 --- a/test-suite/coq-makefile/uninstall1/run.sh +++ b/test-suite/coq-makefile/uninstall1/run.sh @@ -19,5 +19,8 @@ make uninstall-doc DSTROOT="$PWD/tmp" ) | sort -u > actual sort -u > desired <<EOT . +./test +./test/sub EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/test/d' desired exec diff -u desired actual diff --git a/test-suite/coq-makefile/uninstall2/run.sh b/test-suite/coq-makefile/uninstall2/run.sh index fc95d84b9a..0f05acd072 100755 --- a/test-suite/coq-makefile/uninstall2/run.sh +++ b/test-suite/coq-makefile/uninstall2/run.sh @@ -19,5 +19,8 @@ make uninstall-doc DSTROOT="$PWD/tmp" ) | sort -u > actual sort -u > desired <<EOT . +./test +./test/sub EOT +(coqc -config | grep -q "NATIVE_COMPILER_DEFAULT=yes") || sed -i.bak '/test/d' desired exec diff -u desired actual diff --git a/test-suite/misc/11170.sh b/test-suite/misc/11170.sh new file mode 100755 index 0000000000..da8843fcf6 --- /dev/null +++ b/test-suite/misc/11170.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +set -e + +export PATH=$BIN:$PATH +export OCAMLRUNPARAM=s=1 + +${coqc#"$BIN"} misc/aux11170.v diff --git a/test-suite/misc/aux11170.v b/test-suite/misc/aux11170.v new file mode 100644 index 0000000000..d4a8630053 --- /dev/null +++ b/test-suite/misc/aux11170.v @@ -0,0 +1,6 @@ +Fixpoint T n := match n with O => nat | S n => nat -> T n end. +Fixpoint app n : T n -> nat := + match n with O => fun x => x | S n => fun f => app n (f 0) end. +Definition n := (fix aux n := match n with S n => aux n + aux n | O => 1 end) 13. +Axiom f : T n. +Eval vm_compute in let t := (app n f, 0) in snd t. diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index bcb2468792..05712eaac7 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -62,7 +62,7 @@ Check `(∀ n p : A, n=p). Notation "'let'' f x .. y := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) - (f ident, x closed binder, y closed binder, at level 200, + (f name, x closed binder, y closed binder, at level 200, right associativity). Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. @@ -93,7 +93,7 @@ End A. Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) - (f ident, x closed binder, y closed binder, at level 200, + (f name, x closed binder, y closed binder, at level 200, right associativity). Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. @@ -104,7 +104,7 @@ Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. (* Old request mentioned again on coq-club 20/1/2012 *) Notation "# x : T => t" := (fun x : T => t) - (at level 0, t at level 200, x ident). + (at level 0, t at level 200, x name). Check # x : nat => x. Check # _ : nat => 2. @@ -116,7 +116,7 @@ Parameters (A : Set) (x y : A) (Q : A -> A -> Prop) (conj : Q x y). Check (exist (Q x) y conj). (* Check bug #4854 *) -Notation "% i" := (fun i : nat => i) (at level 0, i ident). +Notation "% i" := (fun i : nat => i) (at level 0, i name). Check %i. Check %j. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 04a91c14d9..6c714fc624 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -305,7 +305,7 @@ Module E. Inductive myex2 {A:Type} (P Q:A -> Prop) : Prop := myex_intro2 : forall x:A, P x -> Q x -> myex2 P Q. Notation "'myexists2' x : A , p & q" := (myex2 (A:=A) (fun x => p) (fun x => q)) - (at level 200, x ident, A at level 200, p at level 200, right associativity, + (at level 200, x name, A at level 200, p at level 200, right associativity, format "'[' 'myexists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. Check myex2 (fun x => let '(y,z) := x in y>z) (fun x => let '(y,z) := x in z>y). diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 86c4b3cccc..df64ae2af3 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -197,3 +197,15 @@ Found an inductive type while a pattern was expected. : nat * nat %%% : Type +## (x, _) (x = 0) + : Prop +The command has indeed failed with message: +Unexpected type constraint in notation already providing a type constraint. +## '(x, y) (x + y = 0) + : Prop +## x (x = 0) + : Prop +## '(x, y) (x = 0) + : Prop +fun f : ## a (a = 0) => f 1 eq_refl + : ## a (a = 0) -> 1 = 0 diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 6af192ea82..ce488fe18d 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -327,6 +327,7 @@ Module P. Module NotationMixedTermBinderAsIdent. + Set Warnings "-deprecated-ident-entry". (* We do want ident! *) Notation "▢_ n P" := (pseudo_force n (fun n => P)) (at level 0, n ident, P at level 9, format "▢_ n P"). Check exists p, ▢_p (p >= 1). @@ -487,3 +488,21 @@ Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) Check %%%. End MorePrecise3. + +Module TypedPattern. + +Notation "## x P" := (forall x:nat*nat, P) (x pattern, at level 0). +Check ## (x,y) (x=0). +Fail Check ## ((x,y):bool*bool) (x=y). + +End TypedPattern. + +Module SingleBinder. + +Notation "## x P" := (forall x, x = x -> P) (x binder, at level 0). +Check ## '(x,y) (x+y=0). +Check ## (x:nat) (x=0). +Check ## '((x,y):nat*nat) (x=0). +Check fun (f : ## {a} (a=0)) => f (a:=1) eq_refl. + +End SingleBinder. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index e1df9ba84a..8c4b567106 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -530,6 +530,16 @@ rewrite H0. change (x+0=0). Abort. +Goal (forall x y, x <= y -> y + x = 0 /\ True) -> exists x y, (x <= 0 -> y <= 1 -> 0 = 0 /\ 1 = 0). +intros. +do 2 eexists. +intros. +eapply H in H0 as (H0,_), H1 as (H1,_). +split. +- exact H0. +- exact H1. +Qed. + (* 2nd order apply used to have delta on local definitions even though it does not have delta on global definitions; keep it by compatibility while finding a more uniform way to proceed. *) @@ -582,3 +592,22 @@ intros. eexists ?[p]. split. rewrite H. reflexivity. exact H0. Qed. + +(* apply and side conditions: we check that apply in iterates only on + the main subgoals *) + +Goal (forall x, x=0 -> x>=0 -> x<=0 \/ x<=1) -> 0>=0 -> 1>=0 -> 1=0 -> True. +intros f H H0 H1. +apply f in H as [], H0 as []. +1-3: change (0 <= 0) in H. +4-6: change (0 <= 1) in H. +1: change (1 <= 0) in H0. +4: change (1 <= 0) in H0. +2: change (1 <= 1) in H0. +5: change (1 <= 1) in H0. +1-2,4-5: exact I. +1,2: exact H1. +change (0 >= 0) in H. +change (1 >= 0) in H0. +exact (eq_refl 0). +Qed. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 023705e169..5247c7b56a 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -309,9 +309,9 @@ Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) : type_scope. Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) - (at level 200, x ident, p at level 200, right associativity) : type_scope. + (at level 200, x name, p at level 200, right associativity) : type_scope. Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) - (at level 200, x ident, A at level 200, p at level 200, right associativity, + (at level 200, x name, A at level 200, p at level 200, right associativity, format "'[' 'exists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. @@ -489,18 +489,18 @@ Module EqNotations. := (match H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, + (at level 10, H' at level 10, y name, p name, format "'[' 'rew' 'dependent' [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' -> [ 'fun' y p => P ] H 'in' H'" := (match H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, only parsing). + (at level 10, H' at level 10, y name, p name, only parsing). Notation "'rew' 'dependent' <- [ 'fun' y p => P ] H 'in' H'" := (match eq_sym H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, + (at level 10, H' at level 10, y name, p name, format "'[' 'rew' 'dependent' <- [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' [ P ] H 'in' H'" := (match H as p in (_ = y) return P y p with diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 84d40035bf..1a2c4ba171 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -96,19 +96,19 @@ Module Generic. (* begin hide *) (* Notations used in the proof. Hidden in coqdoc. *) -Reserved Notation "'∀₁' x : A , B" (at level 200, x ident, A at level 200,right associativity). +Reserved Notation "'∀₁' x : A , B" (at level 200, x name, A at level 200,right associativity). Reserved Notation "A '⟶₁' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₁' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'λ₁' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₁' x" (at level 5, left associativity). -Reserved Notation "'∀₂' A , F" (at level 200, A ident, right associativity). -Reserved Notation "'λ₂' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'∀₂' A , F" (at level 200, A name, right associativity). +Reserved Notation "'λ₂' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity). -Reserved Notation "'∀₀' x : A , B" (at level 200, x ident, A at level 200,right associativity). +Reserved Notation "'∀₀' x : A , B" (at level 200, x name, A at level 200,right associativity). Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₀' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'λ₀' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₀' x" (at level 5, left associativity). -Reserved Notation "'∀₀¹' A : U , F" (at level 200, A ident, right associativity). -Reserved Notation "'λ₀¹' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'∀₀¹' A : U , F" (at level 200, A name, right associativity). +Reserved Notation "'λ₀¹' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity). (* end hide *) diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index 9c8508bf39..b2bdd8099a 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -18,7 +18,7 @@ Set Implicit Arguments. Notation "{ ( x , y ) : A | P }" := (sig (fun anonymous : A => let (x,y) := anonymous in P)) - (x ident, y ident, at level 10) : type_scope. + (x name, y name, at level 10) : type_scope. Declare Scope program_scope. Delimit Scope program_scope with prg. diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index d1cefeb552..a563dcbf95 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -335,19 +335,19 @@ Reserved Notation "[ 'predType' 'of' T ]" (at level 0, Reserved Notation "[ 'pred' : T | E ]" (at level 0, format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x | E ]" (at level 0, x name, format "'[hv' [ 'pred' x | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x name, format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). -Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). -Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, @@ -363,17 +363,17 @@ Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). -Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A ] ']'"). Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). diff --git a/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v index d0508bef2e..dc81b5cca7 100644 --- a/theories/ssr/ssreflect.v +++ b/theories/ssr/ssreflect.v @@ -110,7 +110,7 @@ Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, c, R, vT, vF at level 200). Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, - c, R, vT, vF at level 200, x ident). + c, R, vT, vF at level 200, x name). Reserved Notation "x : T" (at level 100, right associativity, format "'[hv' x '/ ' : T ']'"). diff --git a/theories/ssr/ssrfun.v b/theories/ssr/ssrfun.v index e1442e1da2..ba66e04e4a 100644 --- a/theories/ssr/ssrfun.v +++ b/theories/ssr/ssrfun.v @@ -236,19 +236,19 @@ Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). Reserved Notation "[ 'fun' : T => E ]" (at level 0, format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). + x name, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x : T => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). + x name, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, - x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + x name, y name, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). Reserved Notation "f =1 g" (at level 70, no associativity). Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). @@ -259,33 +259,33 @@ Reserved Notation "f \; g" (at level 60, right associativity, format "f \; '/ ' g"). Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a >-> r }"). + x name, format "{ 'morph' f : x / a >-> r }"). Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a }"). + x name, format "{ 'morph' f : x / a }"). Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). + x name, y name, format "{ 'morph' f : x y / a >-> r }"). Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a }"). + x name, y name, format "{ 'morph' f : x y / a }"). Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a >-> r }"). + x name, format "{ 'homo' f : x / a >-> r }"). Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a }"). + x name, format "{ 'homo' f : x / a }"). Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). + x name, y name, format "{ 'homo' f : x y / a >-> r }"). Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a }"). + x name, y name, format "{ 'homo' f : x y / a }"). Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y /~ a }"). + x name, y name, format "{ 'homo' f : x y /~ a }"). Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a >-> r }"). + x name, format "{ 'mono' f : x / a >-> r }"). Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a }"). + x name, format "{ 'mono' f : x / a }"). Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). + x name, y name, format "{ 'mono' f : x y / a >-> r }"). Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a }"). + x name, y name, format "{ 'mono' f : x y / a }"). Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y /~ a }"). + x name, y name, format "{ 'mono' f : x y /~ a }"). Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index c6ccf2a427..ec339c69c6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -36,7 +36,8 @@ let set_type_in_type () = type color = [`ON | `AUTO | `EMACS | `OFF] -type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type native_compiler = Coq_config.native_compiler = + NativeOff | NativeOn of { ondemand : bool } type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; @@ -96,10 +97,7 @@ type t = { let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) -let default_native = - if Coq_config.native_compiler - then NativeOn {ondemand=true} - else NativeOff +let default_native = Coq_config.native_compiler let default_logic_config = { impredicative_set = Declarations.PredicativeSet; @@ -301,7 +299,7 @@ let get_native_compiler s = | ("no" | "off") -> NativeOff | _ -> error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in - if not Coq_config.native_compiler && n <> NativeOff then + if Coq_config.native_compiler = NativeOff && n <> NativeOff then let () = warn_no_native_compiler s in NativeOff else diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index c8634b7847..f6222e4ec4 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -12,7 +12,8 @@ type color = [`ON | `AUTO | `EMACS | `OFF] val default_toplevel : Names.DirPath.t -type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type native_compiler = Coq_config.native_compiler = + NativeOff | NativeOn of { ondemand : bool } type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 9ca38d64df..69758b3f37 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -106,7 +106,7 @@ let apply adv ev cb cl = | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb | Some (id, cl) -> let cl = Option.map mk_intro_pattern cl in - Tactics.apply_delayed_in adv ev id cb cl + Tactics.apply_delayed_in adv ev id cb cl Tacticals.New.tclIDTAC let mk_destruction_arg = function | ElimOnConstr c -> diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index efe4e17d0b..9fe3e2f7ab 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -246,9 +246,11 @@ type _ target = type prod_info = production_level * production_position type (_, _) entry = +| TTIdent : ('self, lident) entry | TTName : ('self, lname) entry | TTReference : ('self, qualid) entry | TTBigint : ('self, string) entry +| TTBinder : bool -> ('self, kinded_cases_pattern_expr) entry | TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry | TTConstrList : notation_entry * prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry | TTPattern : int -> ('self, cases_pattern_expr) entry @@ -363,21 +365,29 @@ let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = | TTPattern p -> MayRecNo (Pcoq.Symbol.nterml Constr.pattern (string_of_int p)) | TTClosedBinderList [] -> MayRecNo (Pcoq.Symbol.list1 (Pcoq.Symbol.nterm Constr.binder)) | TTClosedBinderList tkl -> MayRecNo (Pcoq.Symbol.list1sep (Pcoq.Symbol.nterm Constr.binder) (make_sep_rules tkl) false) +| TTIdent -> MayRecNo (Pcoq.Symbol.nterm Prim.identref) | TTName -> MayRecNo (Pcoq.Symbol.nterm Prim.name) +| TTBinder true -> MayRecNo (Pcoq.Symbol.nterm Constr.one_open_binder) +| TTBinder false -> MayRecNo (Pcoq.Symbol.nterm Constr.one_closed_binder) | TTOpenBinderList -> MayRecNo (Pcoq.Symbol.nterm Constr.open_binders) | TTBigint -> MayRecNo (Pcoq.Symbol.nterm Prim.bignat) | TTReference -> MayRecNo (Pcoq.Symbol.nterm Constr.global) let interp_entry forpat e = match e with +| ETProdIdent -> TTAny TTIdent | ETProdName -> TTAny TTName | ETProdReference -> TTAny TTReference | ETProdBigint -> TTAny TTBigint +| ETProdOneBinder o -> TTAny (TTBinder o) | ETProdConstr (s,p) -> TTAny (TTConstr (s, p, forpat)) | ETProdPattern p -> TTAny (TTPattern p) | ETProdConstrList (s, p, tkl) -> TTAny (TTConstrList (s, p, tkl, forpat)) | ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList | ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl) +let cases_pattern_expr_of_id { CAst.loc; v = id } = + CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) + let cases_pattern_expr_of_name { CAst.loc; v = na } = CAst.make ?loc @@ match na with | Anonymous -> CPatAtom None | Name id -> CPatAtom (Some (qualid_of_ident ?loc id)) @@ -385,7 +395,7 @@ let cases_pattern_expr_of_name { CAst.loc; v = na } = CAst.make ?loc @@ match na type 'r env = { constrs : 'r list; constrlists : 'r list list; - binders : cases_pattern_expr list; + binders : kinded_cases_pattern_expr list; binderlists : local_binder_expr list list; } @@ -394,16 +404,22 @@ let push_constr subst v = { subst with constrs = v :: subst.constrs } let push_item : type s r. s target -> (s, r) entry -> s env -> r -> s env = fun forpat e subst v -> match e with | TTConstr _ -> push_constr subst v +| TTIdent -> + begin match forpat with + | ForConstr -> { subst with binders = (cases_pattern_expr_of_id v, Glob_term.Explicit) :: subst.binders } + | ForPattern -> push_constr subst (cases_pattern_expr_of_id v) + end | TTName -> begin match forpat with - | ForConstr -> { subst with binders = cases_pattern_expr_of_name v :: subst.binders } + | ForConstr -> { subst with binders = (cases_pattern_expr_of_name v, Glob_term.Explicit) :: subst.binders } | ForPattern -> push_constr subst (cases_pattern_expr_of_name v) end | TTPattern _ -> begin match forpat with - | ForConstr -> { subst with binders = v :: subst.binders } + | ForConstr -> { subst with binders = (v, Glob_term.Explicit) :: subst.binders } | ForPattern -> push_constr subst v end +| TTBinder o -> { subst with binders = v :: subst.binders } | TTOpenBinderList -> { subst with binderlists = v :: subst.binderlists } | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 116cfc6413..5c329f60a9 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -531,6 +531,10 @@ let warn_deprecated_include_type = CWarnings.create ~name:"deprecated-include-type" ~category:"deprecated" (fun () -> strbrk "Include Type is deprecated; use Include instead") +let warn_deprecated_as_ident_kind = + CWarnings.create ~name:"deprecated-as-ident-kind" ~category:"deprecated" + (fun () -> strbrk "grammar kind \"as ident\" no longer accepts \"_\"; use \"as name\" instead to accept \"_\", too, or silence the warning if you actually intended to accept only identifiers.") + } (* Modules and Sections *) @@ -1242,7 +1246,13 @@ GRAMMAR EXTEND Gram ] ] ; explicit_subentry: - [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } + [ [ (* Warning to be turn into an error at the end of deprecation phase (for 8.14) *) + IDENT "ident" -> { ETName false } + (* To be activated at the end of transitory phase (for 8.15) + | IDENT "ident" -> { ETIdent } + *) + | IDENT "name" -> { ETName true } (* Boolean to remove at the end of transitory phase *) + | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } | IDENT "binder" -> { ETBinder true } | IDENT "constr" -> { ETConstr (InConstrEntry,None,DefaultLevel) } @@ -1261,8 +1271,9 @@ GRAMMAR EXTEND Gram | -> { DefaultLevel } ] ] ; binder_interp: - [ [ "as"; IDENT "ident" -> { Notation_term.AsIdent } - | "as"; IDENT "pattern" -> { Notation_term.AsIdentOrPattern } + [ [ "as"; IDENT "ident" -> { warn_deprecated_as_ident_kind (); Notation_term.AsIdent } + | "as"; IDENT "name" -> { Notation_term.AsName } + | "as"; IDENT "pattern" -> { Notation_term.AsNameOrPattern } | "as"; IDENT "strict"; IDENT "pattern" -> { Notation_term.AsStrictPattern } ] ] ; END diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index dc2b2e889e..06eb330958 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -340,14 +340,12 @@ let unparsing_metavar i from typs = let x = List.nth typs (i-1) in let prec,side = unparsing_precedence_of_entry_type from x in match x with - | ETConstr _ | ETGlobal | ETBigint -> + | ETConstr _ | ETGlobal | ETBigint | ETIdent -> UnpMetaVar (prec,side) - | ETPattern _ -> - UnpBinderMetaVar prec - | ETIdent -> - UnpBinderMetaVar prec + | ETPattern _ | ETName _ -> + UnpBinderMetaVar (prec,NotQuotedPattern) | ETBinder isopen -> - assert false + UnpBinderMetaVar (prec,QuotedPattern) (* Heuristics for building default printing rules *) @@ -633,10 +631,11 @@ let include_possible_similar_trailing_pattern typ etyps sl l = try_aux 0 l let prod_entry_type = function - | ETIdent -> ETProdName + | ETIdent -> ETProdIdent + | ETName _ -> ETProdName | ETGlobal -> ETProdReference | ETBigint -> ETProdBigint - | ETBinder _ -> assert false (* See check_binder_type *) + | ETBinder o -> ETProdOneBinder o | ETConstr (s,_,p) -> ETProdConstr (s,p) | ETPattern (_,n) -> ETProdPattern (match n with None -> 0 | Some n -> n) @@ -893,6 +892,11 @@ let default = { end +(* To be turned into a fatal warning in 8.14 *) +let warn_deprecated_ident_entry = + CWarnings.create ~name:"deprecated-ident-entry" ~category:"deprecated" + (fun () -> strbrk "grammar entry \"ident\" permitted \"_\" in addition to proper identifiers; this use is deprecated and its meaning will change in the future; use \"name\" instead.") + let interp_modifiers modl = let open NotationMods in let rec interp subtyps acc = function | [] -> subtyps, acc @@ -954,6 +958,13 @@ let interp_modifiers modl = let open NotationMods in let subtyps,mods = interp [] default modl in (* interpret item levels wrt to main entry *) let extra_etyps = List.map (fun (id,bko,n) -> (id,ETConstr (mods.custom,bko,n))) subtyps in + (* Temporary hack: "ETName false" (i.e. "ident" in deprecation phase) means "ETIdent" for custom entries *) + let mods = + { mods with etyps = List.map (function + | (id,ETName false) -> + if mods.custom = InConstrEntry then (warn_deprecated_ident_entry (); (id,ETName true)) + else (id,ETIdent) + | x -> x) mods.etyps } in { mods with etyps = extra_etyps@mods.etyps } let check_infix_modifiers modifiers = @@ -970,15 +981,6 @@ let check_useless_entry_types recvars mainvars etyps = (Id.print x ++ str " is unbound in the notation.") | _ -> () -let check_binder_type recvars etyps = - let l1,l2 = List.split recvars in - let l = l1@l2 in - List.iter (function - | (x,ETBinder b) when not (List.mem x l) -> - CErrors.user_err (str (if b then "binder" else "closed binder") ++ - strbrk " is only for use in recursive notations for binders.") - | _ -> ()) etyps - let interp_non_syntax_modifiers mods = let set modif (only_parsing,only_printing,entry) = match modif with | SetOnlyParsing -> Some (true,only_printing,entry) @@ -1011,7 +1013,7 @@ let set_entry_type from n etyps (x,typ) = | ETConstr (s,bko,n), InternalProd -> ETConstr (s,bko,(n,InternalProd)) | ETPattern (b,n), _ -> ETPattern (b,n) - | (ETIdent | ETBigint | ETGlobal | ETBinder _ as x), _ -> x + | (ETIdent | ETName _ | ETBigint | ETGlobal | ETBinder _ as x), _ -> x with Not_found -> ETConstr (from,None,(make_lev n from,typ)) in (x,typ) @@ -1034,7 +1036,7 @@ let join_auxiliary_recursive_types recvars etyps = let internalization_type_of_entry_type = function | ETBinder _ -> NtnInternTypeOnlyBinder | ETConstr _ | ETBigint | ETGlobal - | ETIdent | ETPattern _ -> NtnInternTypeAny + | ETIdent | ETName _ | ETPattern _ -> NtnInternTypeAny let set_internalization_type typs = List.map (fun (_, e) -> internalization_type_of_entry_type e) typs @@ -1054,11 +1056,12 @@ let make_interpretation_type isrec isonlybinding default_if_binding = function | ETConstr (_,None,_) -> NtnTypeConstr (* Others *) | ETIdent -> NtnTypeBinder NtnParsedAsIdent + | ETName _ -> NtnTypeBinder NtnParsedAsName | ETPattern (ppstrict,_) -> NtnTypeBinder (NtnParsedAsPattern ppstrict) (* Parsed as ident/pattern, primarily interpreted as binder; maybe strict at printing *) | ETBigint | ETGlobal -> NtnTypeConstr | ETBinder _ -> if isrec then NtnTypeBinderList - else anomaly Pp.(str "Type binder is only for use in recursive notations for binders.") + else NtnTypeBinder NtnParsedAsBinder let subentry_of_constr_prod_entry from_level = function (* Specific 8.2 approximation *) @@ -1074,7 +1077,7 @@ let subentry_of_constr_prod_entry from_level = function | _ -> InConstrEntrySomeLevel let make_interpretation_vars - (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsIdent) + (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsName) recvars level allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && @@ -1170,7 +1173,7 @@ let find_precedence custom lev etyps symbols onlyprint = user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") in (try match List.assoc x etyps, custom with | ETConstr (s,_,(NumLevel _ | NextLevel)), s' when s = s' -> test () - | (ETIdent | ETBigint | ETGlobal), _ -> + | (ETIdent | ETName _ | ETBigint | ETGlobal), _ -> begin match lev with | None -> ([fun () -> Flags.if_verbose (Feedback.msg_info ?loc:None) (strbrk "Setting notation at level 0.")],0) @@ -1297,7 +1300,6 @@ let compute_syntax_data ~local deprecation df modifiers = let assoc = Option.append mods.assoc (Some Gramlib.Gramext.NonA) in let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in let _ = check_useless_entry_types recvars mainvars mods.etyps in - let _ = check_binder_type recvars mods.etyps in (* Notations for interp and grammar *) let msgs,n = find_precedence mods.custom mods.level mods.etyps symbols onlyprint in @@ -1810,7 +1812,7 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing interp_notation_constr env nenv c in let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,InternalProd))) in - let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] 0 acvars (List.map in_pat vars) in + let interp = make_interpretation_vars ~default_if_binding:AsNameOrPattern [] 0 acvars (List.map in_pat vars) in let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in let also_in_cases_pattern = has_no_binders_type vars in let onlyparsing = onlyparsing || fst (printability None [] false reversibility pat) in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4cee4f7a47..01873918aa 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -187,13 +187,16 @@ let level_of_pattern_level = function None -> DefaultLevel | Some n -> NumLevel let pr_constr_as_binder_kind = let open Notation_term in function | AsIdent -> spc () ++ keyword "as ident" - | AsIdentOrPattern -> spc () ++ keyword "as pattern" + | AsName -> spc () ++ keyword "as name" + | AsNameOrPattern -> spc () ++ keyword "as pattern" | AsStrictPattern -> spc () ++ keyword "as strict pattern" let pr_strict b = if b then str "strict " else mt () let pr_set_entry_type pr = function | ETIdent -> str"ident" + | ETName false -> str"ident" (* temporary *) + | ETName true -> str"name" | ETGlobal -> str"global" | ETPattern (b,n) -> pr_strict b ++ str"pattern" ++ pr_at_level (level_of_pattern_level n) | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko @@ -268,9 +271,9 @@ let pr_reference_or_constr pr_c = function | HintsConstr c -> pr_c c let pr_hint_mode = let open Hints in function - | ModeInput -> str"+" - | ModeNoHeadEvar -> str"!" - | ModeOutput -> str"-" + | ModeInput -> str"+" + | ModeNoHeadEvar -> str"!" + | ModeOutput -> str"-" let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } = pr_opt (fun x -> str"|" ++ int x) pri ++ diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 57d9e0ac3c..e5971e1aaa 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -82,7 +82,9 @@ let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = match !default_timeout, timeout with | _, Some n | Some n, None -> - Control.timeout n f x CErrors.Timeout + (match Control.timeout n f x with + | None -> Exninfo.iraise (Exninfo.capture CErrors.Timeout) + | Some x -> x) | None, None -> f x |