diff options
171 files changed, 1816 insertions, 1124 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 caf1821ce5..82d9b89c4f 100644 --- a/Makefile.common +++ b/Makefile.common @@ -122,7 +122,7 @@ LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a DLLCOQRUN:=$(dir $(LIBCOQRUN))dll$(COQRUN)$(DLLEXT) BYTERUN:=$(addprefix kernel/byterun/, \ - coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) + coq_fix_code.o coq_float64.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: # respecting this order is useful for developers that want to load or link @@ -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/bench/gitlab.sh b/dev/bench/gitlab.sh index d2e150be9a..7796ae3b01 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -52,7 +52,7 @@ check_variable "CI_JOB_URL" : "${new_coq_opam_archive_git_branch:=master}" : "${old_coq_opam_archive_git_branch:=master}" : "${num_of_iterations:=1}" -: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast}" +: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial}" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) @@ -269,6 +269,9 @@ create_opam() { opam repo add -q --this-switch coq-extra-dev "$OPAM_COQ_DIR/extra-dev" opam repo add -q --this-switch coq-released "$OPAM_COQ_DIR/released" + # Pinning for packages that are not in a repository + opam pin add -ynq coq-perennial.dev git+https://github.com/mit-pdos/perennial#coq/tested + opam install -qy -j$number_of_processors $initial_opam_packages if [ ! -z "$BENCH_DEBUG" ]; then opam repo list; fi 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/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh new file mode 100644 index 0000000000..95f0de2bd3 --- /dev/null +++ b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13386" ] || [ "$CI_BRANCH" = "master+fix9971-primproj-canonical-structure-on-evar-type" ]; then + + unicoq_CI_REF=master+adapting-coq-pr13386 + unicoq_CI_GITURL=https://github.com/herbelin/unicoq + + elpi_CI_REF=coq-master+adapting-coq-pr13386 + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi 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/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst b/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst new file mode 100644 index 0000000000..4bd214d7be --- /dev/null +++ b/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst @@ -0,0 +1,6 @@ +- **Fixed:** + issue when two expressions involving different projections and one is + primitive need to be unified + (`#13386 <https://github.com/coq/coq/pull/13386>`_, + fixes `#9971 <https://github.com/coq/coq/issues/9971>`_, + by Hugo Herbelin). 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/12965-master+fix9569-propagage-binding-vars-notations.rst b/doc/changelog/03-notations/12965-master+fix9569-propagage-binding-vars-notations.rst new file mode 100644 index 0000000000..e63ab9696e --- /dev/null +++ b/doc/changelog/03-notations/12965-master+fix9569-propagage-binding-vars-notations.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Capture of the name of global references by + binders in the presence of notations for binders + (`#12965 <https://github.com/coq/coq/pull/12965>`_, + fixes `#9569 <https://github.com/coq/coq/issues/9569>`_, + 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/13237-master+fix13235-no-degenerate-in-hyps-clause.rst b/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst new file mode 100644 index 0000000000..bc67fd025a --- /dev/null +++ b/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst @@ -0,0 +1,6 @@ +- **Changed:** + Giving an empty list of occurrences after :n:`in` in tactics is no + longer permitted. Omitting the :n:`in` gives the same behavior + (`#13237 <https://github.com/coq/coq/pull/13236>`_, + fixes `#13235 <https://github.com/coq/coq/issues/13235>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13381-bfs_eauto.rst b/doc/changelog/04-tactics/13381-bfs_eauto.rst index a51f96d0a2..f37fbfe52b 100644 --- a/doc/changelog/04-tactics/13381-bfs_eauto.rst +++ b/doc/changelog/04-tactics/13381-bfs_eauto.rst @@ -1,6 +1,6 @@ - **Deprecated:** Undocumented :n:`eauto @int_or_var @int_or_var` syntax in favor of new ``bfs eauto``. - Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``; - replacement TBD. + Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``. + (Use ``bfs eauto`` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) (`#13381 <https://github.com/coq/coq/pull/13381>`_, by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13403-occs_nums_nat.rst b/doc/changelog/04-tactics/13403-occs_nums_nat.rst new file mode 100644 index 0000000000..5dfa90a267 --- /dev/null +++ b/doc/changelog/04-tactics/13403-occs_nums_nat.rst @@ -0,0 +1,7 @@ +- **Removed:** + :n:`at @occs_nums` clauses in tactics such as tacn:`unfold` + no longer allow negative values. A "-" before the + list (for set complement) is still supported. Ex: "at -1 -2" + is no longer supported but "at -1 2" is. + (`#13403 <https://github.com/coq/coq/pull/13403>`_, + by Jim Fehrle). 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/changes.rst b/doc/sphinx/changes.rst index 4d59fc0513..24fa71059c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -147,7 +147,7 @@ Specification language, type inference This makes typeclasses with declared modes more robust with respect to the order of resolution. (`#10858 <https://github.com/coq/coq/pull/10858>`_, - fixes `#9058 <https://github.com/coq/coq/issues/9058>_`, by Matthieu Sozeau). + fixes `#9058 <https://github.com/coq/coq/issues/9058>`_, by Matthieu Sozeau). - **Added:** Warn when manual implicit arguments are used in unexpected positions of a term (e.g. in `Check id (forall {x}, x)`) or when an implicit 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 f3f69a2fdc..9ec568c2c7 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -274,9 +274,13 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. exn:: Too few occurrences. :undocumented: - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @ident + .. tacv:: change @term {? {? at {+ @natural}} with @term} in @goal_occurrences - This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. + In the presence of :n:`with`, this applies :tacn:`change` to the + occurrences specified by :n:`@goal_occurrences`. In the + absence of :n:`with`, :n:`@goal_occurrences` is expected to + only list hypotheses (and optionally the conclusion) without + specifying occurrences (i.e. no :n:`at` clause). .. tacv:: now_show @term @@ -319,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 } {* @int_or_var } + 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 4c1956d172..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? *) ] @@ -1939,11 +1942,6 @@ tac2rec_fields: [ | LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 ] -(* todo: weird productions, ints only after an initial "-"??: - occs_nums: [ - | LIST1 [ natural | ident ] - | "-" [ natural | ident ] LIST0 int_or_var -*) ltac2_occs_nums: [ | DELETE LIST1 nat_or_anti (* Ltac2 plugin *) | REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) @@ -2541,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 b5d57f92e9..d01f66c6d7 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -480,6 +480,7 @@ opt_hintbases: [ command: [ | "Goal" lconstr | "Proof" +| "Proof" "using" G_vernac.section_subset_expr | "Proof" "Mode" string | "Proof" lconstr | "Abort" @@ -604,7 +605,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 reference | "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT natural | "Proof" "with" Pltac.tactic OPT [ "using" G_vernac.section_subset_expr ] -| "Proof" "using" G_vernac.section_subset_expr OPT [ "with" Pltac.tactic ] +| "Proof" "using" G_vernac.section_subset_expr "with" Pltac.tactic | "Tactic" "Notation" OPT ltac_tactic_level LIST1 ltac_production_item ":=" tactic | "Print" "Ltac" reference | "Locate" "Ltac" reference @@ -1419,6 +1420,7 @@ syntax_modifiers: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "binder" @@ -1439,6 +1441,7 @@ at_level_opt: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1478,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" @@ -1581,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 @@ -1616,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 @@ -1733,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 *) @@ -1744,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 *) @@ -2021,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 @@ -2035,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 *) ] @@ -2328,7 +2331,7 @@ conversion: [ occs_nums: [ | LIST1 nat_or_var -| "-" nat_or_var LIST0 int_or_var +| "-" LIST1 nat_or_var ] occs: [ @@ -2538,6 +2541,7 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc +| "as" equality_intropattern | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index c9d70a88fc..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 ] -| "-" [ natural | ident ] LIST0 int_or_var +| 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 ) ] @@ -953,6 +958,7 @@ command: [ | "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) | "Proof" +| "Proof" "using" section_var_expr | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] @@ -1033,7 +1039,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 qualid | "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" [ "bfs" | "dfs" ] ")" ) OPT natural | "Proof" "with" ltac_expr OPT [ "using" section_var_expr ] -| "Proof" "using" section_var_expr OPT [ "with" ltac_expr ] +| "Proof" "using" section_var_expr "with" ltac_expr | "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid @@ -1573,6 +1579,7 @@ syntax_modifier: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "strict" "pattern" OPT ( "at" "level" natural ) @@ -1585,6 +1592,7 @@ explicit_subentry: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1619,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 ) @@ -1647,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 @@ -1657,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 "|" "]" @@ -1717,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 @@ -1755,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 @@ -1858,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 *) @@ -1868,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 *) @@ -1941,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" @@ -1969,6 +1975,7 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc +| "as" equality_intropattern ] eqn_ipat: [ 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 d1bec16a3f..cf88036f73 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -85,7 +85,7 @@ let is_reserved_type na t = | Name id -> try let pat = Reserve.find_reserved_type id in - let _ = match_notation_constr false t ([],pat) in + let _ = match_notation_constr ~print_univ:false t ~vars:Id.Set.empty ([],pat) in true with Not_found | No_match -> false @@ -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 @@ -1273,7 +1276,7 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = | AppBoundedNotation _ -> raise No_match in (* Try matching ... *) let terms,termlists,binders,binderlists = - match_notation_constr !print_universes t pat in + match_notation_constr ~print_univ:(!print_universes) t ~vars pat in (* Try availability of interpretation ... *) match keyrule with | NotationRule (_,ntn as specific_ntn) -> @@ -1293,20 +1296,21 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = | Some (scopt,key) -> let scopes' = Option.List.cons scopt (snd scopes) in let l = - List.map (fun (c,(subentry,(scopt,scl))) -> + List.map (fun ((vars,c),(subentry,(scopt,scl))) -> extern (* assuming no overloading: *) true (subentry,(scopt,scl@scopes')) vars c) terms in let ll = - List.map (fun (c,(subentry,(scopt,scl))) -> - List.map (extern true (subentry,(scopt,scl@scopes')) vars) c) + List.map (fun ((vars,l),(subentry,(scopt,scl))) -> + List.map (extern true (subentry,(scopt,scl@scopes')) vars) l) termlists in let bl = - List.map (fun (bl,(subentry,(scopt,scl))) -> - mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)) + List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> + (mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)), + Explicit) binders in let bll = - List.map (fun (bl,(subentry,(scopt,scl))) -> + List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in let c = make_notation loc specific_ntn (l,ll,bl,bll) in @@ -1316,7 +1320,7 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = CAst.make ?loc @@ extern_applied_notation inctx nallargs argsimpls c args) | SynDefRule kn -> let l = - List.map (fun (c,(subentry,(scopt,scl))) -> + List.map (fun ((vars,c),(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c) terms in let cf = Nametab.shortest_qualid_of_syndef ?loc vars kn in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index b86ad7175a..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 *) () @@ -534,15 +533,19 @@ let intern_generalized_binder intern_type ntnvars in let na = match na with | Anonymous -> - let name = - let id = - match ty with - | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> - qualid_basename qid - | _ -> default_non_dependent_ident - in Implicit_quantifiers.make_fresh ids' (Global.env ()) id - in Name name - | _ -> na in + let id = + match ty with + | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> + qualid_basename qid + | _ -> default_non_dependent_ident + in + let ids' = List.fold_left (fun ids' lid -> Id.Set.add lid.CAst.v ids') ids' fvs in + let id = + Implicit_quantifiers.make_fresh ids' (Global.env ()) id + in + Name id + | _ -> na + in let impls = impls_type_list 1 ty' in (push_name_env ntnvars impls env' (make ?loc na), (make ?loc (na,b',ty')) :: List.rev bl) @@ -583,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 @@ -591,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) -> @@ -606,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 @@ -702,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 @@ -711,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) *) @@ -749,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 @@ -874,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 () @@ -904,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 *) @@ -932,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.") @@ -962,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) @@ -977,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 -> @@ -1027,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 *) @@ -1155,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 d393dcaecb..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,21 @@ 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 + | PatVar na -> Termops.add_vname vars na + | PatCstr (c, pl, na) -> List.fold_left push_pattern_binders (Termops.add_vname vars na) pl + +let rec push_context_binders vars = function + | [] -> vars + | b :: bl -> + let vars = match DAst.get b with + | GLocalAssum (na,_,_) -> Termops.add_vname vars na + | GLocalPattern ((disjpat,ids),p,bk,t) -> List.fold_right Id.Set.add ids vars + | GLocalDef (na,_,_,_) -> Termops.add_vname vars na in + push_context_binders vars bl let is_term_meta id metas = try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false @@ -836,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 @@ -851,7 +897,7 @@ let alpha_rename alpmetas v = if alpmetas == [] then v else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match -let add_env (alp,alpmetas) (terms,termlists,binders,binderlists) var v = +let add_env (vars,(alp,alpmetas)) (terms,termlists,binders,binderlists) var v = (* Check that no capture of binding variables occur *) (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." with an actual term "fun z => ... z ..." when "x" is not bound in the @@ -879,19 +925,19 @@ let add_env (alp,alpmetas) (terms,termlists,binders,binderlists) var v = refinement *) let v = alpha_rename alpmetas v in (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::terms,termlists,binders,binderlists) + ((var,(vars,v))::terms,termlists,binders,binderlists) -let add_termlist_env (alp,alpmetas) (terms,termlists,binders,binderlists) var vl = +let add_termlist_env (vars,(alp,alpmetas)) (terms,termlists,binders,binderlists) var vl = if List.exists (fun (id,_) -> List.exists (occur_glob_constr id) vl) alp then raise No_match; let vl = List.map (alpha_rename alpmetas) vl in - (terms,(var,vl)::termlists,binders,binderlists) + (terms,(var,(vars,vl))::termlists,binders,binderlists) -let add_binding_env alp (terms,termlists,binders,binderlists) var v = +let add_binding_env (vars,alp) (terms,termlists,binders,binderlists) var v = (* TODO: handle the case of multiple occs in different scopes *) - (terms,termlists,(var,v)::binders,binderlists) + (terms,termlists,(var,(vars,v))::binders,binderlists) -let add_bindinglist_env (terms,termlists,binders,binderlists) x bl = - (terms,termlists,binders,(x,bl)::binderlists) +let add_bindinglist_env (vars,alp) (terms,termlists,binders,binderlists) var bl = + (terms,termlists,binders,(var,(vars,bl))::binderlists) let rec map_cases_pattern_name_left f = DAst.map (function | PatVar na -> PatVar (f na) @@ -936,18 +982,19 @@ let rec pat_binder_of_term t = DAst.map (function | _ -> raise No_match ) t -let unify_name_upto alp na na' = +let unify_name_upto (vars,alp) na na' = match na, na' with - | Anonymous, na' -> alp, na' - | na, Anonymous -> alp, na + | Anonymous, na' -> (Termops.add_vname vars na',alp), na' + | na, Anonymous -> (Termops.add_vname vars na,alp), na | Name id, Name id' -> - if Id.equal id id' then alp, na' - else (fst alp,(id,id')::snd alp), na' + let vars = Termops.add_vname vars na' in + if Id.equal id id' then (vars,alp), na' + else (vars,(fst alp,(id,id')::snd alp)), na' let unify_pat_upto alp p p' = try fold_cases_pattern_eq unify_name_upto alp p p' with Failure _ -> raise No_match -let unify_term alp v v' = +let unify_term (_,alp) v v' = match DAst.get v, DAst.get v' with | GHole _, _ -> v' | _, GHole _ -> v @@ -990,13 +1037,13 @@ let rec unify_binders_upto alp bl bl' = alp, b :: bl | _ -> raise No_match -let unify_id alp id na' = +let unify_id (_,alp) id na' = match na' with | Anonymous -> Name (rename_var (snd alp) id) | Name id' -> if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match -let unify_pat alp p p' = +let unify_pat (_,alp) p p' = if cases_pattern_eq (map_cases_pattern_name_left (Name.map (rename_var (snd alp))) p) p' then p' else raise No_match @@ -1022,33 +1069,37 @@ let rec unify_terms_binders alp cl bl' = let bind_term_env alp (terms,termlists,binders,binderlists as sigma) var v = try (* If already bound to a term, unify with the new term *) - let v' = Id.List.assoc var terms in + let vars,v' = Id.List.assoc var terms in let v'' = unify_term alp v v' in if v'' == v' then sigma else let sigma = (Id.List.remove_assoc var terms,termlists,binders,binderlists) in - add_env alp sigma var v + add_env (Id.Set.union vars (fst alp),snd alp) sigma var v with Not_found -> add_env alp sigma var v let bind_termlist_env alp (terms,termlists,binders,binderlists as sigma) var vl = try (* If already bound to a list of term, unify with the new terms *) - let vl' = Id.List.assoc var termlists in + let vars,vl' = Id.List.assoc var termlists in let vl = unify_terms alp vl vl' in let sigma = (terms,Id.List.remove_assoc var termlists,binders,binderlists) in - add_termlist_env alp sigma var vl + add_termlist_env (Id.Set.union vars (fst alp),snd alp) sigma var vl with Not_found -> add_termlist_env alp sigma var vl let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) var id = try (* If already bound to a term, unify the binder and the term *) - match DAst.get (Id.List.assoc var terms) with + let vars',v' = Id.List.assoc var terms in + match DAst.get v' with | GVar id' | GRef (GlobRef.VarRef id',None) -> - (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), - sigma + let (vars,(alpha,alpmetas)) = alp in + let vars = Id.Set.add id' vars in + let alpmetas = if not (Id.equal id id') then (id,id')::alpmetas else alpmetas in + (Id.Set.union vars' vars,(alpha,alpmetas)), sigma | t -> (* The term is a non-variable pattern *) raise No_match with Not_found -> + let alp = (Id.Set.add id (fst alp), snd alp) in (* The matching against a term allowing to find the instance has not been found yet *) (* If it will be a different name, we shall unfortunately fail *) (* TODO: look at the consequences for alp *) @@ -1059,43 +1110,56 @@ let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) let pat = try cases_pattern_of_glob_constr env Anonymous c with Not_found -> raise No_match in try (* If already bound to a binder, unify the term and the binder *) - let patl' = Id.List.assoc var binders in + let vars,patl' = Id.List.assoc var binders in let patl'' = List.map2 (unify_pat alp) [pat] patl' in if patl' == patl'' then sigma else let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in - add_binding_env alp sigma var patl'' + add_binding_env (Id.Set.union vars (fst alp),snd alp) sigma var patl'' with Not_found -> add_binding_env alp sigma var [pat] let bind_binding_env alp (terms,termlists,binders,binderlists as sigma) var disjpat = try (* If already bound to a binder possibly *) (* generating an alpha-renaming from unifying the new binder *) - let disjpat' = Id.List.assoc var binders in + let vars,disjpat' = Id.List.assoc var binders in + (* if, maybe, there is eventually casts in patterns, the common types have *) + (* to exclude the spine of variable from the two locations they occur *) + let alp' = (Id.Set.union vars (fst alp),snd alp) in let alp, disjpat = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in + alp, add_binding_env alp' sigma var disjpat + with Not_found -> + (* Note: all patterns of the disjunction are supposed to have the same + variables, thus one is enough *) + let alp = (push_pattern_binders (fst alp) (List.hd disjpat), snd alp) in alp, add_binding_env alp sigma var disjpat - with Not_found -> alp, add_binding_env alp sigma var disjpat let bind_bindinglist_env alp (terms,termlists,binders,binderlists as sigma) var bl = let bl = List.rev bl in try (* If already bound to a list of binders possibly *) (* generating an alpha-renaming from unifying the new binders *) - let bl' = Id.List.assoc var binderlists in + let vars, bl' = Id.List.assoc var binderlists in + (* The shared subterm can be under two different spines of *) + (* variables (themselves bound in the notation) , so we take the *) + (* union of both locations *) + let alp' = (Id.Set.union vars (fst alp),snd alp) in let alp, bl = unify_binders_upto alp bl bl' in let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in - alp, add_bindinglist_env sigma var bl + alp, add_bindinglist_env alp' sigma var bl with Not_found -> - alp, add_bindinglist_env sigma var bl + let alp = (push_context_binders (fst alp) bl, snd alp) in + alp, add_bindinglist_env alp sigma var bl let bind_bindinglist_as_termlist_env alp (terms,termlists,binders,binderlists) var cl = try (* If already bound to a list of binders, unify the terms and binders *) - let bl' = Id.List.assoc var binderlists in + let vars,bl' = Id.List.assoc var binderlists in let bl = unify_terms_binders alp cl bl' in + let alp = (Id.Set.union vars (fst alp),snd alp) in let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in - add_bindinglist_env sigma var bl + add_bindinglist_env alp sigma var bl with Not_found -> anomaly (str "There should be a binder list bindings this list of terms.") @@ -1129,7 +1193,9 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | (Anonymous,Name id2) when is_term_meta id2 metas -> (* We let the non-binding occurrence define the rhs *) alp, sigma - | (Name id1,Name id2) -> ((id1,id2)::fst alp, snd alp),sigma + | (Name id1,Name id2) -> + let (vars,(alp,alpmetas)) = alp in + (vars,((id1,id2)::alp,alpmetas)),sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match @@ -1172,9 +1238,9 @@ let match_binderlist match_fun alp metas sigma rest x y iter termin revert = try let metas = add_ldots_var (add_meta_bindinglist y metas) in let (terms,_,_,binderlists as sigma) = match_fun alp metas sigma rest iter in - let rest = Id.List.assoc ldots_var terms in + let _,rest = Id.List.assoc ldots_var terms in let b = - match Id.List.assoc y binderlists with [b] -> b | _ ->assert false + match Id.List.assoc y binderlists with _,[b] -> b | _ ->assert false in let sigma = remove_bindinglist_sigma y (remove_sigma ldots_var sigma) in (* In case y is bound not only to a binder but also to a term *) @@ -1203,18 +1269,20 @@ let match_binderlist match_fun alp metas sigma rest x y iter termin revert = let add_meta_term x metas = (x,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeConstr))::metas (* Should reuse the scope of the partner of x! *) let match_termlist match_fun alp metas sigma rest x y iter termin revert = - let rec aux sigma acc rest = + let rec aux alp sigma acc rest = try let metas = add_ldots_var (add_meta_term y metas) in let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in - let rest = Id.List.assoc ldots_var terms in - let t = Id.List.assoc y terms in + let _,rest = Id.List.assoc ldots_var terms in + let vars,t = Id.List.assoc y terms in let sigma = remove_sigma y (remove_sigma ldots_var sigma) in if !print_parentheses && not (List.is_empty acc) then raise No_match; - aux sigma (t::acc) rest + (* The union is overkill at the current time because each term matches *) + (* at worst the same binder metavariable of the same pattern *) + aux (Id.Set.union vars (fst alp),snd alp) sigma (t::acc) rest with No_match when not (List.is_empty acc) -> - acc, match_fun metas sigma rest termin in - let l,(terms,termlists,binders,binderlists as sigma) = aux sigma [] rest in + alp, acc, match_fun metas sigma rest termin in + let alp,l,(terms,termlists,binders,binderlists as sigma) = aux alp sigma [] rest in let l = if revert then l else List.rev l in if is_bindinglist_meta x metas then (* This is a recursive pattern for both bindings and terms; it is *) @@ -1275,7 +1343,7 @@ let rec match_ inner u alp metas sigma a1 a2 = match_binderlist (match_hd u) alp metas sigma a1 x y iter termin revert (* Matching compositionally *) - | GVar id1, NVar id2 when alpha_var id1 id2 (fst alp) -> sigma + | GVar id1, NVar id2 when alpha_var id1 id2 (fst (snd alp)) -> sigma | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in @@ -1289,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 @@ -1360,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 @@ -1387,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 @@ -1445,9 +1517,9 @@ and match_disjunctive_equations u alp metas sigma {CAst.v=(ids,disjpatl1,rhs1)} (alp,sigma) disjpatl1 disjpatl2 in match_in u alp metas sigma rhs1 rhs2 -let match_notation_constr u c (metas,pat) = +let match_notation_constr ~print_univ c ~vars (metas,pat) = let terms,termlists,binders,binderlists = - match_ false u ([],[]) metas ([],[],[],[]) c pat in + match_ false print_univ (vars,([],[])) metas ([],[],[],[]) c pat in (* Turning substitution based on binding/constr distinction into a substitution based on entry productions *) List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders',binderlists') -> @@ -1457,11 +1529,11 @@ let match_notation_constr u c (metas,pat) = ((term, scl)::terms',termlists',binders',binderlists') | NtnTypeBinder (NtnBinderParsedAsConstr _) -> (match Id.List.assoc x binders with - | [pat] -> + | vars,[pat] -> let v = glob_constr_of_cases_pattern (Global.env()) pat in - ((v,scl)::terms',termlists',binders',binderlists') + (((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 3182ea96d7..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 @@ -68,10 +68,11 @@ exception No_match val print_parentheses : bool ref -val match_notation_constr : bool -> 'a glob_constr_g -> interpretation -> - ('a glob_constr_g * extended_subscopes) list * ('a glob_constr_g list * extended_subscopes) list * - ('a cases_pattern_disjunction_g * extended_subscopes) list * - ('a extended_glob_local_binder_g list * extended_subscopes) list +val match_notation_constr : print_univ:bool -> 'a glob_constr_g -> vars:Id.Set.t -> interpretation -> + ((Id.Set.t * 'a glob_constr_g) * extended_subscopes) list * + ((Id.Set.t * 'a glob_constr_g list) * extended_subscopes) list * + ((Id.Set.t * 'a cases_pattern_disjunction_g) * extended_subscopes) list * + ((Id.Set.t * 'a extended_glob_local_binder_g list) * extended_subscopes) list val match_notation_constr_cases_pattern : 'a cases_pattern_g -> interpretation -> 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/reserve.ml b/interp/reserve.ml index 1d5af3ff39..274d3655d3 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -119,7 +119,7 @@ let revert_reserved_type t = then I've introduced a bug... *) let filter _ pat = try - let _ = match_notation_constr false t ([], pat) in + let _ = match_notation_constr ~print_univ:false t ~vars:Id.Set.empty ([], pat) in true with No_match -> false in 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_fix_code.c b/kernel/byterun/coq_fix_code.c index 9118410549..1ba6a8c8fe 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -43,9 +43,7 @@ void init_arity () { arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= - arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= - arity[LTFLOAT]=arity[LEFLOAT]= - arity[ISINT]=arity[AREINT2]=0; + 0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= @@ -75,9 +73,10 @@ void init_arity () { arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[ISARRAY_CAML_CALL1]=arity[ISINT_CAML_CALL2]= - arity[ISARRAY_INT_CAML_CALL2]=arity[ISARRAY_INT_CAML_CALL3]= - arity[PROJ]=2; + arity[CHECKCAMLCALL1]=arity[CHECKCAMLCALL2_1]= + arity[CHECKCAMLCALL2]=arity[CHECKCAMLCALL3_1]= + arity[PROJ]= + 2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_float64.h b/kernel/byterun/coq_float64.c index 84a3edf1c7..bea47dd47e 100644 --- a/kernel/byterun/coq_float64.h +++ b/kernel/byterun/coq_float64.c @@ -8,19 +8,40 @@ /* * (see LICENSE file for the text of the license) */ /************************************************************************/ -#ifndef _COQ_FLOAT64_ -#define _COQ_FLOAT64_ - #include <math.h> +#include <stdint.h> -#define DECLARE_FREL(name, e) \ - int coq_##name(double x, double y) { \ - return e; \ - } \ - \ - value coq_##name##_byte(value x, value y) { \ - return coq_##name(Double_val(x), Double_val(y)); \ - } +#define CAML_INTERNALS +#include <caml/alloc.h> + +#include "coq_values.h" + +union double_bits { + double d; + uint64_t u; +}; + +static double next_up(double x) { + union double_bits bits; + if (!(x < INFINITY)) return x; // x is +oo or NaN + bits.d = x; + int64_t i = bits.u; + if (i >= 0) ++bits.u; // x >= +0.0, go away from zero + else if (bits.u + bits.u == 0) bits.u = 1; // x is -0.0, should almost never happen + else --bits.u; // x < 0.0, go toward zero + return bits.d; +} + +static double next_down(double x) { + union double_bits bits; + if (!(x > -INFINITY)) return x; // x is -oo or NaN + bits.d = x; + int64_t i = bits.u; + if (i == 0) bits.u = INT64_MIN + 1; // x is +0.0 + else if (i < 0) ++bits.u; // x <= -0.0, go away from zero + else --bits.u; // x > 0.0, go toward zero + return bits.d; +} #define DECLARE_FBINOP(name, e) \ double coq_##name(double x, double y) { \ @@ -40,19 +61,14 @@ return caml_copy_double(coq_##name(Double_val(x))); \ } -DECLARE_FREL(feq, x == y) -DECLARE_FREL(flt, x < y) -DECLARE_FREL(fle, x <= y) DECLARE_FBINOP(fmul, x * y) DECLARE_FBINOP(fadd, x + y) DECLARE_FBINOP(fsub, x - y) DECLARE_FBINOP(fdiv, x / y) DECLARE_FUNOP(fsqrt, sqrt(x)) -DECLARE_FUNOP(next_up, nextafter(x, INFINITY)) -DECLARE_FUNOP(next_down, nextafter(x, -INFINITY)) +DECLARE_FUNOP(next_up, next_up(x)) +DECLARE_FUNOP(next_down, next_down(x)) value coq_is_double(value x) { return Val_long(Is_double(x)); } - -#endif /* _COQ_FLOAT64_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 1b6da7dd6f..6255250218 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -28,7 +28,6 @@ #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" -#include "coq_float64.h" #if OCAML_VERSION < 41000 extern void caml_minor_collection(void); @@ -113,7 +112,7 @@ if (sp - num_args < coq_stack_threshold) { \ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } #define Setup_for_caml_call { *--sp = coq_env; coq_sp = sp; } -#define Restore_after_caml_call { sp = coq_sp; coq_env = *sp++; } +#define Restore_after_caml_call coq_env = *sp++; /* Register optimization. Some compilers underestimate the use of the local variables representing @@ -193,7 +192,9 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif -#define Is_accu(v) (Is_block(v) && Tag_val(v) == Closure_tag && Code_val(v) == accumulate) +/* We should also check "Code_val(v) == accumulate" to be sure, + but Is_accu is only used in places where closures cannot occur. */ +#define Is_accu(v) (Is_block(v) && Tag_val(v) == Closure_tag) #define CheckPrimArgs(cond, apply_lbl) do{ \ if (cond) pc++; \ @@ -237,6 +238,9 @@ extern intnat volatile caml_pending_signals[]; extern void caml_process_pending_signals(void); #endif +extern double coq_next_up(double); +extern double coq_next_down(double); + /* The interpreter itself */ value coq_interprete @@ -712,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); @@ -728,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]; @@ -1126,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]); @@ -1236,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]); @@ -1271,11 +1309,8 @@ value coq_interprete Instruct(CHECKADDINT63){ print_instr("CHECKADDINT63"); CheckInt2(); - } - Instruct(ADDINT63) { /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ - print_instr("ADDINT63"); Uint63_add(accu, *sp++); Next; } @@ -1309,9 +1344,6 @@ value coq_interprete Instruct (CHECKSUBINT63) { print_instr("CHECKSUBINT63"); CheckInt2(); - } - Instruct (SUBINT63) { - print_instr("SUBINT63"); /* returns the subtraction */ Uint63_sub(accu, *sp++); Next; @@ -1517,9 +1549,6 @@ value coq_interprete Instruct (CHECKLTINT63) { print_instr("CHECKLTINT63"); CheckInt2(); - } - Instruct (LTINT63) { - print_instr("LTINT63"); int b; Uint63_lt(b,accu,*sp++); accu = b ? coq_true : coq_false; @@ -1529,9 +1558,6 @@ value coq_interprete Instruct (CHECKLEINT63) { print_instr("CHECKLEINT63"); CheckInt2(); - } - Instruct (LEINT63) { - print_instr("LEINT63"); int b; Uint63_leq(b,accu,*sp++); accu = b ? coq_true : coq_false; @@ -1570,20 +1596,6 @@ value coq_interprete Next; } - Instruct (ISINT){ - print_instr("ISINT"); - accu = (Is_uint63(accu)) ? coq_true : coq_false; - Next; - } - - Instruct (AREINT2){ - print_instr("AREINT2"); - accu = (Is_uint63(accu) && Is_uint63(sp[0])) ? coq_true : coq_false; - sp++; - Next; - } - - Instruct (CHECKOPPFLOAT) { print_instr("CHECKOPPFLOAT"); CheckFloat1(); @@ -1601,27 +1613,21 @@ value coq_interprete Instruct (CHECKEQFLOAT) { print_instr("CHECKEQFLOAT"); CheckFloat2(); - accu = coq_feq(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) == Double_val(*sp++) ? coq_true : coq_false; Next; } Instruct (CHECKLTFLOAT) { print_instr("CHECKLTFLOAT"); CheckFloat2(); - } - Instruct (LTFLOAT) { - print_instr("LTFLOAT"); - accu = coq_flt(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) < Double_val(*sp++) ? coq_true : coq_false; Next; } Instruct (CHECKLEFLOAT) { print_instr("CHECKLEFLOAT"); CheckFloat2(); - } - Instruct (LEFLOAT) { - print_instr("LEFLOAT"); - accu = coq_fle(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) <= Double_val(*sp++) ? coq_true : coq_false; Next; } @@ -1674,35 +1680,35 @@ value coq_interprete Instruct (CHECKADDFLOAT) { print_instr("CHECKADDFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fadd(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) + Double_val(*sp++)); Next; } Instruct (CHECKSUBFLOAT) { print_instr("CHECKSUBFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fsub(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) - Double_val(*sp++)); Next; } Instruct (CHECKMULFLOAT) { print_instr("CHECKMULFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fmul(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) * Double_val(*sp++)); Next; } Instruct (CHECKDIVFLOAT) { print_instr("CHECKDIVFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fdiv(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) / Double_val(*sp++)); Next; } Instruct (CHECKSQRTFLOAT) { print_instr("CHECKSQRTFLOAT"); CheckFloat1(); - Coq_copy_double(coq_fsqrt(Double_val(accu))); + Coq_copy_double(sqrt(Double_val(accu))); Next; } @@ -1784,11 +1790,25 @@ value coq_interprete Next; } + Instruct (CHECKNEXTUPFLOATINPLACE) { + print_instr("CHECKNEXTUPFLOATINPLACE"); + CheckFloat1(); + Store_double_val(accu, coq_next_up(Double_val(accu))); + Next; + } - Instruct(ISINT_CAML_CALL2) { + Instruct (CHECKNEXTDOWNFLOATINPLACE) { + print_instr("CHECKNEXTDOWNFLOATINPLACE"); + CheckFloat1(); + Store_double_val(accu, coq_next_down(Double_val(accu))); + Next; + } + + Instruct(CHECKCAMLCALL2_1) { + // arity-2 callback, the last argument can be an accumulator value arg; - print_instr("ISINT_CAML_CALL2"); - if (Is_uint63(accu)) { + print_instr("CHECKCAMLCALL2_1"); + if (!Is_accu(accu)) { pc++; print_int(*pc); arg = sp[0]; @@ -1801,47 +1821,50 @@ value coq_interprete Next; } - Instruct(ISARRAY_CAML_CALL1) { - print_instr("ISARRAY_CAML_CALL1"); - if (Is_coq_array(accu)) { - pc++; - Setup_for_caml_call; - print_int(*pc); - accu = caml_callback(Field(coq_global_data, *pc),accu); - Restore_after_caml_call; - pc++; - } - else pc += *pc; - Next; + Instruct(CHECKCAMLCALL1) { + // arity-1 callback, no argument can be an accumulator + print_instr("CHECKCAMLCALL1"); + if (!Is_accu(accu)) { + pc++; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback(Field(coq_global_data, *pc), accu); + Restore_after_caml_call; + pc++; + } + else pc += *pc; + Next; } - Instruct(ISARRAY_INT_CAML_CALL2) { + Instruct(CHECKCAMLCALL2) { + // arity-2 callback, no argument can be an accumulator value arg; - print_instr("ISARRAY_INT_CAML_CALL2"); - if (Is_coq_array(accu) && Is_uint63(sp[0])) { - pc++; - arg = sp[0]; - Setup_for_caml_call; - print_int(*pc); - accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); - Restore_after_caml_call; - sp += 1; - pc++; - } else pc += *pc; - Next; + print_instr("CHECKCAMLCALL2"); + if (!Is_accu(accu) && !Is_accu(sp[0])) { + pc++; + arg = sp[0]; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); + Restore_after_caml_call; + sp += 1; + pc++; + } else pc += *pc; + Next; } - Instruct(ISARRAY_INT_CAML_CALL3) { + Instruct(CHECKCAMLCALL3_1) { + // arity-3 callback, the last argument can be an accumulator value arg1; value arg2; - print_instr("ISARRAY_INT_CAML_CALL3"); - if (Is_coq_array(accu) && Is_uint63(sp[0])) { + print_instr("CHECKCAMLCALL3_1"); + if (!Is_accu(accu) && !Is_accu(sp[0])) { pc++; arg1 = sp[0]; arg2 = sp[1]; Setup_for_caml_call; print_int(*pc); - accu = caml_callback3(Field(coq_global_data, *pc),accu, arg1, arg2); + accu = caml_callback3(Field(coq_global_data, *pc), accu, arg1, arg2); Restore_after_caml_call; sp += 2; pc++; diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index ae5251c252..fe076f8f04 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -65,9 +65,10 @@ static void coq_scan_roots(scanning_action action) register value * i; /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { + if (!Is_block(*i)) continue; #ifdef NO_NAKED_POINTERS /* The VM stack may contain C-allocated bytecode */ - if (Is_block(*i) && !Is_in_heap_or_young(*i)) continue; + if (!Is_in_heap_or_young(*i)) continue; #endif (*action) (*i, i); }; diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index f07018711b..0cdef34050 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -30,9 +30,6 @@ #define Is_double(v) (Tag_val(v) == Double_tag) #define Is_tailrec_switch(v) (Field(v,1) == Val_true) -/* coq array */ -#define Is_coq_array(v) (Is_block(v) && (Wosize_val(v) == 1)) - /* coq values for primitive operations */ #define coq_tag_C1 2 #define coq_tag_C0 1 diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 2998178be2..d3e2a2fa7f 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -4,7 +4,7 @@ (public_name coq.vm) (foreign_stubs (language c) - (names coq_fix_code coq_memory coq_values coq_interp) + (names coq_fix_code coq_float64 coq_memory coq_values coq_interp) (flags (:include %{project_root}/config/dune.c_flags)))) (rule diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 17feeb9b5a..c9326615dc 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -263,7 +263,7 @@ let assoc_defined id env = match Environ.lookup_named id env with * before the term is computed. *) -(* Norm means the term is fully normalized and cannot create a redex +(* Ntrl means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) @@ -271,10 +271,10 @@ let assoc_defined id env = match Environ.lookup_named id env with create a redex when substituted Red is used for terms that might be reduced *) -type red_state = Norm | Cstr | Whnf | Red +type red_state = Ntrl | Cstr | Whnf | Red let neutr = function - | Whnf|Norm -> Whnf + | Whnf|Ntrl -> Whnf | Red|Cstr -> Red type optrel = Unknown | KnownR | KnownI @@ -293,13 +293,13 @@ module Mark : sig val neutr : t -> t - val set_norm : t -> t + val set_ntrl : t -> t end = struct type t = int let[@inline] of_state = function - | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + | Ntrl -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 let[@inline] of_relevance = function | Unknown -> 0 @@ -315,15 +315,15 @@ end = struct | _ -> assert false let[@inline] red_state x = match x land 0b1100 with - | 0b0000 -> Norm + | 0b0000 -> Ntrl | 0b0100 -> Cstr | 0b1000 -> Whnf | 0b1100 -> Red | _ -> assert false - let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + let[@inline] neutr x = x lor 0b1000 (* Whnf|Ntrl -> Whnf | Red|Cstr -> Red *) - let[@inline] set_norm x = x land 0b0011 + let[@inline] set_ntrl x = x land 0b0011 end let mark = Mark.mark @@ -358,10 +358,10 @@ and fterm = and finvert = Univ.Instance.t * fconstr array let fterm_of v = v.term -let set_norm v = v.mark <- Mark.set_norm v.mark -let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false +let set_ntrl v = v.mark <- Mark.set_ntrl v.mark +let is_val v = match Mark.red_state v.mark with Ntrl -> true | Cstr | Whnf | Red -> false -let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_atom c = {mark=mark Ntrl Unknown;term=FAtom c} let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose @@ -448,7 +448,7 @@ let rec lft_fconstr n ft = let r = Mark.relevance ft.mark in match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _|FFloat _) -> ft - | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FRel i -> {mark=mark Ntrl r;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} @@ -466,7 +466,7 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} + | Inr(k,None) -> {mark=mark Ntrl Unknown; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} @@ -488,7 +488,7 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Ntrl | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -514,8 +514,8 @@ let mk_clos e t = | Rel i -> clos_rel e i | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } - | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Meta _ | Sort _ -> {mark = mark Ntrl KnownR; term = FAtom t } + | Ind kn -> {mark = mark Ntrl KnownR; term = FInd kn } | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } | Int i -> {mark = mark Cstr Unknown; term = FInt i} | Float f -> {mark = mark Cstr Unknown; term = FFloat f} @@ -734,11 +734,11 @@ let strip_update_shift_app_red head stk = strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -787,7 +787,7 @@ let rec eta_expand_stack = function | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Ntrl Unknown; term= FRel 1}|]] (* Get the arguments of a native operator *) let rec skip_native_args rargs nargs = @@ -968,7 +968,7 @@ module FNativeEntries = | FArray (_u,t,_ty) -> t | _ -> raise Not_found - let dummy = {mark = mark Norm KnownR; term = FRel 0} + let dummy = {mark = mark Ntrl KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty let defined_int = ref false @@ -978,7 +978,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_int63 with | Some c -> defined_int := true; - fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + fint := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false let defined_float = ref false @@ -988,7 +988,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_float64 with | Some c -> defined_float := true; - ffloat := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + ffloat := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_float := false let defined_bool = ref false @@ -1039,7 +1039,7 @@ module FNativeEntries = fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) }; let (icmp, _) = cEq in - fcmp := { mark = mark Norm KnownR; term = FInd (Univ.in_punivs icmp) } + fcmp := { mark = mark Ntrl KnownR; term = FInd (Univ.in_punivs icmp) } | None -> defined_cmp := false let defined_f_cmp = ref false @@ -1327,19 +1327,19 @@ let rec knr info tab m stk = let rargs, a, nargs, stk = get_native_args1 op c stk in kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) else - (* Similarly to fix, partially applied primitives are not Norm! *) + (* Similarly to fix, partially applied primitives are not Ntrl! *) (m, stk) - | Undef _ | OpaqueDef _ -> (set_norm m; (m,stk))) + | Undef _ | OpaqueDef _ -> (set_ntrl m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info tab (RelKey k) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in @@ -1523,9 +1523,9 @@ let norm_val info tab v = with_stats (lazy (kl info tab v)) let whd_stack infos tab m stk = match Mark.red_state m.mark with -| Whnf | Norm -> +| Whnf | Ntrl -> (** No need to perform [kni] nor to unlock updates because - every head subterm of [m] is [Whnf] or [Norm] *) + every head subterm of [m] is [Whnf] or [Ntrl] *) knh infos m stk | Red | Cstr -> let k = kni infos tab m stk in diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index f052e03cde..dc2cd349ce 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -104,11 +104,9 @@ let opcodes = "MAKEPROD"; "BRANCH"; "CHECKADDINT63"; - "ADDINT63"; "CHECKADDCINT63"; "CHECKADDCARRYCINT63"; "CHECKSUBINT63"; - "SUBINT63"; "CHECKSUBCINT63"; "CHECKSUBCARRYCINT63"; "CHECKMULINT63"; @@ -127,21 +125,15 @@ let opcodes = "CHECKLSRINT63CONST1"; "CHECKEQINT63"; "CHECKLTINT63"; - "LTINT63"; "CHECKLEINT63"; - "LEINT63"; "CHECKCOMPAREINT63"; "CHECKHEAD0INT63"; "CHECKTAIL0INT63"; - "ISINT"; - "AREINT2"; "CHECKOPPFLOAT"; "CHECKABSFLOAT"; "CHECKEQFLOAT"; "CHECKLTFLOAT"; - "LTFLOAT"; "CHECKLEFLOAT"; - "LEFLOAT"; "CHECKCOMPAREFLOAT"; "CHECKCLASSIFYFLOAT"; "CHECKADDFLOAT"; @@ -155,10 +147,12 @@ let opcodes = "CHECKLDSHIFTEXP"; "CHECKNEXTUPFLOAT"; "CHECKNEXTDOWNFLOAT"; - "ISINT_CAML_CALL2"; - "ISARRAY_CAML_CALL1"; - "ISARRAY_INT_CAML_CALL2"; - "ISARRAY_INT_CAML_CALL3"; + "CHECKNEXTUPFLOATINPLACE"; + "CHECKNEXTDOWNFLOATINPLACE"; + "CHECKCAMLCALL2_1"; + "CHECKCAMLCALL1"; + "CHECKCAMLCALL2"; + "CHECKCAMLCALL3_1"; "STOP" |] diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index c156a21c86..4977aec00a 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -56,13 +56,12 @@ type instruction = | Kfield of int | Ksetfield of int | Kstop - | Ksequence of bytecodes * bytecodes + | Ksequence of bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int | Kbranch of Label.t (* jump to label *) - | Kprim of CPrimitives.t * pconstant option + | Kprim of CPrimitives.t * pconstant | Kcamlprim of CPrimitives.t * Label.t - | Kareint of int and bytecodes = instruction list @@ -146,21 +145,19 @@ let rec pp_instr i = | Kensurestackcapacity size -> str "growstack " ++ int size | Kprim (op, id) -> str (CPrimitives.to_string op) ++ str " " ++ - (match id with Some (id,_u) -> Constant.print id | None -> str "") + (Constant.print (fst id)) | Kcamlprim (op, lbl) -> str "camlcall " ++ str (CPrimitives.to_string op) ++ spc () ++ pp_lbl lbl - | Kareint n -> str "areint " ++ int n - and pp_bytecodes c = match c with | [] -> str "" | Klabel lbl :: c -> str "L" ++ int lbl ++ str ":" ++ fnl () ++ pp_bytecodes c - | Ksequence (l1, l2) :: c -> - pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c + | Ksequence l :: c -> + pp_bytecodes l ++ pp_bytecodes c | i :: c -> pp_instr i ++ fnl () ++ pp_bytecodes c diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index b703058fb7..003a77ab78 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -54,14 +54,13 @@ type instruction = | Kfield of int (** accu = accu[n] *) | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop - | Ksequence of bytecodes * bytecodes + | Ksequence of bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int | Kbranch of Label.t (** jump to label, is it needed ? *) - | Kprim of CPrimitives.t * pconstant option + | Kprim of CPrimitives.t * pconstant | Kcamlprim of CPrimitives.t * Label.t - | Kareint of int and bytecodes = instruction list diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 16a0f42664..70c92fd8f0 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -315,12 +315,10 @@ let pos_evar evk r = (* non-terminating instruction (branch, raise, return, appterm) *) (* in front of it. *) -let discard_dead_code cont = cont -(*function - [] -> [] +let rec discard_dead_code = function + | [] -> [] | (Klabel _ | Krestart ) :: _ as cont -> cont | _ :: cont -> discard_dead_code cont -*) (* Return a label to the beginning of the given continuation. *) (* If the sequence starts with a branch, use the target of that branch *) @@ -581,7 +579,7 @@ let rec compile_lam env cenv lam sz cont = let cont_fun = ensure_stack_capacity (compile_lam env r_fun body arity) [Kreturn arity] in - fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; + fun_code := Ksequence (add_grab arity lbl_fun cont_fun) :: !fun_code; let fv = fv r_fun in compile_fv cenv fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) @@ -604,7 +602,7 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; (* Compiling bodies *) for i = 0 to ndef - 1 do @@ -617,7 +615,7 @@ let rec compile_lam env cenv lam sz cont = let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; let fv = !rfv in compile_fv cenv fv.fv_rev sz @@ -637,7 +635,7 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; (* Compiling bodies *) for i = 0 to ndef - 1 do @@ -652,25 +650,13 @@ let rec compile_lam env cenv lam sz cont = in let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; - fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; + fun_code := Ksequence (add_grab (arity+1) lbl cont) :: !fun_code; done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - | Lif(t, bt, bf) -> - let branch, cont = make_branch cont in - let lbl_true = Label.create() in - let lbl_false = Label.create() in - compile_lam env cenv t sz - (Kswitch([|lbl_true;lbl_false|],[||]) :: - Klabel lbl_false :: - compile_lam env cenv bf sz - (branch :: - Klabel lbl_true :: - compile_lam env cenv bt sz cont)) - | Lcase(ci,rtbl,t,a,branches) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env in @@ -688,7 +674,7 @@ let rec compile_lam env cenv lam sz cont = ensure_stack_capacity (compile_lam env cenv t sz) [Kpop sz; Kstop] in let lbl_typ,fcode = label_code fcode in - fun_code := [Ksequence(fcode,!fun_code)]; + fun_code := Ksequence fcode :: !fun_code; (* Compilation of the branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = @@ -700,6 +686,7 @@ let rec compile_lam env cenv lam sz cont = | _ -> assert false in + let cont = discard_dead_code cont in let c = ref cont in (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin @@ -770,7 +757,7 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont - | Lprim (Some (kn,u), op, args) when is_caml_prim op -> + | Lprim ((kn,u), op, args) when is_caml_prim op -> let arity = CPrimitives.arity op in let nparams = CPrimitives.nparams op in let nargs = arity - nparams in @@ -788,7 +775,7 @@ let rec compile_lam env cenv lam sz cont = if Int.equal nparams 0 then cont else comp_args (compile_lam env) cenv (Array.sub args 0 nparams) (sz + nargs) (Kpush::cont) in - fun_code := [Ksequence(default, !fun_code)]; + fun_code := Ksequence default :: !fun_code; comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz (Kcamlprim (op, lbl_default) :: cont) | Lprim (kn, op, args) -> @@ -878,7 +865,7 @@ let compile ~fail_on_error ?universes:(universes=0) env c = ensure_stack_capacity (compile_lam env r_fun body full_arity) [Kreturn full_arity] in - fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; + fun_code := Ksequence (add_grab full_arity lbl_fun cont_fun) :: !fun_code; let fv = fv r_fun in let init_code = ensure_stack_capacity (compile_fv cenv fv.fv_rev 0) diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index babc57794b..c1d8fcb855 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -208,14 +208,6 @@ let slot_for_caml_prim env op = (* Emission of one instruction *) -let nocheck_prim_op = function - | Int63add -> opADDINT63 - | Int63sub -> opSUBINT63 - | Int63lt -> opLTINT63 - | Int63le -> opLEINT63 - | _ -> assert false - - let check_prim_op = function | Int63head0 -> opCHECKHEAD0INT63 | Int63tail0 -> opCHECKTAIL0INT63 @@ -259,11 +251,20 @@ let check_prim_op = function | Float64ldshiftexp -> opCHECKLDSHIFTEXP | Float64next_up -> opCHECKNEXTUPFLOAT | Float64next_down -> opCHECKNEXTDOWNFLOAT - | Arraymake -> opISINT_CAML_CALL2 - | Arrayget -> opISARRAY_INT_CAML_CALL2 - | Arrayset -> opISARRAY_INT_CAML_CALL3 + | Arraymake -> opCHECKCAMLCALL2_1 + | Arrayget -> opCHECKCAMLCALL2 + | Arrayset -> opCHECKCAMLCALL3_1 | Arraydefault | Arraycopy | Arraylength -> - opISARRAY_CAML_CALL1 + opCHECKCAMLCALL1 + +let inplace_prim_op = function + | Float64next_up | Float64next_down -> true + | _ -> false + +let check_prim_op_inplace = function + | Float64next_up -> opCHECKNEXTUPFLOATINPLACE + | Float64next_down -> opCHECKNEXTDOWNFLOATINPLACE + | _ -> assert false let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -354,10 +355,7 @@ let emit_instr env = function | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size | Kbranch lbl -> out env opBRANCH; out_label env lbl - | Kprim (op,None) -> - out env (nocheck_prim_op op) - - | Kprim(op,Some (q,_u)) -> + | Kprim (op, (q,_u)) -> out env (check_prim_op op); slot_for_getglobal env q @@ -366,13 +364,8 @@ let emit_instr env = function out_label env lbl; slot_for_caml_prim env op - | Kareint 1 -> out env opISINT - | Kareint 2 -> out env opAREINT2; - | Kstop -> out env opSTOP - | Kareint _ -> assert false - (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) let rec emit env insns remaining = match insns with @@ -406,8 +399,14 @@ let rec emit env insns remaining = match insns with emit env c remaining | Kpop n :: Kjump :: c -> out env opRETURN; out_int env n; emit env c remaining - | Ksequence(c1,c2)::c -> - emit env c1 (c2::c::remaining) + | Ksequence c1 :: c -> + emit env c1 (c :: remaining) + | Kprim (op1, (q1, _)) :: Kprim (op2, (q2, _)) :: c when inplace_prim_op op2 -> + out env (check_prim_op op1); + slot_for_getglobal env q1; + out env (check_prim_op_inplace op2); + slot_for_getglobal env q2; + emit env c remaining (* Default case *) | instr :: c -> emit_instr env instr; emit env c remaining diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 332a331a7a..9cca204e8c 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -19,10 +19,8 @@ type lambda = | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant - | Lprim of pconstant option * CPrimitives.t * lambda array - (* No check if None *) + | Lprim of pconstant * CPrimitives.t * lambda array | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lif of lambda * lambda * lambda | Lfix of (int array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int @@ -112,10 +110,6 @@ let rec pp_lam lam = pp_names ids ++ str " => " ++ pp_lam c) (Array.to_list branches.nonconstant_branches))) ++ cut() ++ str "end") - | Lif (t, bt, bf) -> - v 0 (str "(if " ++ pp_lam t ++ - cut () ++ str "then " ++ pp_lam bt ++ - cut() ++ str "else " ++ pp_lam bf ++ str ")") | Lfix((t,i),(lna,tl,bl)) -> let fixl = Array.mapi (fun i id -> (id,t.(i),tl.(i),bl.(i))) lna in hov 1 @@ -148,16 +142,11 @@ let rec pp_lam lam = | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i - | Lprim(Some (kn,_u),_op,args) -> + | Lprim ((kn,_u),_op,args) -> hov 1 (str "(PRIM " ++ pr_con kn ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") - | Lprim(None,op,args) -> - hov 1 - (str "(PRIM_NC " ++ str (CPrimitives.to_string op) ++ spc() ++ - prlist_with_sep spc pp_lam (Array.to_list args) ++ - str")") | Lproj(p,arg) -> hov 1 (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg @@ -237,11 +226,6 @@ let map_lam_with_binders g f n lam = in if t == t' && a == a' && branches == branches' then lam else Lcase(ci,rtbl,t',a',branches') - | Lif(t,bt,bf) -> - let t' = f n t in - let bt' = f n bt in - let bf' = f n bf in - if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.Smart.map (f n) ltypes in let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in @@ -312,28 +296,6 @@ let can_subst lam = | Lval _ | Lsort _ | Lind _ -> true | _ -> false - -let can_merge_if bt bf = - match bt, bf with - | Llam(_idst,_), Llam(_idsf,_) -> true - | _ -> false - -let merge_if t bt bf = - let (idst,bodyt) = decompose_Llam bt in - let (idsf,bodyf) = decompose_Llam bf in - let nt = Array.length idst in - let nf = Array.length idsf in - let common,idst,idsf = - if nt = nf then idst, [||], [||] - else - if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) - else idsf, Array.sub idst nf (nt - nf), [||] in - Llam(common, - Lif(lam_lift (Array.length common) t, - mkLlam idst bodyt, - mkLlam idsf bodyf)) - - let rec simplify subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst @@ -352,14 +314,6 @@ let rec simplify subst lam = | lam' -> lam' end - | Lif(t,bt,bf) -> - let t' = simplify subst t in - let bt' = simplify subst bt in - let bf' = simplify subst bf in - if can_merge_if bt' bf' then merge_if t' bt' bf' - else - if t == t' && bt == bt' && bf == bf' then lam - else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = @@ -442,9 +396,6 @@ let rec occurrence k kind lam = in Array.iter on_b branches.nonconstant_branches; !r - | Lif (t, bt, bf) -> - let kind = occurrence k kind t in - kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> let kind = occurrence_args k kind ltypes in @@ -566,7 +517,7 @@ let rec get_alias env kn = (* Compilation of primitive *) let prim kn p args = - Lprim(Some kn, p, args) + Lprim (kn, p, args) let expand_prim kn op arity = (* primitives are always Relevant *) diff --git a/kernel/vmlambda.mli b/kernel/vmlambda.mli index bd11c2667f..ad5f81638f 100644 --- a/kernel/vmlambda.mli +++ b/kernel/vmlambda.mli @@ -12,10 +12,8 @@ type lambda = | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant - | Lprim of pconstant option * CPrimitives.t * lambda array - (* No check if None *) + | Lprim of pconstant * CPrimitives.t * lambda array | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lif of lambda * lambda * lambda | Lfix of (int array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 7b4101b9d0..9944458d6b 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -381,7 +381,15 @@ let rec whd_accu a stk = CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") -external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" +[@@@warning "-37"] +type vm_closure_kind = + | VCfun (** closure, or fixpoint applied past the recursive argument *) + | VCfix (** unapplied fixpoint *) + | VCfix_partial (** partially applied fixpoint, but not sufficiently for recursion *) + | VCaccu (** accumulator *) +[@@@warning "+37"] + +external kind_of_closure : Obj.t -> vm_closure_kind = "coq_kind_of_closure" external is_accumulate : tcode -> bool = "coq_is_accumulate_code" external int_tcode : tcode -> int -> int = "coq_int_tcode" external accumulate : unit -> tcode = "accumulate_code" @@ -400,12 +408,11 @@ let whd_val (v: values) = else if Int.equal tag Obj.closure_tag && is_accumulate (fun_code o) then whd_accu o [] else if Int.equal tag Obj.closure_tag || Int.equal tag Obj.infix_tag then - (match kind_of_closure o with - | 0 -> Vfun(Obj.obj o) - | 1 -> Vfix(Obj.obj o, None) - | 2 -> Vfix(Obj.obj (Obj.field o 2), Some (Obj.obj o)) - | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + match kind_of_closure o with + | VCfun -> Vfun (Obj.obj o) + | VCfix -> Vfix (Obj.obj o, None) + | VCfix_partial -> Vfix (Obj.obj (Obj.field o 2), Some (Obj.obj o)) + | VCaccu -> Vatom_stk (Aid (RelKey (int_tcode (fun_code o) 1)), []) else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else 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 236de65462..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: @@ -234,9 +234,7 @@ GRAMMAR EXTEND Gram ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } - | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) - { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] + | "-"; nl = LIST1 nat_or_var -> { AllOccurrencesBut nl } ] ] ; occs: [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] @@ -379,9 +377,11 @@ GRAMMAR EXTEND Gram { {onhyps=None; concl_occs=occs} } | "*"; "|-"; occs=concl_occ -> { {onhyps=None; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + | "|-"; occs=concl_occ -> + { {onhyps=Some []; concl_occs=occs} } + | hl = LIST1 hypident_occ SEP ","; "|-"; occs=concl_occ -> { {onhyps=Some hl; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP"," -> + | hl = LIST1 hypident_occ SEP "," -> { {onhyps=Some hl; concl_occs=NoOccurrences} } ] ] ; clause_dft_concl: @@ -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/ring/ring.ml b/plugins/ring/ring.ml index 9c75175889..292fbefb84 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -71,7 +71,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - CErrors.user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") + CErrors.user_err ~hdr:"lookup_map" (str"Map "++qs map++str"not found") let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in @@ -135,15 +135,11 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" (****************************************************************************) -let ic c = - let env = Global.env() in - let sigma = Evd.from_env env in +let ic env sigma c = let c, uctx = Constrintern.interp_constr env sigma c in (Evd.from_ctx uctx, c) -let ic_unsafe c = (*FIXME remove *) - let env = Global.env() in - let sigma = Evd.from_env env in +let ic_unsafe env sigma c = (*FIXME remove *) fst (Constrintern.interp_constr env sigma c) let decl_constant name univs c = @@ -170,8 +166,8 @@ let dummy_goal env sigma = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp in {Evd.it = gl; Evd.sigma = sigma} -let constr_of evd v = match Value.to_constr v with - | Some c -> EConstr.to_constr evd c +let constr_of sigma v = match Value.to_constr v with + | Some c -> EConstr.to_constr sigma c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -189,7 +185,7 @@ let get_res = Tacenv.register_ml_tactic name [| tac |]; entry -let exec_tactic env evd n f args = +let exec_tactic env sigma n f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar CAst.(make id)) in @@ -203,11 +199,11 @@ let exec_tactic env evd n f args = let get_res = TacML (CAst.make (get_res, [TacGeneric (None, n)])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (* Evaluate the whole result *) - let gl = dummy_goal env evd in + let gl = dummy_goal env sigma in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in - let evd = Evd.minimize_universes gls.Evd.sigma in - let nf c = constr_of evd c in - Array.map nf !tactic_res, Evd.universe_context_set evd + let sigma = Evd.minimize_universes gls.Evd.sigma in + let nf c = constr_of sigma c in + Array.map nf !tactic_res, Evd.universe_context_set sigma let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) @@ -222,10 +218,9 @@ let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evdref f args = - let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in - evdref := evd; - mkApp(fc,args) +let plapp sigma f args = + let sigma, fc = Evarutil.new_global sigma (Lazy.force f) in + sigma, mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -351,14 +346,14 @@ let find_ring_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"ring" - (str"arguments of ring_simplify do not have all the same type") + (str"Arguments of ring_simplify do not have all the same type.") in List.iter check cl'; (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"ring" - (str"cannot find a declared ring structure over"++ - spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) + (str"Cannot find a declared ring structure over"++ + spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\".")) | [] -> assert false let add_entry e = @@ -411,16 +406,14 @@ let theory_to_obj : ring_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -let setoid_of_relation env evd a r = +let setoid_of_relation env sigma a r = try - let evm = !evd in - let evm, refl = Rewrite.get_reflexive_proof env evm a r in - let evm, sym = Rewrite.get_symmetric_proof env evm a r in - let evm, trans = Rewrite.get_transitive_proof env evm a r in - evd := evm; - lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] + let sigma, refl = Rewrite.get_reflexive_proof env sigma a r in + let sigma, sym = Rewrite.get_symmetric_proof env sigma a r in + let sigma, trans = Rewrite.get_transitive_proof env sigma a r in + sigma, lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> - error "cannot find setoid relation" + CErrors.user_err (str "Cannot find a setoid structure for relation " ++ pr_econstr_env env sigma r ++ str ".") let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] @@ -428,61 +421,59 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -let ring_equality env evd (r,add,mul,opp,req) = - match EConstr.kind !evd req with - | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let setoid = plapp evd coq_eq_setoid [|r|] in - let op_morph = +let ring_equality env sigma (r,add,mul,opp,req) = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> + let sigma, setoid = plapp sigma coq_eq_setoid [|r|] in + let sigma, op_morph = match opp with - Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] - | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let sigma = !evd in + Some opp -> plapp sigma coq_eq_morph [|r;add;mul;opp|] + | None -> plapp sigma coq_eq_smorph [|r;add;mul|] in let sigma, setoid = Typing.solve_evars env sigma setoid in let sigma, op_morph = Typing.solve_evars env sigma op_morph in - evd := sigma; (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) evd r req in + let sigma, setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> - error "ring addition should be declared as a morphism" in + CErrors.user_err (str "Ring addition " ++ pr_econstr_env env sigma add ++ str " should be declared as a morphism.") in let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> - error "ring multiplication should be declared as a morphism" in + CErrors.user_err (str "Ring multiplication " ++ pr_econstr_env env sigma mul ++ str " should be declared as a morphism.") in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> - error "ring opposite should be declared as a morphism" in + CErrors.user_err (str "Ring opposite " ++ pr_econstr_env env sigma opp ++ str " should be declared as a morphism.") in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ - str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ - str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ + (str"Using setoid \""++ pr_econstr_env env sigma req++str"\""++spc()++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ + str"\","++spc()++ str"\""++pr_econstr_env env sigma mul_m++ + str"\""++spc()++str"and \""++pr_econstr_env env sigma opp_m++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ + (str"Using setoid \""++pr_econstr_env env sigma req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ str"\""++spc()++str"and \""++ - pr_econstr_env env !evd mul_m_lem++str"\""); + pr_econstr_env env sigma mul_m++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) -let build_setoid_params env evd r add mul opp req eqth = +let build_setoid_params env sigma r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality env evd (r,add,mul,opp,req) + | None -> ring_equality env sigma (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in @@ -515,71 +506,69 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in TacArg(CAst.make (TacCall(CAst.make (t,[])))) -let make_hyp env evd c = - let t = Retyping.get_type_of env !evd c in - plapp evd coq_mkhypo [|t;c|] +let make_hyp env sigma c = + let t = Retyping.get_type_of env sigma c in + plapp sigma coq_mkhypo [|t;c|] -let make_hyp_list env evdref lH = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; - let l = +let make_hyp_list env sigma lH = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in + let sigma, l = List.fold_right - (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH - (plapp evdref coq_nil [|carrier|]) + (fun c (sigma,l) -> + let sigma, c = make_hyp env sigma c in + plapp sigma coq_cons [|carrier; c; l|]) lH + (plapp sigma coq_nil [|carrier|]) in - let sigma, l' = Typing.solve_evars env !evdref l in - evdref := sigma; + let sigma, l' = Typing.solve_evars env sigma l in let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evdref l' + sigma, Evarutil.nf_evars_universes sigma l' -let interp_power env evdref pow = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_power env sigma pow = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) + let sigma, c = plapp sigma coq_None [|carrier|] in + sigma, (TacArg(CAst.make (TacCall(CAst.make (t,[])))), c) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evdref (ic_unsafe spec) in - (tac, plapp evdref coq_Some [|carrier; spec|]) + let spec = ic_unsafe env sigma spec in + let sigma, spec = make_hyp env sigma spec in + let sigma, pow = plapp sigma coq_Some [|carrier; spec|] in + sigma, (tac, pow) -let interp_sign env evdref sign = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_sign env sigma sign = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match sign with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evdref div = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_div env sigma div = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match div with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = +let add_theory0 env sigma name rth eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); - let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let evd = ref sigma in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd div in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma div in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 5 (zltac "ring_lemmas") + exec_tactic env sigma 5 (zltac "ring_lemmas") [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -619,16 +608,16 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div ring_post_tac = posttac }) in () -let ic_coeff_spec = function - | Computational t -> Computational (ic_unsafe t) - | Morphism t -> Morphism (ic_unsafe t) +let ic_coeff_spec env sigma = function + | Computational t -> Computational (ic_unsafe env sigma t) + | Morphism t -> Morphism (ic_unsafe env sigma t) | Abstract -> Abstract let set_once s r v = if Option.is_empty !r then r := Some v else error (s^" cannot be set twice") -let process_ring_mods l = +let process_ring_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -638,11 +627,11 @@ let process_ring_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k) + Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec env sigma k) | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; @@ -650,9 +639,11 @@ let process_ring_mods l = (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) let add_theory id rth l = - let (sigma, rth) = ic rth in - let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory0 id (sigma, rth) set k cst (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, rth = ic env sigma rth in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods env sigma l in + add_theory0 env sigma id rth set k cst (pre,post) power sign div (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and @@ -663,13 +654,12 @@ let make_args_list sigma rl t = | [] -> let (_,t1,t2) = dest_rel0 sigma t in [t1;t2] | _ -> rl -let make_term_list env evd carrier rl = - let l = List.fold_right - (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl - (plapp evd coq_nil [|carrier|]) +let make_term_list env sigma carrier rl = + let sigma, l = List.fold_right + (fun x (sigma,l) -> plapp sigma coq_cons [|carrier;x;l|]) rl + (plapp sigma coq_nil [|carrier|]) in - let sigma, l = Typing.solve_evars env !evd l in - evd := sigma; l + Typing.solve_evars env sigma l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -695,12 +685,13 @@ let ring_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rl = make_args_list sigma rl t in - let evdref = ref sigma in let e = find_ring_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in + let sigma, l = make_term_list env sigma (EConstr.of_constr e.ring_carrier) rl in + let rl = Value.of_constr l in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (ring@[lH;rl])) end (***********************************************************************) @@ -758,23 +749,23 @@ let sfield_theory = my_reference "semi_field_theory" let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" -let dest_field env evd th_spec = - let th_typ = Retyping.get_type_of env !evd th_spec in - match EConstr.kind !evd th_typ with +let dest_field env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match EConstr.kind sigma th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force afield_theory) f -> - let rth = plapp evd af_ar + when isRefX sigma (Lazy.force afield_theory) f -> + let sigma, rth = plapp sigma af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force field_theory) f -> - let rth = - plapp evd f_r + when isRefX sigma (Lazy.force field_theory) f -> + let sigma, rth = + plapp sigma f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when isRefX !evd (Lazy.force sfield_theory) f -> - let rth = plapp evd sf_sr + when isRefX sigma (Lazy.force sfield_theory) f -> + let sigma, rth = plapp sigma sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" @@ -804,14 +795,14 @@ let find_field_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"field" - (str"arguments of field_simplify do not have all the same type") + (str"Arguments of field_simplify do not have all the same type.") in List.iter check cl'; (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"field" - (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) + (str"Cannot find a declared field structure over"++ + spc()++str"\""++pr_econstr_env env sigma ty++str"\".")) | [] -> assert false let add_field_entry e = @@ -860,14 +851,14 @@ let ftheory_to_obj : field_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -let field_equality evd r inv req = - match EConstr.kind !evd req with - | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> +let field_equality env sigma r inv req = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> let c = UnivGen.constr_of_monomorphic_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) evd r req in + let _setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -875,24 +866,22 @@ let field_equality evd r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory0 env sigma name fth eqth morphth cst_tac inj (pre,post) power sign odiv = let open Constr in check_required_library (cdir@["Field_tac"]); - let (sigma,fth) = ic fth in - let env = Global.env() in - let evd = ref sigma in + let (sigma,fth) = ic env sigma fth in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env evd fth in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + dest_field env sigma fth in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory0 name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd odiv in - let inv_m = field_equality evd r inv req in + let _ = add_theory0 env sigma name rth eqth morphth cst_tac (None,None) power sign odiv in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma odiv in + let inv_m = field_equality env sigma r inv req in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 9 (field_ltac"field_lemmas") + exec_tactic env sigma 9 (field_ltac"field_lemmas") [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -940,7 +929,7 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od field_pre_tac = pretac; field_post_tac = posttac }) in () -let process_field_mods l = +let process_field_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -951,22 +940,24 @@ let process_field_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k) + Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec env sigma k) | Ring_mod(Const_tac t) -> set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; + | Inject i -> set_once "infinite property" inj (ic_unsafe env sigma i)) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) + (env, sigma, k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) let add_field_theory id t mods = - let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods mods in - add_field_theory0 id t set k cst_tac inj (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let (env,sigma,k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods env sigma mods in + add_field_theory0 env sigma id t set k cst_tac inj (pre,post) power sign div let ltac_field_structure e = let req = carg e.field_req in @@ -987,10 +978,11 @@ let field_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rl = make_args_list sigma rl t in - let evdref = ref sigma in let e = find_field_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in + let sigma, c = make_term_list env sigma (EConstr.of_constr e.field_carrier) rl in + let rl = Value.of_constr c in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (field@[lH;rl])) 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/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index bd514f15d5..a4aa08300d 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -454,7 +454,7 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = - List.length (snd (lookup_canonical_conversion (GlobRef.ConstRef pc, k))).o_TCOMPS in + List.length (snd (lookup_canonical_conversion (Global.env()) (GlobRef.ConstRef pc, k))).o_TCOMPS in let nargs_of_proj t = match kind t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be 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/evarconv.ml b/pretyping/evarconv.ml index 00d4c7b3d8..cdf2922516 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -244,24 +244,20 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then - lookup_canonical_conversion (proji, Prod_cs), + lookup_canonical_conversion env (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> let s = ESorts.kind sigma s in - lookup_canonical_conversion + lookup_canonical_conversion env (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> - let c2 = GlobRef.ConstRef (Projection.constant p) in - let c = Retyping.expand_projection env sigma p c [] in - let _, args = destApp sigma c in - let sk2 = Stack.append_app args sk2 in - lookup_canonical_conversion (proji, Const_cs c2), sk2 + lookup_canonical_conversion env (proji, Proj_cs (Projection.repr p)), Stack.append_app [|c|] sk2 | _ -> let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in - lookup_canonical_conversion (proji, Const_cs c2),sk2 + lookup_canonical_conversion env (proji, Const_cs c2),sk2 with Not_found -> - let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in + let (c, cs) = lookup_canonical_conversion env (proji,Default_cs) in (c,cs),[] in let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; @@ -273,6 +269,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = + (* Are we sure that ty is not an evar? *) try Inductiveops.find_mrectype env sigma ty with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index e6e5ad8dd4..b6e44265ae 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -144,19 +144,21 @@ type obj_typ = { type cs_pattern = Const_cs of GlobRef.t + | Proj_cs of Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs -let eq_cs_pattern p1 p2 = match p1, p2 with -| Const_cs gr1, Const_cs gr2 -> GlobRef.equal gr1 gr2 +let eq_cs_pattern env p1 p2 = match p1, p2 with +| Const_cs gr1, Const_cs gr2 -> Environ.QGlobRef.equal env gr1 gr2 +| Proj_cs p1, Proj_cs p2 -> Environ.QProjection.Repr.equal env p1 p2 | Prod_cs, Prod_cs -> true | Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 | Default_cs, Default_cs -> true | _ -> false -let rec assoc_pat a = function - | ((pat, t), e) :: xs -> if eq_cs_pattern pat a then (t, e) else assoc_pat a xs +let rec assoc_pat env a = function + | ((pat, t), e) :: xs -> if eq_cs_pattern env pat a then (t, e) else assoc_pat env a xs | [] -> raise Not_found @@ -179,10 +181,7 @@ let rec cs_pattern_of_constr env t = patt, n, args @ Array.to_list vargs | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] - | Proj (p, c) -> - let ty = Retyping.get_type_of_constr env c in - let _, params = Inductive.find_rectype env ty in - Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] + | Proj (p, c) -> Proj_cs (Projection.repr p), None, [c] | Sort s -> Sort_cs (Sorts.family s), None, [] | _ -> Const_cs (fst @@ destRef t) , None, [] @@ -238,6 +237,7 @@ let compute_canonical_projections env ~warn (gref,ind) = let pr_cs_pattern = function Const_cs c -> Nametab.pr_global_env Id.Set.empty c + | Proj_cs p -> Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef (Projection.Repr.constant p)) | Prod_cs -> str "_ -> _" | Default_cs -> str "_" | Sort_cs s -> Sorts.pr_sort_family s @@ -253,7 +253,7 @@ let register_canonical_structure ~warn env sigma o = compute_canonical_projections env ~warn o |> List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in - match assoc_pat cs_pat l with + match assoc_pat env cs_pat l with | exception Not_found -> object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table | _, cs -> @@ -320,8 +320,8 @@ let check_and_decompose_canonical_structure env sigma ref = error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (ref,indsp) -let lookup_canonical_conversion (proj,pat) = - assoc_pat pat (GlobRef.Map.find proj !object_table) +let lookup_canonical_conversion env (proj,pat) = + assoc_pat env pat (GlobRef.Map.find proj !object_table) let decompose_projection sigma c args = match EConstr.kind sigma c with diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 3be60d5e62..5b8dc8184a 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -67,6 +67,7 @@ val find_primitive_projection : Constant.t -> Projection.Repr.t option (** A cs_pattern characterizes the form of a component of canonical structure *) type cs_pattern = Const_cs of GlobRef.t + | Proj_cs of Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs @@ -88,7 +89,7 @@ val pr_cs_pattern : cs_pattern -> Pp.t type cs = GlobRef.t * inductive -val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ +val lookup_canonical_conversion : Environ.env -> (GlobRef.t * cs_pattern) -> constr * obj_typ val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> cs -> unit val subst_canonical_structure : Mod_subst.substitution -> cs -> cs diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 4bd22e76cb..34bcd0982c 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -67,6 +67,14 @@ let get_type_from_constraints env sigma t = | _ -> raise Not_found else raise Not_found +let sort_of_arity_with_constraints env sigma t = + try Reductionops.sort_of_arity env sigma t + with Reduction.NotArity -> + try + let t = get_type_from_constraints env sigma t in + Reductionops.sort_of_arity env sigma t + with Not_found | Reduction.NotArity -> retype_error NotAnArity + let rec subst_type env sigma typ = function | [] -> typ | h::rest -> @@ -187,9 +195,7 @@ let retype ?(polyprop=true) sigma = let mip = lookup_mind_specif env ind in let paramtyps = Array.map_to_list (fun arg () -> let t = type_of env arg in - let s = try Reductionops.sort_of_arity env sigma t - with Reduction.NotArity -> retype_error NotAnArity - in + let s = sort_of_arity_with_constraints env sigma t in Sorts.univ_of_sort (ESorts.kind sigma s)) args in 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/stm/stm.ml b/stm/stm.ml index df7e35beb5..f7d66b7b53 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1003,9 +1003,9 @@ end = struct (* {{{ *) end (* }}} *) (* Wrapper for the proof-closing special path for Qed *) -let stm_qed_delay_proof ?route ~proof ~pinfo ~id ~st ~loc ~control pending : Vernacstate.t = +let stm_qed_delay_proof ?route ~proof ~id ~st ~loc ~control pending : Vernacstate.t = set_id_for_feedback ?route dummy_doc id; - Vernacinterp.interp_qed_delayed_proof ~proof ~pinfo ~st ~control (CAst.make ?loc pending) + Vernacinterp.interp_qed_delayed_proof ~proof ~st ~control (CAst.make ?loc pending) (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly @@ -1470,16 +1470,15 @@ end = struct (* {{{ *) (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) State.unfreeze st; - let pobject, _info = + let pobject = PG_compat.close_future_proof ~feedback_id:stop (Future.from_val proof) in let st = Vernacstate.freeze_interp_state ~marshallable:false in let opaque = Opaque in try let _pstate = - let pinfo = Declare.Proof.Proof_info.default () in stm_qed_delay_proof ~st ~id:stop - ~proof:pobject ~pinfo ~loc ~control:[] (Proved (opaque,None)) in + ~proof:pobject ~loc ~control:[] (Proved (opaque,None)) in () with exn -> (* If [stm_qed_delay_proof] fails above we need to use the @@ -1621,12 +1620,9 @@ end = struct (* {{{ *) else begin let opaque = Opaque in - (* The original terminator, a hook, has not been saved in the .vio*) - let proof, _info = + let proof = PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true in - let pinfo = Declare.Proof.Proof_info.default () in - (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) @@ -1638,7 +1634,7 @@ end = struct (* {{{ *) *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~pinfo ~loc ~control:[] (Proved (opaque,None))); + ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~loc ~control:[] (Proved (opaque,None))); (* Is this name the same than the one in scope? *) let name = Declare.Proof.get_po_name proof in `OK name @@ -2219,13 +2215,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> CErrors.anomaly (Pp.str "Cannot delegate transparent proofs, this is a bug in the STM.") in - let proof, pinfo = + let proof = PG_compat.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in let control, pe = extract_pe x in - ignore(stm_qed_delay_proof ~id ~st ~proof ~pinfo ~loc ~control pe); + ignore(stm_qed_delay_proof ~id ~st ~proof ~loc ~control pe); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; @@ -2264,9 +2260,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in let _st = match proof with | None -> stm_vernac_interp id st x - | Some (proof, pinfo) -> + | Some proof -> let control, pe = extract_pe x in - stm_qed_delay_proof ~id ~st ~proof ~pinfo ~loc ~control pe + stm_qed_delay_proof ~id ~st ~proof ~loc ~control pe in let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" 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_13249.v b/test-suite/bugs/closed/bug_13249.v new file mode 100644 index 0000000000..06f7ddbd3a --- /dev/null +++ b/test-suite/bugs/closed/bug_13249.v @@ -0,0 +1,9 @@ +Global Generalizable All Variables. + +Section test. + Context {A : Type}. + Context `{!foo A}. + + Goal foo A. + Proof. assumption. Defined. +End test. diff --git a/test-suite/bugs/closed/bug_13300.v b/test-suite/bugs/closed/bug_13300.v new file mode 100644 index 0000000000..e4fcd6dacc --- /dev/null +++ b/test-suite/bugs/closed/bug_13300.v @@ -0,0 +1,7 @@ +Polymorphic Definition type := Type. + +Inductive bad : type := . + +Fail Check bad : Prop. +Check bad : Set. +(* lowered as much as possible *) diff --git a/test-suite/bugs/closed/bug_13366.v b/test-suite/bugs/closed/bug_13366.v new file mode 100644 index 0000000000..06918a9266 --- /dev/null +++ b/test-suite/bugs/closed/bug_13366.v @@ -0,0 +1,5 @@ +Class Functor (F : Type -> Type) : Type := + fmap : F nat. + +Fail Definition blah := sum fmap. +(* used to be anomaly not an arity *) 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/bugs/closed/bug_9809.v b/test-suite/bugs/closed/bug_9809.v new file mode 100644 index 0000000000..4a7d2c7fac --- /dev/null +++ b/test-suite/bugs/closed/bug_9809.v @@ -0,0 +1,30 @@ +Section FreeMonad. + + Variable S : Type. + Variable P : S -> Type. + + Inductive FreeF A : Type := + | retFree : A -> FreeF A + | opr : forall s, (P s -> FreeF A) -> FreeF A. + +End FreeMonad. + +Section Fibonnacci. + + Inductive gen_op := call_op : nat -> gen_op. + Definition gen_ty (op : gen_op) := + match op with + | call_op _ => nat + end. + + Fail Definition fib0 (n:nat) : FreeF gen_op gen_ty nat := + match n with + | 0 + | 1 => retFree _ _ _ 1 + | S (S k) => + opr _ _ _ (call_op (S k)) + (fun r1 => opr _ _ _ (call_op k) + (fun r0 => retFree (* _ _ _ *) (r1 + r0))) + end. + +End Fibonnacci. diff --git a/test-suite/bugs/closed/bug_9971.v b/test-suite/bugs/closed/bug_9971.v new file mode 100644 index 0000000000..ef526dcd7d --- /dev/null +++ b/test-suite/bugs/closed/bug_9971.v @@ -0,0 +1,27 @@ +(* Test that it raises a normal error and not an anomaly *) +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments fst {A B} _. +Arguments snd {A B} _. +Arguments pair {A B} _ _. +Record piis := { dep_types : Type; indep_args : dep_types -> Type }. +Import EqNotations. +Goal forall (id : Set) (V : id) (piiio : id -> piis) + (Z : {ridc : id & prod (dep_types (piiio ridc)) True}) + (P : dep_types (piiio V) -> Type) (W : {x : dep_types (piiio V) & P x}), + let ida := fun (x : id) (y : dep_types (piiio x)) => indep_args (piiio x) y in + prod True (ida V (projT1 W)) -> + Z = existT _ V (pair (projT1 W) I) -> + ida (projT1 Z) (fst (projT2 Z)). + intros. + refine (rew <- [fun k' => ida (projT1 k') (fst (projT2 k'))] + H in + let v := I in + _); + refine (snd X). + Undo. +Fail refine (rew <- [fun k' => ida (projT1 k') (fst (projT2 k'))] + H in + let v := I in + snd X). +Abort. 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/output/bug_9569.out b/test-suite/output/bug_9569.out new file mode 100644 index 0000000000..2d474e4933 --- /dev/null +++ b/test-suite/output/bug_9569.out @@ -0,0 +1,16 @@ +1 subgoal + + ============================ + exists I : True, I = Logic.I +1 subgoal + + ============================ + f True False True False (Logic.True /\ Logic.False) +1 subgoal + + ============================ + [I | I = Logic.I; I = Logic.I] = [I | I = Logic.I; I = Logic.I] +1 subgoal + + ============================ + [I & I = Logic.I | I = Logic.I; Logic.I = I] diff --git a/test-suite/output/bug_9569.v b/test-suite/output/bug_9569.v new file mode 100644 index 0000000000..ee5b052811 --- /dev/null +++ b/test-suite/output/bug_9569.v @@ -0,0 +1,18 @@ +Goal exists I, I = Logic.I. +Show. +Abort. + +Notation f x y p q r := ((forall x, p /\ r) /\ forall y, q /\ r). +Goal f True False True False (Logic.True /\ Logic.False). +Show. +Abort. + +Notation "[ x | y ; z ; .. ; t ]" := (pair .. (pair (forall x, y) (forall x, z)) .. (forall x, t)). +Goal [ I | I = Logic.I ; I = Logic.I ] = [ I | I = Logic.I ; I = Logic.I ]. +Show. +Abort. + +Notation "[ x & p | y ; .. ; z ; t ]" := (forall x, p -> y -> .. (forall x, p -> z -> forall x, p -> t) ..). +Goal [ I & I = Logic.I | I = Logic.I ; Logic.I = I ]. +Show. +Abort. diff --git a/test-suite/primitive/float/next_up_down.v b/test-suite/primitive/float/next_up_down.v index 4f8427dc5b..ea45fb3983 100644 --- a/test-suite/primitive/float/next_up_down.v +++ b/test-suite/primitive/float/next_up_down.v @@ -120,3 +120,46 @@ Check (eq_refl (SF64succ (Prim2SF f14)) <<: Prim2SF (next_up f14) = SF64succ (Pr Check (eq_refl (SF64pred (Prim2SF f14)) <<: Prim2SF (next_down f14) = SF64pred (Prim2SF f14)). Check (eq_refl (SF64succ (Prim2SF f15)) <<: Prim2SF (next_up f15) = SF64succ (Prim2SF f15)). Check (eq_refl (SF64pred (Prim2SF f15)) <<: Prim2SF (next_down f15) = SF64pred (Prim2SF f15)). + +Check (eq_refl : next_up nan = nan). +Check (eq_refl : next_down nan = nan). +Check (eq_refl : next_up neg_infinity = -0x1.fffffffffffffp+1023). +Check (eq_refl : next_down neg_infinity = neg_infinity). +Check (eq_refl : next_up (-0x1.fffffffffffffp+1023) = -0x1.ffffffffffffep+1023). +Check (eq_refl : next_down (-0x1.fffffffffffffp+1023) = neg_infinity). +Check (eq_refl : next_up (-0x1.ffffffffffffap+1023) = -0x1.ffffffffffff9p+1023). +Check (eq_refl : next_down (-0x1.ffffffffffffap+1023) = -0x1.ffffffffffffbp+1023). +Check (eq_refl : next_up (-0x1.fffffffffffff) = -0x1.ffffffffffffe). +Check (eq_refl : next_down (-0x1.fffffffffffff) = -0x1p+1). +Check (eq_refl : next_up (-0x1p1) = -0x1.fffffffffffff). +Check (eq_refl : next_down (-0x1p1) = -0x1.0000000000001p+1). +Check (eq_refl : next_up (-0x1p-1022) = -0x0.fffffffffffffp-1022). +Check (eq_refl : next_down (-0x1p-1022) = -0x1.0000000000001p-1022). +Check (eq_refl : next_up (-0x0.fffffffffffffp-1022) = -0x0.ffffffffffffep-1022). +Check (eq_refl : next_down (-0x0.fffffffffffffp-1022) = -0x1p-1022). +Check (eq_refl : next_up (-0x0.01p-1022) = -0x0.00fffffffffffp-1022). +Check (eq_refl : next_down (-0x0.01p-1022) = -0x0.0100000000001p-1022). +Check (eq_refl : next_up (-0x0.0000000000001p-1022) = -0). +Check (eq_refl : next_down (-0x0.0000000000001p-1022) = -0x0.0000000000002p-1022). +Check (eq_refl : next_up (-0) = 0x0.0000000000001p-1022). +Check (eq_refl : next_down (-0) = -0x0.0000000000001p-1022). +Check (eq_refl : next_up 0 = 0x0.0000000000001p-1022). +Check (eq_refl : next_down 0 = -0x0.0000000000001p-1022). +Check (eq_refl : next_up 0x0.0000000000001p-1022 = 0x0.0000000000002p-1022). +Check (eq_refl : next_down 0x0.0000000000001p-1022 = 0). +Check (eq_refl : next_up 0x0.01p-1022 = 0x0.0100000000001p-1022). +Check (eq_refl : next_down 0x0.01p-1022 = 0x0.00fffffffffffp-1022). +Check (eq_refl : next_up 0x0.fffffffffffffp-1022 = 0x1p-1022). +Check (eq_refl : next_down 0x0.fffffffffffffp-1022 = 0x0.ffffffffffffep-1022). +Check (eq_refl : next_up 0x1p-1022 = 0x1.0000000000001p-1022). +Check (eq_refl : next_down 0x1p-1022 = 0x0.fffffffffffffp-1022). +Check (eq_refl : next_up 0x1p1 = 0x1.0000000000001p+1). +Check (eq_refl : next_down 0x1p1 = 0x1.fffffffffffff). +Check (eq_refl : next_up 0x1.fffffffffffff = 0x1p+1). +Check (eq_refl : next_down 0x1.fffffffffffff = 0x1.ffffffffffffe). +Check (eq_refl : next_up 0x1.ffffffffffffap+1023 = 0x1.ffffffffffffbp+1023). +Check (eq_refl : next_down 0x1.ffffffffffffap+1023 = 0x1.ffffffffffff9p+1023). +Check (eq_refl : next_up 0x1.fffffffffffffp+1023 = infinity). +Check (eq_refl : next_down 0x1.fffffffffffffp+1023 = 0x1.ffffffffffffep+1023). +Check (eq_refl : next_up infinity = infinity). +Check (eq_refl : next_down infinity = 0x1.fffffffffffffp+1023). 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/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v index 76e9b1e947..9323ae23b9 100644 --- a/theories/setoid_ring/Ring_tac.v +++ b/theories/setoid_ring/Ring_tac.v @@ -41,7 +41,7 @@ Ltac Get_goal := match goal with [|- ?G] => G end. Ltac OnEquation req := match goal with | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => (fun _ => fail "Goal is not an equation (of expected equality)") + | _ => (fun _ => fail "Goal is not an equation (of expected equality)" req) end. Ltac OnEquationHyp req h := diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index b205965ed1..a563dcbf95 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -22,9 +22,10 @@ Require Import ssreflect ssrfun. is_true b == the coercion of b : bool to Prop (:= b = true). This is just input and displayed as `b''. reflect P b == the reflection inductive predicate, asserting - that the logical proposition P : prop with the - formula b : bool. Lemmas asserting reflect P b - are often referred to as "views". + that the logical proposition P : Prop holds iff + the formula b : bool is equal to true. Lemmas + asserting reflect P b are often referred to as + "views". iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection views: iffP is used to prove reflection from logical equivalence, appP to compose views, and @@ -33,7 +34,7 @@ Require Import ssreflect ssrfun. elimT :: coercion reflect >-> Funclass, which allows the direct application of `reflect' views to boolean assertions. - decidable P <-> P is effectively decidable (:= {P} + {~ P}. + decidable P <-> P is effectively decidable (:= {P} + {~ P}). contra, contraL, ... :: contraposition lemmas. altP my_viewP :: natural alternative for reflection; given lemma myviewP: reflect my_Prop my_formula, @@ -334,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, @@ -362,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/comInductive.ml b/vernac/comInductive.ml index 597e55a39e..8cb077ca21 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -271,9 +271,8 @@ let inductive_levels env evd arities inds = if Sorts.is_prop a || Sorts.is_sprop a then None else Some (univ_of_sort a)) destarities in - let cstrs_levels, min_levels, sizes = - CList.split3 - (List.map2 (fun (_,tys) (arity,(ctx,du)) -> + let cstrs_levels, sizes = + CList.split (List.map2 (fun (_,tys) (arity,(ctx,du)) -> let len = List.length tys in let minlev = Sorts.univ_of_sort du in let minlev = @@ -283,13 +282,15 @@ let inductive_levels env evd arities inds = in let minlev = (* Indices contribute. *) - if indices_matter env && List.length ctx > 0 then ( + if indices_matter env then begin let ilev = sign_level env evd ctx in - Univ.sup ilev minlev) + Univ.sup ilev minlev + end else minlev in let clev = extract_level env evd minlev tys in - (clev, minlev, len)) inds destarities) + (clev, len)) + inds destarities) in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) @@ -326,8 +327,13 @@ let inductive_levels env evd arities inds = let duu = Sorts.univ_of_sort du in let template_prop, evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then - if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - true, Evd.set_eq_sort env evd Sorts.prop du + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) + then if Term.isArity arity + (* If not a syntactic arity, the universe may be used in a + polymorphic instance and so cannot be lowered to Prop. + See #13300. *) + then true, Evd.set_eq_sort env evd Sorts.prop du + else false, Evd.set_eq_sort env evd Sorts.set du else false, evd else false, Evd.set_eq_sort env evd (sort_of_univ cu) du in diff --git a/vernac/declare.ml b/vernac/declare.ml index 1e8771b641..73ebca276d 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -39,8 +39,10 @@ module Hook = struct let make_g hook = CEphemeron.create hook let make (hook : S.t -> unit) : t = CEphemeron.create (fun x () -> hook x) - let call_g ?hook x s = Option.cata (fun hook -> CEphemeron.get hook x s) s hook - let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x ()) hook + let hcall hook x s = CEphemeron.default hook (fun _ x -> x) x s + + let call_g ?hook x s = Option.cata (fun hook -> hcall hook x s) s hook + let call ?hook x = Option.iter (fun hook -> hcall hook x ()) hook end @@ -1367,14 +1369,6 @@ module Proof_info = struct ; proof_ending = CEphemeron.create proof_ending } - (* This is used due to a deficiency on the API, should fix *) - let add_first_thm ~pinfo ~name ~typ ~impargs = - let cinfo : Constr.t CInfo.t = CInfo.make ~name ~impargs ~typ:(EConstr.Unsafe.to_constr typ) () in - { pinfo with cinfo = cinfo :: pinfo.cinfo } - - (* This is called by the STM, and we have to fixup cinfo later as - indeed it will not be correct *) - let default () = make ~cinfo:[] ~info:(Info.make ()) () end type t = @@ -1388,7 +1382,6 @@ type t = (*** Proof Global manipulation ***) -let info { pinfo } = pinfo let get ps = ps.proof let get_name ps = (Proof.data ps.proof).Proof.name let get_initial_euctx ps = ps.initial_euctx @@ -1566,6 +1559,7 @@ type proof_object = (* [name] only used in the STM *) ; entries : Evd.side_effects proof_entry list ; uctx: UState.t + ; pinfo : Proof_info.t } let get_po_name { name } = name @@ -1673,7 +1667,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ps = definition_entry_core ~opaque ?using ~univs:utyp ~univsbody:ubody ~types:typ ~eff body in let entries = CList.map make_entry elist in - { name; entries; uctx } + { name; entries; uctx; pinfo } type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t @@ -1718,7 +1712,7 @@ let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.comput |> delayed_definition_entry ~opaque ~feedback_id ~using ~univs ~types in let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in - { name; entries; uctx = initial_euctx } + { name; entries; uctx = initial_euctx; pinfo } let close_future_proof = close_proof_delayed @@ -1961,7 +1955,7 @@ let compute_proof_using_for_admitted proof typ pproofs = let finish_admitted ~pm ~pinfo ~uctx ~sec_vars ~univs = let cst = MutualEntry.declare_variable ~pinfo ~uctx ~sec_vars ~univs in (* If the constant was an obligation we need to update the program map *) - match CEphemeron.get pinfo.Proof_info.proof_ending with + match CEphemeron.default pinfo.Proof_info.proof_ending Proof_ending.Regular with | Proof_ending.End_obligation oinfo -> Obls_.obligation_admitted_terminator ~pm oinfo uctx (List.hd cst) | _ -> pm @@ -2083,7 +2077,7 @@ let save ~pm ~proof ~opaque ~idopt = let proof_info = process_idopt_for_save ~idopt proof.pinfo in finalize_proof ~pm proof_obj proof_info -let save_regular ~proof ~opaque ~idopt = +let save_regular ~(proof : t) ~opaque ~idopt = let open Proof_ending in match CEphemeron.default proof.pinfo.Proof_info.proof_ending Regular with | Regular -> @@ -2094,8 +2088,8 @@ let save_regular ~proof ~opaque ~idopt = (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) -let save_lemma_admitted_delayed ~pm ~proof ~pinfo = - let { entries; uctx } = proof in +let save_lemma_admitted_delayed ~pm ~proof = + let { entries; uctx; pinfo } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -2106,16 +2100,10 @@ let save_lemma_admitted_delayed ~pm ~proof ~pinfo = let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in finish_admitted ~pm ~uctx ~pinfo ~sec_vars ~univs -let save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt = - (* vio2vo calls this but with invalid info, we have to workaround - that to add the name to the info structure *) - if CList.is_empty pinfo.Proof_info.cinfo then - let name = get_po_name proof in - let info = Proof_info.add_first_thm ~pinfo ~name ~typ:EConstr.mkSet ~impargs:[] in - finalize_proof ~pm proof info - else - let info = process_idopt_for_save ~idopt pinfo in - finalize_proof ~pm proof info +let save_lemma_proved_delayed ~pm ~proof ~idopt = + (* vio2vo used to call this with invalid [pinfo], now it should work fine. *) + let pinfo = process_idopt_for_save ~idopt proof.pinfo in + finalize_proof ~pm proof pinfo end (* Proof module *) diff --git a/vernac/declare.mli b/vernac/declare.mli index 0520bf8717..e4c77113af 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -278,14 +278,6 @@ module Proof : sig environment and empty evar_map. *) val get_current_context : t -> Evd.evar_map * Environ.env - (* Internal, don't use *) - module Proof_info : sig - type t - (* Make a dummy value, used in the stm *) - val default : unit -> t - end - val info : t -> Proof_info.t - (** {2 Proof delay API, warning, internal, not stable *) (* Intermediate step necessary to delegate the future. @@ -313,13 +305,11 @@ module Proof : sig val save_lemma_admitted_delayed : pm:OblState.t -> proof:proof_object - -> pinfo:Proof_info.t -> OblState.t val save_lemma_proved_delayed : pm:OblState.t -> proof:proof_object - -> pinfo:Proof_info.t -> idopt:Names.lident option -> OblState.t * GlobRef.t list 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 edf48fef1a..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 @@ -226,24 +228,24 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = *) (* Interpreting a possibly delayed proof *) -let interp_qed_delayed ~proof ~pinfo ~st pe : Vernacstate.LemmaStack.t option * Declare.OblState.t = +let interp_qed_delayed ~proof ~st pe : Vernacstate.LemmaStack.t option * Declare.OblState.t = let stack = st.Vernacstate.lemmas in let pm = st.Vernacstate.program in let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in let pm = match pe with | Admitted -> - Declare.Proof.save_lemma_admitted_delayed ~pm ~proof ~pinfo + Declare.Proof.save_lemma_admitted_delayed ~pm ~proof | Proved (_,idopt) -> - let pm, _ = Declare.Proof.save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt in + let pm, _ = Declare.Proof.save_lemma_proved_delayed ~pm ~proof ~idopt in pm in stack, pm -let interp_qed_delayed_control ~proof ~pinfo ~st ~control { CAst.loc; v=pe } = +let interp_qed_delayed_control ~proof ~st ~control { CAst.loc; v=pe } = let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) control - (fun ~st -> interp_qed_delayed ~proof ~pinfo ~st pe) + (fun ~st -> interp_qed_delayed ~proof ~st pe) ~st (* General interp with management of state *) @@ -273,6 +275,6 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = let interp ?(verbosely=true) ~st cmd = interp_gen ~verbosely ~st ~interp_fn:interp_control cmd -let interp_qed_delayed_proof ~proof ~pinfo ~st ~control pe : Vernacstate.t = +let interp_qed_delayed_proof ~proof ~st ~control pe : Vernacstate.t = interp_gen ~verbosely:false ~st - ~interp_fn:(interp_qed_delayed_control ~proof ~pinfo ~control) pe + ~interp_fn:(interp_qed_delayed_control ~proof ~control) pe diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 84d3256c9f..f31bebf7db 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -15,7 +15,6 @@ val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> proof and won't be forced *) val interp_qed_delayed_proof : proof:Declare.Proof.proof_object - -> pinfo:Declare.Proof.Proof_info.t -> st:Vernacstate.t -> control:Vernacexpr.control_flag list -> Vernacexpr.proof_end CAst.t diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 204008997d..011d943c9b 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -204,18 +204,14 @@ module Declare_ = struct s_lemmas := Some stack; res - type closed_proof = Declare.Proof.proof_object * Declare.Proof.Proof_info.t - let return_proof () = cc Declare.Proof.return_proof let return_partial_proof () = cc Declare.Proof.return_partial_proof let close_future_proof ~feedback_id pf = - cc (fun pt -> Declare.Proof.close_future_proof ~feedback_id pt pf, - Declare.Proof.info pt) + cc (fun pt -> Declare.Proof.close_future_proof ~feedback_id pt pf) let close_proof ~opaque ~keep_body_ucst_separate = - cc (fun pt -> Declare.Proof.close_proof ~opaque ~keep_body_ucst_separate pt, - Declare.Proof.info pt) + cc (fun pt -> Declare.Proof.close_proof ~opaque ~keep_body_ucst_separate pt) let discard_all () = s_lemmas := None let update_sigma_univs ugraph = dd (Declare.Proof.update_sigma_univs ugraph) diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index e1b13dcb73..e9e06e6d8e 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -104,13 +104,15 @@ module Declare : sig val return_proof : unit -> Declare.Proof.closed_proof_output val return_partial_proof : unit -> Declare.Proof.closed_proof_output - type closed_proof = Declare.Proof.proof_object * Declare.Proof.Proof_info.t - - val close_future_proof : - feedback_id:Stateid.t -> - Declare.Proof.closed_proof_output Future.computation -> closed_proof - - val close_proof : opaque:Vernacexpr.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof + val close_future_proof + : feedback_id:Stateid.t + -> Declare.Proof.closed_proof_output Future.computation + -> Declare.Proof.proof_object + + val close_proof + : opaque:Vernacexpr.opacity_flag + -> keep_body_ucst_separate:bool + -> Declare.Proof.proof_object val discard_all : unit -> unit val update_sigma_univs : UGraph.t -> unit |