diff options
350 files changed, 4647 insertions, 6491 deletions
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 3bd3342329..df9e14b178 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -17,3 +17,5 @@ Fixes / closes #???? <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). - [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). +- [ ] Overlay pull requests (if this breaks 3rd party developments in CI, see +https://github.com/coq/coq/blob/master/dev/ci/user-overlays/README.md for details) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7ec3ba1bd7..744fe1c743 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -74,18 +74,3 @@ jobs: make -j "$NJOBS" test-suite PRINT_LOGS=1 env: NJOBS: "2" - - - name: Create the dmg bundle - run: | - eval $(opam env) - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - export OUTDIR="$(pwd)/_install_ci" - ./dev/build/osx/make-macos-dmg.sh - env: - MACOSX_DEPLOYMENT_TARGET: "10.11" - NJOBS: "2" - - - uses: actions/upload-artifact@v2 - with: - name: coq-macOS-installer - path: _build/*.dmg diff --git a/.gitignore b/.gitignore index bf7430cc2e..1abead3c67 100644 --- a/.gitignore +++ b/.gitignore @@ -115,6 +115,9 @@ doc/stdlib/index-body.html doc/stdlib/index-list.html doc/tools/docgram/editedGrammar doc/tools/docgram/prodnGrammar +doc/tools/docgram/prodnCommands +doc/tools/docgram/prodnTactics +doc/tools/docgram/updated_rsts doc/unreleased.rst # .mll files diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d0ffedab2a..52b03e455b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,7 +20,7 @@ variables: # Format: $IMAGE-V$DATE-$hash # The $hash is the first 10 characters of the md5 of the Dockerfile. e.g. # echo $(md5sum dev/ci/docker/bionic_coq/Dockerfile | head -c 10) - CACHEKEY: "bionic_coq-V2021-02-11-b601de5a7b" + CACHEKEY: "bionic_coq-V2021-04-14-802aebab96" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -706,7 +706,11 @@ library:ci-engine_bench: extends: .ci-template library:ci-fcsl_pcm: - extends: .ci-template + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-fiat_crypto: extends: .ci-template-flambda @@ -781,6 +785,10 @@ plugin:ci-gappa: library:ci-geocoq: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-hott: extends: .ci-template @@ -820,6 +828,13 @@ library:ci-vst: - build:edge+flambda - library:ci-flocq +library:ci-deriving: + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp + # Plugins are by definition the projects that depend on Coq's ML API plugin:ci-aac_tactics: @@ -871,6 +886,10 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp plugin:ci-reduction_effects: extends: .ci-template @@ -22,6 +22,7 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@nardis.inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> +Frédéric Besson <frederic.besson@inria.fr> BESSON Frederic <frederic.besson@inria.fr> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> Lasse Blaauwbroek <lasse@blaauwbroek.eu> Lasse Blaauwbroek <lasse@lasse-work.localdomain> Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> @@ -72,6 +73,7 @@ Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e- Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> Hugo Herbelin <herbelin@users.noreply.github.com> +Wolf Honore <wolfhonore@gmail.com> whonore <wolfhonore@gmail.com> Jasper Hugunin <jasperh@cs.washington.edu> Jasper Hugunin <jasper@hashplex.com> Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -91,7 +93,6 @@ Larry Darryl Lee Jr. <llee454@gmail.com> llee454@gmail.com <llee454@gm Xavier Leroy <xavier.leroy@college-de-france.fr> Xavier Leroy <xavier.leroy@inria.fr> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> -Xia Li-yao <lysxia@gmail.com> Lysxia <lysxia@gmail.com> Yishuai Li <yishuai@cis.upenn.edu> Yishuai Li <yishuai@upenn.edu> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> Kenji Maillard <kenji.maillard@inria.fr> Kenji Maillard <kenji@maillard.blue> @@ -154,6 +155,9 @@ Laurent Théry <laurent.thery@inria.fr> Laurent Théry <thery@sophia Laurent Théry <laurent.thery@inria.fr> thery <Laurent.Thery@inria.fr> Anton Trunov <anton.a.trunov@gmail.com> Anton Trunov <anton.trunov@imdea.org> Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7> +Li-yao Xia <lysxia@gmail.com> Lysxia <lysxia@gmail.com> +Li-yao Xia <lysxia@gmail.com> Xia Li-yao <lysxia@gmail.com> +Li-yao Xia <lysxia@gmail.com> Xia Li-yao <Lysxia@users.noreply.github.com> Wang Zhuyang <hawnzug@gmail.com> hawnzug <hawnzug@gmail.com> Beta Ziliani <beta@mpi-sws.org> Beta Ziliani <bziliani@famaf.unc.edu.ar> Beta Ziliani <beta@mpi-sws.org> beta <beta@mpi-sws.org> diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a96b93154c..361270ff32 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -643,7 +643,7 @@ reviewers, with specific requests. - [needs: benchmarking][needs-benchmarking] and [needs: testing][needs-testing] indicate the PR needs testing beyond what the test suite can handle. For example, performance benchmarking is currently performed with a different - infrastructure ([documented in the wiki][jenkins-doc]). Unless some followup + infrastructure ([documented in the wiki][Benchmarking]). Unless some followup is specifically requested, you aren't expected to do this additional testing. More generally, such labels should come with a description that should @@ -1007,7 +1007,7 @@ to prepare overlays, and propose a simplified and documented procedure. We also have a benchmarking infrastructure, which is documented [on -the wiki][jenkins-doc]. +the wiki][Benchmarking]. ##### Restarting failed jobs ##### @@ -1225,6 +1225,7 @@ can be found [on the wiki][wiki-CUDW]. [add-contributor]: https://github.com/orgs/coq/teams/contributors/members?add=true [api-doc]: https://coq.github.io/doc/master/api/ +[Benchmarking]: https://github.com/coq/coq/wiki/Benchmarking [CEP]: https://github.com/coq/ceps [check-owners]: dev/tools/check-owners-pr.sh [CI-README-developers]: dev/ci/README-developers.md @@ -1272,7 +1273,6 @@ can be found [on the wiki][wiki-CUDW]. [GitLab-coq]: https://gitlab.com/coq [GitLab-doc]: https://docs.gitlab.com/ [JasonGross-coq-tools]: https://github.com/JasonGross/coq-tools -[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) [kind-documentation]: https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22 [master-doc]: https://coq.github.io/doc/master/refman/ [merge-pr]: dev/tools/merge-pr.sh diff --git a/META.coq-core.in b/META.coq-core.in index c58513979d..bc56b7b66e 100644 --- a/META.coq-core.in +++ b/META.coq-core.in @@ -320,21 +320,6 @@ package "plugins" ( plugin(native) = "tauto_plugin.cmxs" ) - package "omega" ( - - description = "Coq omega plugin" - version = "8.14" - - requires = "coq-core.plugins.ltac" - directory = "omega" - - archive(byte) = "omega_plugin.cmo" - archive(native) = "omega_plugin.cmx" - - plugin(byte) = "omega_plugin.cmo" - plugin(native) = "omega_plugin.cmxs" - ) - package "micromega" ( description = "Coq micromega plugin" diff --git a/Makefile.build b/Makefile.build index d619fd3c85..cbd4f4efbe 100644 --- a/Makefile.build +++ b/Makefile.build @@ -893,7 +893,7 @@ PLUGININCLUDES=$(addprefix -I plugins/, $(PLUGINDIRS)) $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEPBOOT) -vos -boot $(DYNDEP) -R theories Coq -R plugins Coq -Q user-contrib "" $(PLUGININCLUDES) $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) -R theories Coq -R plugins Coq -Q user-contrib "" $(PLUGININCLUDES) $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.ci b/Makefile.ci index d549ed1b39..f7c2943cc2 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -24,6 +24,7 @@ CI_TARGETS= \ ci-coq_performance_tests \ ci-coq_tools \ ci-coqprime \ + ci-deriving \ ci-elpi \ ci-engine_bench \ ci-ext_lib \ @@ -74,6 +75,7 @@ ci-color: ci-bignums ci-coqprime: ci-bignums ci-coquelicot: ci-mathcomp +ci-deriving: ci-mathcomp ci-math_classes: ci-bignums ci-corn: ci-math_classes @@ -86,9 +88,12 @@ ci-fiat_crypto_ocaml: ci-fiat_crypto ci-interval: ci-mathcomp ci-flocq ci-coquelicot ci-bignums ci-fourcolor: ci-mathcomp ci-oddorder: ci-mathcomp +ci-fcsl_pcm: ci-mathcomp + +ci-geocoq: ci-mathcomp ci-simple_io: ci-ext_lib -ci-quickchick: ci-ext_lib ci-simple_io +ci-quickchick: ci-ext_lib ci-simple_io ci-mathcomp ci-metacoq: ci-equations diff --git a/Makefile.common b/Makefile.common index dc40413078..a21e974ed5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -102,7 +102,7 @@ CORESRCDIRS:=\ tactics vernac stm sysinit toplevel PLUGINDIRS:=\ - omega micromega \ + micromega \ ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ @@ -138,7 +138,6 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l # plugins object files ########################################################################### -OMEGACMO:=plugins/omega/omega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo RINGCMO:=plugins/ring/ring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo @@ -159,7 +158,7 @@ SSRSEARCHCMO=plugins/ssrsearch/ssrsearch_plugin.cmo LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo ZIFYCMO:=plugins/micromega/zify_plugin.cmo -PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ +PLUGINSCMO:=$(LTACCMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ diff --git a/Makefile.dev b/Makefile.dev index cfb02b6d80..c573fccf95 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -141,7 +141,6 @@ noreal: unicode logic arith bool zarith qarith lists sets fsets \ ### 4) plugins ################ -OMEGAVO:=$(filter theories/omega/%, $(THEORIESVO)) MICROMEGAVO:=$(filter theories/micromega/%, $(THEORIESVO)) RINGVO:=$(filter theories/setoid_ring/%, $(THEORIESVO)) NSATZVO:=$(filter theories/nsatz/%, $(THEORIESVO)) @@ -153,7 +152,6 @@ CCVO:= DERIVEVO:=$(filter theories/derive/%, $(THEORIESVO)) LTACVO:=$(filter theories/ltac/%, $(THEORIESVO)) -omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) @@ -164,7 +162,7 @@ rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) -.PHONY: omega micromega ring nsatz extraction +.PHONY: micromega ring nsatz extraction .PHONY: funind cc rtauto btauto ltac # For emacs: diff --git a/Makefile.dune b/Makefile.dune index c338405f2c..1313ef5eac 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -18,7 +18,7 @@ help: @echo " - world: build all public binaries and libraries" @echo " - watch: build all public binaries and libraries [continuous build]" @echo " - check: build all ML files as fast as possible" - @echo " - test-suite: run Coq's test suite" + @echo " - test-suite: run Coq's test suite [env NJOBS=N to set job parallelism]" @echo "" @echo " Note: running ./configure is not recommended," @echo " see dev/doc/build-system.dune.md for more info" diff --git a/checker/values.ml b/checker/values.ml index f7a367b986..1353435181 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -87,7 +87,7 @@ let v_cons = v_tuple "constructor" [|v_ind;Int|] (** kernel/univ *) -let v_level_global = v_tuple "Level.Global.t" [|v_dp;Int|] +let v_level_global = v_tuple "Level.Global.t" [|v_dp;String;Int|] let v_raw_level = v_sum "raw_level" 3 (* SProp, Prop, Set *) [|(*Level*)[|v_level_global|]; (*Var*)[|Int|]|] let v_level = v_tuple "level" [|Int;v_raw_level|] diff --git a/clib/cThread.ml b/clib/cThread.ml index 89ca2f7d83..3796fdf788 100644 --- a/clib/cThread.ml +++ b/clib/cThread.ml @@ -107,3 +107,22 @@ let mask_sigalrm f x = let create f x = Thread.create (mask_sigalrm f) x + +(* + Atomic mutex lock taken from https://gitlab.com/gadmm/memprof-limits/-/blob/master/src/thread_map.ml#L23-34 + Critical sections : + - Mutex.lock does not poll on leaving the blocking section + since 4.12. + - Never inline, to avoid theoretically-possible reorderings with + flambda. + (workaround to the lack of masking) +*) + +(* We inline the call to Mutex.unlock to avoid polling in bytecode mode *) +external unlock: Mutex.t -> unit = "caml_mutex_unlock" + +let[@inline never] with_lock m ~scope = + let () = Mutex.lock m (* BEGIN ATOMIC *) in + match (* END ATOMIC *) scope () with + | (* BEGIN ATOMIC *) x -> unlock m ; (* END ATOMIC *) x + | (* BEGIN ATOMIC *) exception e -> unlock m ; (* END ATOMIC *) raise e diff --git a/clib/cThread.mli b/clib/cThread.mli index 87889f3356..d974135d43 100644 --- a/clib/cThread.mli +++ b/clib/cThread.mli @@ -29,3 +29,8 @@ val thread_friendly_really_read_line : thread_ic -> string (* Wrapper around Thread.create that blocks signals such as Sys.sigalrm (used * for Timeout *) val create : ('a -> 'b) -> 'a -> Thread.t + +(* + Atomic mutex lock taken from https://gitlab.com/gadmm/memprof-limits/-/blob/master/src/thread_map.ml#L23-34 +*) +val with_lock : Mutex.t -> scope:(unit -> 'a) -> 'a diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 07b7f47529..4c1f47df30 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -71,10 +71,9 @@ let record_backtrace b = let get_backtrace e = get e backtrace_info let iraise (e,i) = - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let () = current := (id, (e,i)) :: remove_assoc id !current in - let () = Mutex.unlock lock in + CThread.with_lock lock ~scope:(fun () -> + let id = Thread.id (Thread.self ()) in + current := (id, (e,i)) :: remove_assoc id !current); match get i backtrace_info with | None -> raise e @@ -82,12 +81,11 @@ let iraise (e,i) = Printexc.raise_with_backtrace e bt let find_and_remove () = - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let (v, l) = find_and_remove_assoc id !current in - let () = current := l in - let () = Mutex.unlock lock in - v + CThread.with_lock lock ~scope:(fun () -> + let id = Thread.id (Thread.self ()) in + let (v, l) = find_and_remove_assoc id !current in + let () = current := l in + v) let info e = let (src, data) = find_and_remove () in diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 2de103a2ff..748f50b54b 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -615,12 +615,29 @@ let pr_ast fmt = function | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac | ArgumentExt arg -> fprintf fmt "%a@\n" ArgumentExt.print_ast arg -let () = +let help () = + Format.eprintf "Usage: coqpp file.mlg@\n%!"; + exit 1 + +let parse () = let () = - if Array.length Sys.argv <> 2 then fatal "Expected exactly one command line argument" + if Array.length Sys.argv <> 2 + then help () in - let file = Sys.argv.(1) in - let output = Filename.chop_extension file ^ ".ml" in + match Sys.argv.(1) with + | "-help" | "--help" -> help () + | file -> file + +let output_name file = + try + Filename.chop_extension file ^ ".ml" + with + | Invalid_argument _ -> + fatal "Input file must have an extension for coqpp [input.ext -> input.ml]" + +let () = + let file = parse () in + let output = output_name file in let ast = parse_file file in let chan = open_out output in let fmt = formatter_of_out_channel chan in diff --git a/default.nix b/default.nix index f838f17d07..4700a6ed64 100644 --- a/default.nix +++ b/default.nix @@ -33,7 +33,7 @@ }: with pkgs; -with stdenv.lib; +with pkgs.lib; stdenv.mkDerivation rec { diff --git a/dev/base_include b/dev/base_include index f375a867bc..b761924b46 100644 --- a/dev/base_include +++ b/dev/base_include @@ -16,7 +16,6 @@ #install_printer (* kernel_name *) ppkn;; #install_printer (* constant *) ppcon;; #install_printer (* projection *) ppproj;; -#install_printer (* cl_index *) ppclindex;; #install_printer (* recarg Rtree.t *) ppwf_paths;; #install_printer (* constr *) print_pure_constr;; #install_printer (* patch *) ppripos;; @@ -69,7 +68,7 @@ open Constr_matching open Glob_term open Glob_ops open Coercion -open Recordops +open Structures open Detyping open Reductionops open Evarconv diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh deleted file mode 100755 index 2550cbb31c..0000000000 --- a/dev/build/osx/make-macos-dmg.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/bin/bash - -# Fail on first error -set -e - -# Configuration setup -DMGDIR=$PWD/_dmg -VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) -APP=bin/CoqIDE_${VERSION}.app - -# Install Coq into the .app file -make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop - -# Fill .app file with metadata and other .app specific stuff (like non-system .so) -make PRIVATEBINARIES="$APP" -j 1 -l2 "$APP" VERBOSE=1 - -# Create the dmg bundle -mkdir -p "$DMGDIR" -ln -sf /Applications "$DMGDIR/Applications" -cp -r "$APP" "$DMGDIR" - -mkdir -p _build - -# Temporary countermeasure to hdiutil error 5341 -# head -c9703424 /dev/urandom > $DMGDIR/.padding - -hdi_opts=(-volname "coq-$VERSION-installer-macos" - -srcfolder "$DMGDIR" - -ov # overwrite existing file - -format UDZO - -imagekey "zlib-level=9" - - # needed for backward compat since macOS 10.14 which uses APFS by default - # see discussion in #11803 - -fs hfs+ - ) -hdiutil create "${hdi_opts[@]}" "_build/coq-$VERSION-installer-macos.dmg" diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8bcbd90f0b..0093b5fca2 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -79,8 +79,6 @@ project iris "https://gitlab.mpi-sws.org/iris/iris" "" project autosubst "https://github.com/coq-community/autosubst" "master" -project iris_string_ident "https://gitlab.mpi-sws.org/iris/string-ident" "master" - project iris_examples "https://gitlab.mpi-sws.org/iris/examples" "master" ######################################################################## @@ -141,7 +139,8 @@ project compcert "https://github.com/AbsInt/CompCert" "master" ######################################################################## # VST ######################################################################## -project vst "https://github.com/PrincetonUniversity/VST" "master" +# todo: 2021 03 11: switch back to master once vst merges the compcert3.9 branch +project vst "https://github.com/PrincetonUniversity/VST" "compcert3.9" ######################################################################## # cross-crypto @@ -249,7 +248,7 @@ project reduction_effects "https://github.com/coq-community/reduction-effects" " # menhirlib ######################################################################## # Note: menhirlib is now in subfolder coq-menhirlib of menhir -project menhirlib "https://gitlab.inria.fr/fpottier/menhir" "20201122" +project menhirlib "https://gitlab.inria.fr/fpottier/menhir" "20210310" ######################################################################## # aac_tactics @@ -308,3 +307,8 @@ project sf "https://github.com/DeepSpec/sf" "master" # Coqtail ######################################################################## project coqtail "https://github.com/whonore/Coqtail" "master" + +######################################################################## +# Deriving +######################################################################## +project deriving "https://github.com/arthuraa/deriving" "master" diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 8d8f78e10c..6d1e6d788a 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -138,38 +138,8 @@ make() if [ -z "${MAKEFLAGS+x}" ] && [ -n "${NJOBS}" ]; then # Not submake and parallel make requested - command make --output-sync -j "$NJOBS" "$@" + command make -j "$NJOBS" "$@" else - command make --output-sync "$@" + command make "$@" fi } - -# this installs just the ssreflect library of math-comp -install_ssreflect() -{ - echo 'Installing ssreflect' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp/ssreflect" && \ - make && \ - make install ) - -} - -# this installs just the ssreflect + algebra library of math-comp -install_ssralg() -{ - echo 'Installing ssralg' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && \ - make -C ssreflect && \ - make -C ssreflect install && \ - make -C fingroup && \ - make -C fingroup install && \ - make -C algebra && \ - make -C algebra install ) - -} diff --git a/dev/ci/ci-deriving.sh b/dev/ci/ci-deriving.sh new file mode 100755 index 0000000000..c34fc44f69 --- /dev/null +++ b/dev/ci/ci-deriving.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download deriving + +( cd "${CI_BUILD_DIR}/deriving" && make && make tests && make install ) diff --git a/dev/ci/ci-fcsl_pcm.sh b/dev/ci/ci-fcsl_pcm.sh index cb951630c8..e1248c6627 100755 --- a/dev/ci/ci-fcsl_pcm.sh +++ b/dev/ci/ci-fcsl_pcm.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download fcsl_pcm ( cd "${CI_BUILD_DIR}/fcsl_pcm" && make ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index cb6c3e6452..01723e5b5c 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -5,4 +5,10 @@ ci_dir="$(dirname "$0")" git_download flocq -( cd "${CI_BUILD_DIR}/flocq" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) +( cd "${CI_BUILD_DIR}/flocq" + ( if [ ! -x ./configure ]; then + autoconf + ./configure COQEXTRAFLAGS="-compat 8.13"; + fi ) + ./remake "-j${NJOBS}" + ./remake install ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index e4fc983e68..0ad9ac0cbb 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssralg - git_download geocoq ( cd "${CI_BUILD_DIR}/geocoq" && ./configure.sh && make ) diff --git a/dev/ci/ci-iris.sh b/dev/ci/ci-iris.sh index d29e6f1635..7a72462758 100755 --- a/dev/ci/ci-iris.sh +++ b/dev/ci/ci-iris.sh @@ -5,7 +5,6 @@ ci_dir="$(dirname "$0")" # Setup iris_examples and separate dependencies first git_download autosubst -git_download iris_string_ident git_download iris_examples # Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) @@ -31,8 +30,5 @@ git_download stdpp # Build autosubst ( cd "${CI_BUILD_DIR}/autosubst" && make && make install ) -# Build iris-string-ident -( cd "${CI_BUILD_DIR}/iris_string_ident" && make && make install ) - # Build Iris examples ( cd "${CI_BUILD_DIR}/iris_examples" && make && make install ) diff --git a/dev/ci/ci-quickchick.sh b/dev/ci/ci-quickchick.sh index 08686d7ced..62623f4c39 100755 --- a/dev/ci/ci-quickchick.sh +++ b/dev/ci/ci-quickchick.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download quickchick -( cd "${CI_BUILD_DIR}/quickchick" && make && make install) +( cd "${CI_BUILD_DIR}/quickchick" && make && make install-plugin) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 8f14625c63..00729cd168 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -24,7 +24,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ texlive-science tipa # More dependencies of the sphinx doc, pytest for coqtail -RUN pip3 install sphinx==2.3.1 sphinx_rtd_theme==0.4.3 \ +RUN pip3 install docutils==0.16 sphinx==2.3.1 sphinx_rtd_theme==0.4.3 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.2 \ pytest==5.4.3 @@ -44,7 +44,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages ENV BASE_OPAM="zarith.1.10 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.1" \ CI_OPAM="ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.13.0" + BASE_ONLY_OPAM="elpi.1.13.1" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" diff --git a/dev/ci/user-overlays/13852-Lysxia-no-collision-projection.sh b/dev/ci/user-overlays/13852-Lysxia-no-collision-projection.sh new file mode 100644 index 0000000000..9b8d1a63d9 --- /dev/null +++ b/dev/ci/user-overlays/13852-Lysxia-no-collision-projection.sh @@ -0,0 +1 @@ +overlay compcert https://github.com/Lysxia/CompCert no-collision-projection 13852 diff --git a/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh b/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh new file mode 100644 index 0000000000..d860cfec01 --- /dev/null +++ b/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/pi8027/coq-elpi coq-overlay-13912 13912 diff --git a/dev/ci/user-overlays/13958-gares-recordops-api.sh b/dev/ci/user-overlays/13958-gares-recordops-api.sh new file mode 100644 index 0000000000..0ec50a1dda --- /dev/null +++ b/dev/ci/user-overlays/13958-gares-recordops-api.sh @@ -0,0 +1,6 @@ +overlay metacoq https://github.com/gares/metacoq recordops-api 13958 +overlay mtac2 https://github.com/gares/Mtac2 recordops-api 13958 +overlay elpi https://github.com/gares/coq-elpi recordops-api 13958 +overlay unicoq https://github.com/gares/unicoq recordops-api 13958 +overlay equations https://github.com/gares/Coq-Equations recordops-api 13958 +overlay hierarchy_builder https://github.com/gares/hierarchy-builder coq-master 13958 diff --git a/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh b/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh new file mode 100644 index 0000000000..d1606711dc --- /dev/null +++ b/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh @@ -0,0 +1 @@ +overlay metacoq https://github.com/SkySkimmer/metacoq no-remote-counter-alt 14050 diff --git a/dev/ci/user-overlays/14111-gares-update-elpi.sh b/dev/ci/user-overlays/14111-gares-update-elpi.sh new file mode 100644 index 0000000000..8827127a38 --- /dev/null +++ b/dev/ci/user-overlays/14111-gares-update-elpi.sh @@ -0,0 +1,2 @@ +overlay elpi https://github.com/LPCIC/coq-elpi coq-master+1.9.5 14111 +overlay hierarchy_builder https://github.com/math-comp/hierarchy-builder coq-master+1.1.0 14111 diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index da3022644d..db51dc08b6 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -6,7 +6,7 @@ load_printer clib.cma load_printer dynlink.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index de3d5a3d15..8ebd6b5073 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -10,17 +10,23 @@ Coq can now be built using [Dune](https://github.com/ocaml/dune). ## Quick Start -Usually, using the latest version of Dune is recommended, see -`dune-project` for the minimum required version; type `dune build` to -build the base Coq libraries. No call to `./configure` is needed. +Usually, using the latest version of Dune is recommended, see the +first line of the `dune-project` file for the minimum required +version. + +It is strongly recommended that you use the helper targets available +in `Makefile.dune`, `make -f Makefile.dune` will display help. Note +that dune will call configure for you if needed, so no need to call +`./configure` in the regular development workflow. + +`dune build @install` will build all the public Coq artifacts; `dune +build` will build all the targets in the workspace, including tests +and documentations. Dune will get confused if it finds leftovers of in-tree compilation, so please be sure your tree is clean from objects files generated by the make-based system. -More helper targets are available in `Makefile.dune`, `make -f -Makefile.dune` will display some help. - Dune places build artifacts in a separate directory `_build`; it will also generate an `.install` file so files can be properly installed by package managers. @@ -84,7 +90,11 @@ builds, please see below. ## Documentation and testing targets -Coq's test-suite can be run with `dune runtest`. +Coq's test-suite can be run with `dune runtest`; given that `dune` +still invokes the test-suite makefile, the environment variable +`NJOBS` will control the value of the `-j` option that is passed to +make; common call `NJOBS=8 dune runtest`. This will be resolved in the +future once the test suite is ported to Dune rules. There is preliminary support to build the API documentation and reference manual in HTML format, use `dune build {@doc,@refman-html}` @@ -229,3 +239,17 @@ useful to Coq, some examples are: implicitly loaded plugins / vo files. See the "Running binaries [coqtop / coqide]" section above as to how to correctly call Coq's binaries. + +## Dune cheat sheet + +- `dune build` build all targets in the current workspace +- `dune build @check` build all ML targets as fast as possible, setup merlin +- `dune utop $dir` open a shell for libraries in `$dir` +- `dune exec -- $file` build and execute binary `$file`, can be in path or be an specific name +- `dune build _build/$context/$foo` build target `$foo$` in `$context`, with build dir layout +- `dune build _build/install/$context/foo` build target `$foo$` in `$context`, with install dir layout + +### packaging: + +- `dune subst` generate metadata for a package to be installed / distributed, necessary for opam +- `dune build -p $pkg` build a package in release mode diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 4452baf513..5c8b8944a7 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -344,6 +344,16 @@ Conversion machines noticeable if activated by chance, since it usually breaks control-flow integrity + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: arbitrary code execution on irreducible PArray.set + introduced: 8.13 + impacted released versions: 8.13.0, 8.13.1 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.2 + found by: Melquiond + GH issue number: #13998 + risk: none, unless using primitive array operations; systematic otherwise + Side-effects component: side-effects diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 57c325f698..1697a19668 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -114,6 +114,11 @@ list of contributors between Coq revisions. Typically used with `VX.X+alpha..vX.X` to check the contributors of version `VX.X`. + Note that this script relies on `.mailmap` to merge multiple + identities. If you notice anything incorrect while using it, use + the opportunity to fix the `.mailmap` file. Same thing if you want + to have the full name of a contributor shown instead of a pseudonym. + ## For each release (preview, final, patch-level) ## - [ ] Ensure that there exists a milestone for the following version. @@ -21,8 +21,8 @@ %{lib:coq-core.clib:clib.cma} %{lib:coq-core.lib:lib.cma} %{lib:coq-core.kernel:kernel.cma} - %{lib:coq-core.vm:byterun.cma} - %{lib:coq-core.vm:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.vm:coqrun.cma} + %{lib:coq-core.vm:../../stublibs/dllcoqrun_stubs.so} %{lib:coq-core.library:library.cma} %{lib:coq-core.engine:engine.cma} %{lib:coq-core.pretyping:pretyping.cma} diff --git a/dev/dune-dbg.in b/dev/dune-dbg.in index 47dfbad3a0..cc8574c6d6 100755 --- a/dev/dune-dbg.in +++ b/dev/dune-dbg.in @@ -26,4 +26,4 @@ esac emacs="${INSIDE_EMACS:+-emacs}" -ocamldebug $emacs $(ocamlfind query -recursive -i-format coq.top_printers) -I +threads -I dev $exe "$@" +ocamldebug $emacs $(ocamlfind query -recursive -i-format coq-core.top_printers) -I +threads -I dev $exe "$@" diff --git a/dev/dune_db_408 b/dev/dune_db_408 index bc86020d56..dff9b1e9e6 100644 --- a/dev/dune_db_408 +++ b/dev/dune_db_408 @@ -6,7 +6,7 @@ load_printer clib.cma load_printer dynlink.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/dune_db_409 b/dev/dune_db_409 index adb1f76872..6c9f701b65 100644 --- a/dev/dune_db_409 +++ b/dev/dune_db_409 @@ -5,7 +5,7 @@ load_printer config.cma load_printer clib.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index a582a70e0a..37e39a99a9 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/0bbeca2ff952e6a171534793ddd0fa97c8f9546a.tar.gz"; - sha256 = "0h1y4ffvyvkqs6k2pak02pby25va7c6c1y4p8xkwlzqwswxqxvfl"; + url = "https://github.com/NixOS/nixpkgs/archive/5c7a370a208d93d458193fc05ed84ced0ba7f387.tar.gz"; + sha256 = "1jkn71xscsk4rb0agbp5saf06hy36qvy512zzh3881pkkn67i9js"; }) diff --git a/dev/shim/dune b/dev/shim/dune index e4cc7699f0..2c7f9c3fa9 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -26,7 +26,7 @@ (targets coqbyte-prelude) (deps %{bin:coqtop.byte} - %{lib:coq-core.kernel:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.kernel:../../stublibs/dllcoqrun_stubs.so} %{project_root}/theories/Init/Prelude.vo) (action (with-stdout-to %{targets} diff --git a/dev/tools/list-contributors.sh b/dev/tools/list-contributors.sh index c968f2e952..0b0d01c7e2 100644..100755 --- a/dev/tools/list-contributors.sh +++ b/dev/tools/list-contributors.sh @@ -1,15 +1,15 @@ #!/usr/bin/env bash # For compat with OSX which has a non-gnu sed which doesn't support -z -SED=`which gsed || which sed` +SED=`(which gsed || which sed) 2> /dev/null` if [ $# != 1 ]; then - error "usage: $0 rev0..rev1" + echo "usage: $0 rev0..rev1" exit 1 fi git shortlog -s -n --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > contributors.tmp cat contributors.tmp | wc -l | xargs echo "Contributors:" -cat contributors.tmp | gsed -z "s/\n/, /g" +cat contributors.tmp | $SED -z "s/\n/, /g" echo rm contributors.tmp diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index fe95a59d9b..5d37c60bca 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -12,7 +12,6 @@ install_printer Top_printers.ppmind install_printer Top_printers.ppind install_printer Top_printers.ppsp install_printer Top_printers.ppqualid -install_printer Top_printers.ppclindex install_printer Top_printers.ppscheme install_printer Top_printers.ppwf_paths install_printer Top_printers.ppevar diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f8fd8b3d5b..67fe7b980b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -52,7 +52,6 @@ let ppmind kn = pp(MutInd.debug_print kn) let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) -let ppclindex cl = pp(Coercionops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let prrecarg = Declareops.pp_recarg diff --git a/dev/top_printers.mli b/dev/top_printers.mli index b4b24d743a..ba7d92f907 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -29,8 +29,6 @@ val ppind : Names.inductive -> unit val ppsp : Libnames.full_path -> unit val ppqualid : Libnames.qualid -> unit -val ppclindex : Coercionops.cl_index -> unit - val ppscheme : 'a Ind_tables.scheme_kind -> unit val prrecarg : Declarations.recarg -> Pp.t diff --git a/doc/changelog/03-notations/13840-print-prim.rst b/doc/changelog/03-notations/13840-print-prim.rst new file mode 100644 index 0000000000..d6e3184662 --- /dev/null +++ b/doc/changelog/03-notations/13840-print-prim.rst @@ -0,0 +1,11 @@ +- **Changed:** + Flag :flag:`Printing Notations` no longer controls + whether strings and numbers are printed raw + (`#13840 <https://github.com/coq/coq/pull/13840>`_, + by Enrico Tassi). + +- **Added:** + Flag :flag:`Printing Raw Literals` to control whether + strings and numbers are printed raw. + (`#13840 <https://github.com/coq/coq/pull/13840>`_, + by Enrico Tassi). diff --git a/doc/changelog/04-tactics/13741-remove_omega.rst b/doc/changelog/04-tactics/13741-remove_omega.rst new file mode 100644 index 0000000000..0b25c01958 --- /dev/null +++ b/doc/changelog/04-tactics/13741-remove_omega.rst @@ -0,0 +1,7 @@ +- **Removed:** + Removed the `omega` tactic (deprecated in 8.12) and 4 `* Omega *` flags. + Use `lia` instead. + (`#13741 <https://github.com/coq/coq/pull/13741>`_, + by Jim Fehrle, who addressed the final details, building on much work by + Frédéric Besson, who greatly improved :tacn:`lia`, Maxime Dénès, + Vincent Laporte and with the help of many package maintainers, among others). diff --git a/doc/changelog/04-tactics/14033-fix-14009.rst b/doc/changelog/04-tactics/14033-fix-14009.rst new file mode 100644 index 0000000000..3b58e193cb --- /dev/null +++ b/doc/changelog/04-tactics/14033-fix-14009.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Properly expand projection parameters in hint discrimination + nets. (`#14033 <https://github.com/coq/coq/pull/14033>`_, + fixes `#9000 <https://github.com/coq/coq/issues/9000>`_, + `#14009 <https://github.com/coq/coq/issues/14009>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13774-ltac2-deprecated-attribute-term.rst b/doc/changelog/05-tactic-language/13774-ltac2-deprecated-attribute-term.rst new file mode 100644 index 0000000000..5fdfbd9796 --- /dev/null +++ b/doc/changelog/05-tactic-language/13774-ltac2-deprecated-attribute-term.rst @@ -0,0 +1,6 @@ +- **Added:** + Ltac2 commands defining terms now accept the :attr:`deprecated` + attribute + (`#13774 <https://github.com/coq/coq/pull/13774>`_, + fixes `#12317 <https://github.com/coq/coq/issues/12317>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13914-ltac2-cast-fun-return.rst b/doc/changelog/05-tactic-language/13914-ltac2-cast-fun-return.rst new file mode 100644 index 0000000000..5ecc5934eb --- /dev/null +++ b/doc/changelog/05-tactic-language/13914-ltac2-cast-fun-return.rst @@ -0,0 +1,5 @@ +- **Added:** + Allow the presence of type casts for function return values, let bindings and + global definitions in Ltac2 + (`#13914 <https://github.com/coq/coq/pull/13914>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst new file mode 100644 index 0000000000..32499957be --- /dev/null +++ b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst @@ -0,0 +1,5 @@ +- **Added:** + Added the Ltac2 API `Ltac2.Ind` for manipulating inductive types + (`#13920 <https://github.com/coq/coq/pull/13920>`_, + fixes `#10095 <https://github.com/coq/coq/issues/10095>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst b/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst new file mode 100644 index 0000000000..9753ce915b --- /dev/null +++ b/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst @@ -0,0 +1,5 @@ +- **Added:** + Allow scope delimiters in Ltac2 open_constr:(...) quotation + (`#13939 <https://github.com/coq/coq/pull/13939>`_, + fixes `#12806 <https://github.com/coq/coq/issues/12806>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst b/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst new file mode 100644 index 0000000000..b5b63455c9 --- /dev/null +++ b/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst @@ -0,0 +1,5 @@ +- **Added:** + Added a FFI to convert between Ltac1 and Ltac2 identifiers + (`#13997 <https://github.com/coq/coq/pull/13997>`_, + fixes `#13996 <https://github.com/coq/coq/issues/13996>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-vernac-commands-and-options/13852-no-collision-projection.rst b/doc/changelog/07-vernac-commands-and-options/13852-no-collision-projection.rst new file mode 100644 index 0000000000..d3ef244cb0 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13852-no-collision-projection.rst @@ -0,0 +1,6 @@ +- **Changed:** + In `Record`, alpha-rename the variable associated with the record to avoid + alpha-renaming parameters of projections + (`#13852 <https://github.com/coq/coq/pull/13852>`_, + fixes `#13727 <https://github.com/coq/coq/issues/13727>`_, + by Li-yao Xia). diff --git a/doc/changelog/07-vernac-commands-and-options/13909-reduce-ambiguous-paths.rst b/doc/changelog/07-vernac-commands-and-options/13909-reduce-ambiguous-paths.rst new file mode 100644 index 0000000000..c5a2172005 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13909-reduce-ambiguous-paths.rst @@ -0,0 +1,6 @@ +- **Changed:** + Improve the :cmd:`Coercion` command to reduce the number of ambiguous paths to + report. A pair of multiple inheritance paths that can be reduced to smaller + adjoining pairs will not be reported as ambiguous paths anymore. + (`#13909 <https://github.com/coq/coq/pull/13909>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst b/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst new file mode 100644 index 0000000000..99efda3a5b --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst @@ -0,0 +1,5 @@ +- **Changed:** + The printing order of :cmd:`Print Classes` and :cmd:`Print Graph`, due to the + changes for the internal tables of coercion classes and coercion paths. + (`#13912 <https://github.com/coq/coq/pull/13912>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst b/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst new file mode 100644 index 0000000000..7831d10392 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst @@ -0,0 +1,6 @@ +- **Added:** + The Ltac2 grammar can now be printed using the + Print Grammar ltac2 command + (`#14093 <https://github.com/coq/coq/pull/14093>`_, + fixes `#14092 <https://github.com/coq/coq/issues/14092>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst b/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst new file mode 100644 index 0000000000..6a34f5a70e --- /dev/null +++ b/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Failure of extraction in the presence of inductive types with local + definitions in parameters + (`#13624 <https://github.com/coq/coq/pull/13624>`_, + fixes `#13581 <https://github.com/coq/coq/issues/13581>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-cli-tools/14024-coqdep-errors.rst b/doc/changelog/08-cli-tools/14024-coqdep-errors.rst new file mode 100644 index 0000000000..355c0bd7b7 --- /dev/null +++ b/doc/changelog/08-cli-tools/14024-coqdep-errors.rst @@ -0,0 +1,8 @@ +- **Changed:** + ``coqdep`` now reports an error if files specified on the + command line don't exist or if it encounters unreadable files. + Unknown options now generate a warning. Previously these + conditions were ignored. + (`#14024 <https://github.com/coq/coq/pull/14024>`_, + fixes `#14023 <https://github.com/coq/coq/issues/14023>`_, + by Hendrik Tews). diff --git a/doc/changelog/10-standard-library/13582-exp_ineq.rst b/doc/changelog/10-standard-library/13582-exp_ineq.rst index 27d89b2f8b..ff4e8db8b0 100644 --- a/doc/changelog/10-standard-library/13582-exp_ineq.rst +++ b/doc/changelog/10-standard-library/13582-exp_ineq.rst @@ -4,6 +4,4 @@ Adds exp_ineq1_le, which holds for all reals (but is a <= instead of a <). (`#13582 <https://github.com/coq/coq/pull/13582>`_, - by Avi Shinnar and Barry Trager, with help from Laurent Théry - -). + by Avi Shinnar and Barry Trager, with help from Laurent Théry). diff --git a/doc/changelog/10-standard-library/13671-Vector_to_list.rst b/doc/changelog/10-standard-library/13671-Vector_to_list.rst new file mode 100644 index 0000000000..e8404f0c93 --- /dev/null +++ b/doc/changelog/10-standard-library/13671-Vector_to_list.rst @@ -0,0 +1,4 @@ +- **Added:** + Lemmas about vectors related with ``to_list``: ``length_to_list``, ``of_list_to_list_opp``, ``to_list_nil``, ``to_list_cons``, ``to_list_hd``, ``to_list_last``, ``to_list_const``, ``to_list_nth_order``, ``to_list_tl``, ``to_list_append``, ``to_list_rev_append_tail``, ``to_list_rev_append``, ``to_list_rev``, ``to_list_map``, ``to_list_fold_left``, ``to_list_fold_right``, ``to_list_Forall``, ``to_list_Exists``, ``to_list_In``, ``to_list_Forall2`` + (`#13671 <https://github.com/coq/coq/pull/13671>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/13804-count_occ.rst b/doc/changelog/10-standard-library/13804-count_occ.rst new file mode 100644 index 0000000000..9354b219d8 --- /dev/null +++ b/doc/changelog/10-standard-library/13804-count_occ.rst @@ -0,0 +1,4 @@ +- **Added:** + Lemmas about ``count_occ``: ``count_occ_app``, ``count_occ_elt_eq``, ``count_occ_elt_neq``, ``count_occ_bound``, ``count_occ_repeat_eq``, ``count_occ_repeat_neq``, ``count_occ_unique``, ``count_occ_repeat_excl``, ``count_occ_sgt``, ``Permutation_count_occ`` + (`#13804 <https://github.com/coq/coq/pull/13804>`_, + by Olivier Laurent with help of Jean-Christophe Léchenet). diff --git a/doc/changelog/10-standard-library/13955-List_lemmas1.rst b/doc/changelog/10-standard-library/13955-List_lemmas1.rst new file mode 100644 index 0000000000..73eb9a78d9 --- /dev/null +++ b/doc/changelog/10-standard-library/13955-List_lemmas1.rst @@ -0,0 +1,4 @@ +- **Added:** + Lemmas to ``List``: ``Exists_map``, ``Exists_concat``, ``Exists_flat_map``, ``Forall_map``, ``Forall_concat``, ``Forall_flat_map``, ``nth_error_map``, ``nth_repeat``, ``nth_error_repeat`` + (`#13955 <https://github.com/coq/coq/pull/13955>`_, + by Andrej Dudenhefner, with help from Olivier Laurent). diff --git a/doc/changelog/10-standard-library/13986-clean-List-imports.rst b/doc/changelog/10-standard-library/13986-clean-List-imports.rst new file mode 100644 index 0000000000..02e7b9cc97 --- /dev/null +++ b/doc/changelog/10-standard-library/13986-clean-List-imports.rst @@ -0,0 +1,4 @@ +- **Removed:** + from ``List.v`` deprecated/unexpected dependencies ``Setoid``, ``Le``, ``Gt``, ``Minus``, ``Lt`` + (`#13986 <https://github.com/coq/coq/pull/13986>`_, + by Andrej Dudenhefner). diff --git a/doc/changelog/10-standard-library/14008-Cantor-pairing.rst b/doc/changelog/10-standard-library/14008-Cantor-pairing.rst new file mode 100644 index 0000000000..4c217f3fb0 --- /dev/null +++ b/doc/changelog/10-standard-library/14008-Cantor-pairing.rst @@ -0,0 +1,6 @@ +- **Added:** + ``Cantor.v`` containing the Cantor pairing function and its inverse. + ``Cantor.to_nat : nat * nat -> nat`` and ``Cantor.of_nat : nat -> nat * nat`` + are the respective bijections between ``nat * nat`` and ``nat``. + (`#14008 <https://github.com/coq/coq/pull/14008>`_, + by Andrej Dudenhefner). @@ -63,3 +63,6 @@ (files (refman-html as html/refman) (refman-pdf as pdf/refman)) (section doc) (package coq-doc)) + +(documentation + (package coq-doc)) diff --git a/doc/index.mld b/doc/index.mld new file mode 100644 index 0000000000..3a1979bc62 --- /dev/null +++ b/doc/index.mld @@ -0,0 +1,3 @@ +{0 coq-doc } + +The coq-doc package only contains user documentation on the Coq proof assistant and no OCaml library. diff --git a/doc/sphinx/_static/ansi.css b/doc/sphinx/_static/ansi.css index 2a618f68d2..a4850a738b 100644 --- a/doc/sphinx/_static/ansi.css +++ b/doc/sphinx/_static/ansi.css @@ -69,7 +69,7 @@ } .ansi-fg-white { - color: #2e3436; + color: #ffffff; } .ansi-fg-light-black { diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 5d471c695c..d718454364 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -159,7 +159,6 @@ and checked to be :math:`-1`. This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. - High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst deleted file mode 100644 index 86bb0502c6..0000000000 --- a/doc/sphinx/addendum/omega.rst +++ /dev/null @@ -1,210 +0,0 @@ -.. _omega_chapter: - -Omega: a (deprecated) solver for arithmetic -===================================================================== - -:Author: Pierre Crégut - -.. warning:: - - The :tacn:`omega` tactic is deprecated in favor of the :tacn:`lia` - tactic. The goal is to consolidate the arithmetic solving - capabilities of Coq into a single engine; moreover, :tacn:`lia` is - in general more powerful than :tacn:`omega` (it is a complete - Presburger arithmetic solver while :tacn:`omega` was known to be - incomplete). - - It is recommended to switch from :tacn:`omega` to :tacn:`lia` in existing - projects. We also ask that you report (in our `bug tracker - <https://github.com/coq/coq/issues>`_) any issue you encounter, especially - if the issue was not present in :tacn:`omega`. If no new issues are - reported, :tacn:`omega` will be removed soon. - - Note that replacing :tacn:`omega` with :tacn:`lia` can break - non-robust proof scripts which rely on incompleteness bugs of - :tacn:`omega` (e.g. using the pattern :g:`; try omega`). - -Description of ``omega`` ------------------------- - -.. tacn:: omega - - .. deprecated:: 8.12 - - Use :tacn:`lia` instead. - - :tacn:`omega` is a tactic for solving goals in Presburger arithmetic, - i.e. for proving formulas made of equations and inequalities over the - type ``nat`` of natural numbers or the type ``Z`` of binary-encoded integers. - Formulas on ``nat`` are automatically injected into ``Z``. The procedure - may use any hypothesis of the current proof session to solve the goal. - - Multiplication is handled by :tacn:`omega` but only goals where at - least one of the two multiplicands of products is a constant are - solvable. This is the restriction meant by "Presburger arithmetic". - - If the tactic cannot solve the goal, it fails with an error message. - In any case, the computation eventually stops. - -Arithmetical goals recognized by ``omega`` ------------------------------------------- - -:tacn:`omega` applies only to quantifier-free formulas built from the connectives:: - - /\ \/ ~ -> - -on atomic formulas. Atomic formulas are built from the predicates:: - - = < <= > >= - -on ``nat`` or ``Z``. In expressions of type ``nat``, :tacn:`omega` recognizes:: - - + - * S O pred - -and in expressions of type ``Z``, :tacn:`omega` recognizes numeral constants and:: - - + - * Z.succ Z.pred - -All expressions of type ``nat`` or ``Z`` not built on these -operators are considered abstractly as if they -were arbitrary variables of type ``nat`` or ``Z``. - -Messages from ``omega`` ------------------------ - -When :tacn:`omega` does not solve the goal, one of the following errors -is generated: - -.. exn:: omega can't solve this system. - - This may happen if your goal is not quantifier-free (if it is - universally quantified, try :tacn:`intros` first; if it contains - existentials quantifiers too, :tacn:`omega` is not strong enough to solve your - goal). This may happen also if your goal contains arithmetical - operators not recognized by :tacn:`omega`. Finally, your goal may be simply - not true! - -.. exn:: omega: Not a quantifier-free goal. - - If your goal is universally quantified, you should first apply - :tacn:`intro` as many times as needed. - -.. exn:: omega: Unrecognized predicate or connective: @ident. - :undocumented: - -.. exn:: omega: Unrecognized atomic proposition: ... - :undocumented: - -.. exn:: omega: Can't solve a goal with proposition variables. - :undocumented: - -.. exn:: omega: Unrecognized proposition. - :undocumented: - -.. exn:: omega: Can't solve a goal with non-linear products. - :undocumented: - -.. exn:: omega: Can't solve a goal with equality on type ... - :undocumented: - - -Using ``omega`` ---------------- - -The ``omega`` tactic does not belong to the core system. It should be -loaded by - -.. coqtop:: in - - Require Import Omega. - -.. example:: - - .. coqtop:: all warn - - Require Import Omega. - - Open Scope Z_scope. - - Goal forall m n:Z, 1 + 2 * m <> 2 * n. - intros; omega. - Abort. - - Goal forall z:Z, z > 0 -> 2 * z + 1 > z. - intro; omega. - Abort. - - -Options -------- - -.. flag:: Stable Omega - - .. deprecated:: 8.5 - - This deprecated flag (on by default) is for compatibility with Coq pre 8.5. It - resets internal name counters to make executions of :tacn:`omega` independent. - -.. flag:: Omega UseLocalDefs - - This flag (on by default) allows :tacn:`omega` to use the :term:`bodies <body>` of local - variables. - -.. flag:: Omega System - - This flag (off by default) activate the printing of debug information - -.. flag:: Omega Action - - This flag (off by default) activate the printing of debug information - -Technical data --------------- - -Overview of the tactic -~~~~~~~~~~~~~~~~~~~~~~ - - * The goal is negated twice and the first negation is introduced as a hypothesis. - * Hypotheses are decomposed in simple equations or inequalities. Multiple - goals may result from this phase. - * Equations and inequalities over ``nat`` are translated over - ``Z``, multiple goals may result from the translation of subtraction. - * Equations and inequalities are normalized. - * Goals are solved by the OMEGA decision procedure. - * The script of the solution is replayed. - -Overview of the OMEGA decision procedure -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The OMEGA decision procedure involved in the :tacn:`omega` tactic uses -a small subset of the decision procedure presented in :cite:`TheOmegaPaper` -Here is an overview, refer to the original paper for more information. - - * Equations and inequalities are normalized by division by the GCD of their - coefficients. - * Equations are eliminated, using the Banerjee test to get a coefficient - equal to one. - * Note that each inequality cuts the Euclidean space in half. - * Inequalities are solved by projecting on the hyperspace - defined by cancelling one of the variables. They are partitioned - according to the sign of the coefficient of the eliminated - variable. Pairs of inequalities from different classes define a - new edge in the projection. - * Redundant inequalities are eliminated or merged in new - equations that can be eliminated by the Banerjee test. - * The last two steps are iterated until a contradiction is reached - (success) or there is no more variable to eliminate (failure). - -It may happen that there is a real solution and no integer one. The last -steps of the Omega procedure are not implemented, so the -decision procedure is only partial. - -Bugs ----- - - * The simplification procedure is very dumb and this results in - many redundant cases to explore. - - * Much too slow. - - * Certainly other bugs! You can report them to https://coq.inria.fr/bugs/. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 4f3ee2dcaf..f8d6b35226 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -721,6 +721,33 @@ CoqIDE (`#13870 <https://github.com/coq/coq/pull/13870>`_, by Guillaume Melquiond). +Changes in 8.13.2 +~~~~~~~~~~~~~~~~~ + +Kernel +^^^^^^ + +- **Fixed:** + Crash when using :tacn:`vm_compute` on an irreducible ``PArray.set`` + (`#14005 <https://github.com/coq/coq/pull/14005>`_, + fixes `#13998 <https://github.com/coq/coq/issues/13998>`_, + by Guillaume Melquiond). +- **Fixed:** + Never store persistent arrays as VM / native structured values. + This could be used to make vo marshalling crash, and probably + breaking some other invariants of the kernel + (`#14007 <https://github.com/coq/coq/pull/14007>`_, + fixes `#14006 <https://github.com/coq/coq/issues/14006>`_, + by Pierre-Marie Pédrot). + +Tactic language +^^^^^^^^^^^^^^^^ + +- **Fixed:** + Ltac2 ``Array.init`` no longer incurs exponential overhead when used + recursively (`#14012 <https://github.com/coq/coq/pull/14012>`_, fixes `#14011 + <https://github.com/coq/coq/issues/14011>`_, by Jason Gross). + Version 8.12 ------------ @@ -751,10 +778,8 @@ The main changes include: of chapters along with updated syntax descriptions that match Coq's grammar in most but not all chapters. -Additionally, the :tacn:`omega` tactic is deprecated in this version of Coq, -and we recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter -<omega_chapter>`). +Additionally, the `omega` tactic is deprecated in this version of Coq, +and we recommend users to switch to :tacn:`lia` in new proof scripts. See the `Changes in 8.12+beta1`_ section and following sections for the detailed list of changes, including potentially breaking changes marked @@ -1019,7 +1044,7 @@ Tactics <https://github.com/coq/coq/pull/10760>`_, by Jason Gross). - **Changed:** The :g:`auto with zarith` tactic and variations (including - :tacn:`intuition`) may now call :tacn:`lia` instead of :tacn:`omega` + :tacn:`intuition`) may now call :tacn:`lia` instead of `omega` (when the `Omega` module is loaded); more goals may be automatically solved, fewer section variables will be captured spuriously (`#11018 <https://github.com/coq/coq/pull/11018>`_, @@ -1115,7 +1140,7 @@ Tactics (`#11883 <https://github.com/coq/coq/pull/11883>`_, by Attila Gáspár). - **Deprecated:** - The :tacn:`omega` tactic is deprecated; + The `omega` tactic is deprecated; use :tacn:`lia` from the :ref:`Micromega <micromega>` plugin instead (`#11976 <https://github.com/coq/coq/pull/11976>`_, by Vincent Laporte). @@ -2102,11 +2127,9 @@ The main changes brought by Coq version 8.11 are: - :ref:`Revision<811Reals>` of the :g:`Coq.Reals` library, its axiomatisation and instances of the constructive and classical real numbers. -Additionally, while the :tacn:`omega` tactic is not yet deprecated in +Additionally, while the `omega` tactic is not yet deprecated in this version of Coq, it should soon be the case and we already -recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter -<omega_chapter>`). +recommend users to switch to :tacn:`lia` in new proof scripts. The ``dev/doc/critical-bugs`` file documents the known critical bugs of Coq and affected releases. See the `Changes in 8.11+beta1`_ diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 9f097b4fe9..abe928fa26 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -5,7 +5,7 @@ The underlying formal language of Coq is a :gdef:`Calculus of Inductive Constructions` (|Cic|) whose inference rules are presented in this chapter. The history of this formalism as well as pointers to related -work are provided in a separate chapter; see *Credits*. +work are provided in a separate chapter; see :ref:`history`. .. _The-terms: diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 5d36ec3cf9..49c2c6b785 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -515,6 +515,11 @@ To build, say, two targets foo.vo and bar.vo in parallel one can use + ``-extra-phony`` and ``-extra`` are deprecated. To provide additional target (``.PHONY`` or not) please use ``CoqMakefile.local``. +.. note:: + + Due to limitations with the compilation chain, makefiles generated + by ``coq_makefile`` won't correctly compile OCaml plugins with OCaml + < 4.07.0 when using more than one job (``-j N`` for ``N > 1``). Precompiling for ``native_compute`` +++++++++++++++++++++++++++++++++++ diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b1759bf71b..88fca93547 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1666,7 +1666,7 @@ Proving a subgoal as a separate lemma: abstract is chosen to get a fresh name. If the proof is closed with :cmd:`Qed`, the auxiliary lemma is inlined in the final proof term. - This is useful with tactics such as :tacn:`omega` or + This is useful with tactics such as :tacn:`discriminate` that generate huge proof terms with many intermediate goals. It can significantly reduce peak memory use. In most cases it doesn't have a significant impact on run time. One case in which it can reduce run time @@ -2317,11 +2317,10 @@ performance issue. .. coqtop:: reset in - Set Warnings "-omega-is-deprecated". - Require Import Coq.omega.Omega. + Require Import Lia. Ltac mytauto := tauto. - Ltac tac := intros; repeat split; omega || mytauto. + Ltac tac := intros; repeat split; lia || mytauto. Notation max x y := (x + (y - x)) (only parsing). @@ -2340,7 +2339,7 @@ performance issue. Set Ltac Profiling. tac. Show Ltac Profile. - Show Ltac Profile "omega". + Show Ltac Profile "lia". .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 9f3f0ef3d5..25ac72069b 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -66,7 +66,6 @@ Current limitations include: - An easy way to get the number of constructors of an inductive type. Currently only way to do this is to destruct a variable of the inductive type and count the number of goals that result. -- The :attr:`deprecated` attribute is not supported for Ltac2 definitions. - Error messages may be cryptic. @@ -229,6 +228,8 @@ One can define new types with the following commands. defined in Coq and give their type information. They can also declare data structures from OCaml. This command has no use for the end user. + This command supports the :attr:`deprecated` attribute. + APIs ~~~~ @@ -263,10 +264,10 @@ There is dedicated syntax for list and array literals. .. prodn:: ltac2_expr ::= @ltac2_expr5 ; @ltac2_expr | @ltac2_expr5 - ltac2_expr5 ::= fun {+ @tac2pat0 } => @ltac2_expr + ltac2_expr5 ::= fun {+ @tac2pat0 } {? : @ltac2_type } => @ltac2_expr | let {? rec } @ltac2_let_clause {* with @ltac2_let_clause } in @ltac2_expr | @ltac2_expr3 - ltac2_let_clause ::= {+ @tac2pat0 } := @ltac2_expr + ltac2_let_clause ::= {+ @tac2pat0 } {? : @ltac2_type } := @ltac2_expr ltac2_expr3 ::= {+, @ltac2_expr2 } ltac2_expr2 ::= @ltac2_expr1 :: @ltac2_expr2 | @ltac2_expr1 @@ -304,7 +305,7 @@ Ltac2 Definitions .. insertprodn tac2def_body tac2def_body .. prodn:: - tac2def_body ::= {| _ | @ident } {* @tac2pat0 } := @ltac2_expr + tac2def_body ::= {| _ | @ident } {* @tac2pat0 } {? : @ltac2_type } := @ltac2_expr This command defines a new global Ltac2 value. If one or more :token:`tac2pat0` are specified, the new value is a function. This is a shortcut for one of the @@ -319,6 +320,8 @@ Ltac2 Definitions If ``mutable`` is set, the definition can be redefined at a later stage (see below). + This command supports the :attr:`deprecated` attribute. + .. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr This command redefines a previous ``mutable`` definition. @@ -1246,6 +1249,8 @@ Notations so that you may have to resort to thunking to ensure that side-effects are performed at the right time. + This command supports the :attr:`deprecated` attribute. + Abbreviations ~~~~~~~~~~~~~ @@ -1276,6 +1281,8 @@ Abbreviations Note that abbreviations are not type checked at all, and may result in typing errors after expansion. + This command supports the :attr:`deprecated` attribute. + .. _defining_tactics: Defining tactics @@ -1368,8 +1375,9 @@ table further down lists the classes that that are handled plainly. the term (as described in :ref:`LocalInterpretationRulesForNotations`). The last :token:`scope_key` is the top of the scope stack that's applied to the :token:`term`. - :n:`open_constr` - Parses an open :token:`term`. + :n:`open_constr {? ( {+, @scope_key } ) }` + Parses an open :token:`term`. Like :n:`constr` above, this class + accepts a list of notation scopes with the same effects. :n:`ident` Parses :token:`ident` or :n:`$@ident`. The first form returns :n:`ident:(@ident)`, diff --git a/doc/sphinx/proofs/automatic-tactics/index.rst b/doc/sphinx/proofs/automatic-tactics/index.rst index c3712b109d..e458c3a9f5 100644 --- a/doc/sphinx/proofs/automatic-tactics/index.rst +++ b/doc/sphinx/proofs/automatic-tactics/index.rst @@ -14,7 +14,6 @@ complex goals in new domains. :maxdepth: 1 logic - ../../addendum/omega ../../addendum/micromega ../../addendum/ring ../../addendum/nsatz diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 557ef10555..d212256765 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -442,6 +442,12 @@ Displaying information about notations Controls whether to use notations for printing terms wherever possible. Default is on. +.. flag:: Printing Raw Literals + + Controls whether to use string and number notations for printing terms + wherever possible (see :ref:`string-notations`). + Default is off. + .. flag:: Printing Parentheses If on, parentheses are printed even if implied by associativity and precedence @@ -461,6 +467,7 @@ Displaying information about notations - `tactic` - for currently-defined tactic notations, :token:`tactic`\s and tacticals (corresponding to :token:`ltac_expr` in the documentation). - `vernac` - for :token:`command`\s + - `ltac2` - for Ltac2 notations (corresponding to :token:`ltac2_expr`) This command doesn't display all nonterminals of the grammar. For example, productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` diff --git a/doc/sphinx/using/libraries/writing.rst b/doc/sphinx/using/libraries/writing.rst index 917edf0774..7461bfe443 100644 --- a/doc/sphinx/using/libraries/writing.rst +++ b/doc/sphinx/using/libraries/writing.rst @@ -22,13 +22,17 @@ deprecated compatibility alias using :cmd:`Notation (abbreviation)` by a comma. This attribute is supported by the following commands: :cmd:`Ltac`, - :cmd:`Tactic Notation`, :cmd:`Notation`, :cmd:`Infix`. + :cmd:`Tactic Notation`, :cmd:`Notation`, :cmd:`Infix`, :cmd:`Ltac2`, + :cmd:`Ltac2 Notation`, :cmd:`Ltac2 external`. It can trigger the following warnings: .. warn:: Tactic @qualid is deprecated since @string__since. @string__note. Tactic Notation @qualid is deprecated since @string__since. @string__note. Notation @string is deprecated since @string__since. @string__note. + Ltac2 definition @qualid is deprecated since @string__since. @string__note. + Ltac2 alias @qualid is deprecated since @string__since. @string__note. + Ltac2 notation {+ @ltac2_scope } is deprecated since @string__since. @string__note. :n:`@qualid` or :n:`@string` is the notation, :n:`@string__since` is the version number, :n:`@string__note` is diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index e4f0967794..bca66cc61b 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -58,10 +58,7 @@ theories/micromega/ZifyPow.v theories/micromega/Zify.v theories/nsatz/NsatzTactic.v theories/nsatz/Nsatz.v -theories/omega/Omega.v theories/omega/OmegaLemmas.v -theories/omega/OmegaPlugin.v -theories/omega/OmegaTactic.v theories/omega/PreOmega.v theories/quote/Quote.v theories/romega/ROmega.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index b0f4e883be..6fda3b06ce 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -135,6 +135,7 @@ through the <tt>Require Import</tt> command.</p> theories/Arith/Bool_nat.v theories/Arith/Factorial.v theories/Arith/Wf_nat.v + theories/Arith/Cantor.v </dd> <dt> <b>PArith</b>: @@ -685,6 +686,7 @@ through the <tt>Require Import</tt> command.</p> user-contrib/Ltac2/Fresh.v user-contrib/Ltac2/Ident.v user-contrib/Ltac2/Init.v + user-contrib/Ltac2/Ind.v user-contrib/Ltac2/Int.v user-contrib/Ltac2/List.v user-contrib/Ltac2/Ltac1.v diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 1ab4fe8f81..aa95d4f249 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -529,12 +529,12 @@ class ProductionObject(CoqObject): self.signatures = [] indexnode = super().run()[0] # makes calls to handle_signature - table = nodes.container(classes=['prodn-table']) - tgroup = nodes.container(classes=['prodn-column-group']) + table = nodes.inline(classes=['prodn-table']) + tgroup = nodes.inline(classes=['prodn-column-group']) for _ in range(4): - tgroup += nodes.container(classes=['prodn-column']) + tgroup += nodes.inline(classes=['prodn-column']) table += tgroup - tbody = nodes.container(classes=['prodn-row-group']) + tbody = nodes.inline(classes=['prodn-row-group']) table += tbody # create rows @@ -542,8 +542,8 @@ class ProductionObject(CoqObject): lhs, op, rhs, tag = signature position = self.state_machine.get_source_and_line(self.lineno) - row = nodes.container(classes=['prodn-row']) - entry = nodes.container(classes=['prodn-cell-nonterminal']) + row = nodes.inline(classes=['prodn-row']) + entry = nodes.inline(classes=['prodn-cell-nonterminal']) if lhs != "": target_name = make_id('grammar-token-' + lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) @@ -553,19 +553,19 @@ class ProductionObject(CoqObject): entry += inline entry += notation_to_sphinx('@'+lhs, *position) else: - entry += nodes.Text('') + entry += nodes.literal('', '') row += entry - entry = nodes.container(classes=['prodn-cell-op']) - entry += nodes.Text(op) + entry = nodes.inline(classes=['prodn-cell-op']) + entry += nodes.literal(op, op) row += entry - entry = nodes.container(classes=['prodn-cell-production']) + entry = nodes.inline(classes=['prodn-cell-production']) entry += notation_to_sphinx(rhs, *position) row += entry - entry = nodes.container(classes=['prodn-cell-tag']) - entry += nodes.Text(tag) + entry = nodes.inline(classes=['prodn-cell-tag']) + entry += nodes.literal(tag, tag) row += entry tbody += row diff --git a/doc/tools/coqrst/repl/ansicolors.py b/doc/tools/coqrst/repl/ansicolors.py index 9e23be2409..6700c20b1a 100644 --- a/doc/tools/coqrst/repl/ansicolors.py +++ b/doc/tools/coqrst/repl/ansicolors.py @@ -91,7 +91,10 @@ def parse_ansi(code): leading ‘^[[’ or the final ‘m’ """ classes = [] - parse_style([int(c) for c in code.split(';')], 0, classes) + if code == "37": + pass # ignore white fg + else: + parse_style([int(c) for c in code.split(';')], 0, classes) return ["ansi-" + cls for cls in classes] if __name__ == '__main__': diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 24ecc65e9b..fd1c3c0260 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -2730,6 +2730,7 @@ SPLICE: [ | variance_identref | rewriter | conversion +| type_cast ] (* end SPLICE *) RENAME: [ diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 4ba60ddd9f..873b2f8dff 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -21,7 +21,6 @@ (glob_files %{project_root}/plugins/ltac/*.mlg) (glob_files %{project_root}/plugins/micromega/*.mlg) (glob_files %{project_root}/plugins/nsatz/*.mlg) - (glob_files %{project_root}/plugins/omega/*.mlg) (glob_files %{project_root}/plugins/ring/*.mlg) (glob_files %{project_root}/plugins/rtauto/*.mlg) (glob_files %{project_root}/plugins/ssr/*.mlg) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index be1b9d80fb..0c8980b1bd 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1,6 +1,492 @@ (* Coq grammar generated from .mlg files. Do not edit by hand. Not compiled into Coq *) DOC_GRAMMAR +Constr.ident: [ +| Prim.ident +] + +Prim.name: [ +| "_" +] + +global: [ +| Prim.reference +] + +constr_pattern: [ +| constr +] + +cpattern: [ +| lconstr +] + +sort: [ +| "Set" +| "Prop" +| "SProp" +| "Type" +| "Type" "@{" "_" "}" +| "Type" "@{" universe "}" +] + +sort_family: [ +| "Set" +| "Prop" +| "SProp" +| "Type" +] + +universe_increment: [ +| "+" natural +| +] + +universe_name: [ +| global +| "Set" +| "Prop" +] + +universe_expr: [ +| universe_name universe_increment +] + +universe: [ +| "max" "(" LIST1 universe_expr SEP "," ")" +| universe_expr +] + +lconstr: [ +| term200 +] + +constr: [ +| term8 +| "@" global univ_annot +] + +term200: [ +| binder_constr +| term100 +] + +term100: [ +| term99 "<:" term200 +| term99 "<<:" term200 +| term99 ":" term200 +| term99 ":>" +| term99 +] + +term99: [ +| term90 +] + +term90: [ +| term10 +] + +term10: [ +| term9 LIST1 arg +| "@" global univ_annot LIST0 term9 +| "@" pattern_ident LIST1 identref +| term9 +] + +term9: [ +| ".." term0 ".." +| term8 +] + +term8: [ +| term1 +] + +term1: [ +| term0 ".(" global LIST0 arg ")" +| term0 ".(" "@" global LIST0 ( term9 ) ")" +| term0 "%" IDENT +| term0 +] + +term0: [ +| atomic_constr +| term_match +| "(" term200 ")" +| "{|" record_declaration bar_cbrace +| "{" binder_constr "}" +| "`{" term200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot +| "`(" term200 ")" +| "ltac" ":" "(" Pltac.ltac_expr ")" +] + +array_elems: [ +| LIST0 lconstr SEP ";" +] + +record_declaration: [ +| fields_def +] + +fields_def: [ +| field_def ";" fields_def +| field_def +| +] + +field_def: [ +| global binders ":=" lconstr +] + +binder_constr: [ +| "forall" open_binders "," term200 +| "fun" open_binders "=>" term200 +| "let" name binders let_type_cstr ":=" term200 "in" term200 +| "let" "fix" fix_decl "in" term200 +| "let" "cofix" cofix_body "in" term200 +| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 case_type "in" term200 +| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 +| "if" term200 as_return_type "then" term200 "else" term200 +| "fix" fix_decls +| "cofix" cofix_decls +| "if" term200 "is" ssr_dthen ssr_else (* SSR plugin *) +| "if" term200 "isn't" ssr_dthen ssr_else (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +] + +arg: [ +| test_lpar_id_coloneq "(" identref ":=" lconstr ")" +| term9 +] + +atomic_constr: [ +| global univ_annot +| sort +| NUMBER +| string +| "_" +| "?" "[" identref "]" +| "?" "[" pattern_ident "]" +| pattern_ident evar_instance +] + +inst: [ +| identref ":=" lconstr +] + +evar_instance: [ +| "@{" LIST1 inst SEP ";" "}" +| +] + +univ_annot: [ +| "@{" LIST0 universe_level "}" +| +] + +universe_level: [ +| "Set" +| "Prop" +| "Type" +| "_" +| global +] + +fix_decls: [ +| fix_decl +| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref +] + +cofix_decls: [ +| cofix_body +| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref +] + +fix_decl: [ +| identref binders_fixannot type_cstr ":=" term200 +] + +cofix_body: [ +| identref binders type_cstr ":=" term200 +] + +term_match: [ +| "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" +] + +case_item: [ +| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] +] + +case_type: [ +| "return" term100 +] + +as_return_type: [ +| OPT [ OPT [ "as" name ] case_type ] +] + +branches: [ +| OPT "|" LIST0 eqn SEP "|" +] + +mult_pattern: [ +| LIST1 pattern200 SEP "," +] + +eqn: [ +| LIST1 mult_pattern SEP "|" "=>" lconstr +] + +record_pattern: [ +| global ":=" pattern200 +] + +record_patterns: [ +| record_pattern ";" record_patterns +| record_pattern +| +] + +pattern200: [ +| pattern100 +] + +pattern100: [ +| pattern99 ":" term200 +| pattern99 +] + +pattern99: [ +| pattern90 +] + +pattern90: [ +| pattern10 +] + +pattern10: [ +| pattern1 "as" name +| pattern1 LIST1 pattern1 +| "@" Prim.reference LIST0 pattern1 +| pattern1 +] + +pattern1: [ +| pattern0 "%" IDENT +| pattern0 +] + +pattern0: [ +| Prim.reference +| "{|" record_patterns bar_cbrace +| "_" +| "(" pattern200 ")" +| "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" +| NUMBER +| string +] + +fixannot: [ +| "{" "struct" identref "}" +| "{" "wf" constr identref "}" +| "{" "measure" constr OPT identref OPT constr "}" +] + +binders_fixannot: [ +| ensure_fixannot fixannot +| binder binders_fixannot +| +] + +open_binders: [ +| name LIST0 name ":" lconstr +| name LIST0 name binders +| name ".." name +| closed_binder binders +] + +binders: [ +| LIST0 binder +| Pcoq.Constr.binders +] + +binder: [ +| name +| closed_binder +] + +closed_binder: [ +| "(" name LIST1 name ":" lconstr ")" +| "(" name ":" lconstr ")" +| "(" name ":=" lconstr ")" +| "(" name ":" lconstr ":=" lconstr ")" +| "{" name "}" +| "{" name LIST1 name ":" lconstr "}" +| "{" name ":" lconstr "}" +| "{" name LIST1 name "}" +| "[" name "]" +| "[" name LIST1 name ":" lconstr "]" +| "[" name ":" lconstr "]" +| "[" name LIST1 name "]" +| "`(" LIST1 typeclass_constraint SEP "," ")" +| "`{" LIST1 typeclass_constraint SEP "," "}" +| "`[" LIST1 typeclass_constraint SEP "," "]" +| "'" pattern0 +| [ "of" | "&" ] term99 (* SSR plugin *) +] + +one_open_binder: [ +| name +| name ":" lconstr +| one_closed_binder +] + +one_closed_binder: [ +| "(" name ":" lconstr ")" +| "{" name "}" +| "{" name ":" lconstr "}" +| "[" name "]" +| "[" name ":" lconstr "]" +| "'" pattern0 +] + +typeclass_constraint: [ +| "!" term200 +| "{" name "}" ":" [ "!" | ] term200 +| test_name_colon name ":" [ "!" | ] term200 +| term200 +] + +type_cstr: [ +| ":" lconstr +| +] + +let_type_cstr: [ +| OPT [ ":" lconstr ] +] + +preident: [ +| IDENT +] + +ident: [ +| IDENT +] + +pattern_ident: [ +| LEFTQMARK ident +] + +identref: [ +| ident +] + +hyp: [ +| identref +] + +field: [ +| FIELD +] + +fields: [ +| field fields +| field +] + +fullyqualid: [ +| ident fields +| ident +] + +name: [ +| "_" +| ident +] + +reference: [ +| ident fields +| ident +] + +qualid: [ +| reference +] + +by_notation: [ +| ne_string OPT [ "%" IDENT ] +] + +smart_global: [ +| reference +| by_notation +] + +ne_string: [ +| STRING +] + +ne_lstring: [ +| ne_string +] + +dirpath: [ +| ident LIST0 field +] + +string: [ +| STRING +] + +lstring: [ +| string +] + +integer: [ +| bigint +] + +natural: [ +| bignat +] + +bigint: [ +| bignat +| test_minus_nat "-" bignat +] + +bignat: [ +| NUMBER +] + +bar_cbrace: [ +| test_pipe_closedcurly "|" "}" +] + +strategy_level: [ +| "expand" +| "opaque" +| integer +| "transparent" +] + +vernac_toplevel: [ +| "Drop" "." +| "Quit" "." +| "BackTo" natural "." +| test_show_goal "Show" "Goal" natural "at" natural "." +| "Show" "Proof" "Diffs" OPT "removed" "." +| Pvernac.Vernac_.main_entry +] + opt_hintbases: [ | | ":" LIST1 IDENT @@ -981,492 +1467,6 @@ binder_interp: [ | "as" "strict" "pattern" ] -vernac_toplevel: [ -| "Drop" "." -| "Quit" "." -| "BackTo" natural "." -| test_show_goal "Show" "Goal" natural "at" natural "." -| "Show" "Proof" "Diffs" OPT "removed" "." -| Pvernac.Vernac_.main_entry -] - -Constr.ident: [ -| Prim.ident -] - -Prim.name: [ -| "_" -] - -global: [ -| Prim.reference -] - -constr_pattern: [ -| constr -] - -cpattern: [ -| lconstr -] - -sort: [ -| "Set" -| "Prop" -| "SProp" -| "Type" -| "Type" "@{" "_" "}" -| "Type" "@{" universe "}" -] - -sort_family: [ -| "Set" -| "Prop" -| "SProp" -| "Type" -] - -universe_increment: [ -| "+" natural -| -] - -universe_name: [ -| global -| "Set" -| "Prop" -] - -universe_expr: [ -| universe_name universe_increment -] - -universe: [ -| "max" "(" LIST1 universe_expr SEP "," ")" -| universe_expr -] - -lconstr: [ -| term200 -] - -constr: [ -| term8 -| "@" global univ_annot -] - -term200: [ -| binder_constr -| term100 -] - -term100: [ -| term99 "<:" term200 -| term99 "<<:" term200 -| term99 ":" term200 -| term99 ":>" -| term99 -] - -term99: [ -| term90 -] - -term90: [ -| term10 -] - -term10: [ -| term9 LIST1 arg -| "@" global univ_annot LIST0 term9 -| "@" pattern_ident LIST1 identref -| term9 -] - -term9: [ -| ".." term0 ".." -| term8 -] - -term8: [ -| term1 -] - -term1: [ -| term0 ".(" global LIST0 arg ")" -| term0 ".(" "@" global LIST0 ( term9 ) ")" -| term0 "%" IDENT -| term0 -] - -term0: [ -| atomic_constr -| term_match -| "(" term200 ")" -| "{|" record_declaration bar_cbrace -| "{" binder_constr "}" -| "`{" term200 "}" -| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot -| "`(" term200 ")" -| "ltac" ":" "(" Pltac.ltac_expr ")" -] - -array_elems: [ -| LIST0 lconstr SEP ";" -] - -record_declaration: [ -| fields_def -] - -fields_def: [ -| field_def ";" fields_def -| field_def -| -] - -field_def: [ -| global binders ":=" lconstr -] - -binder_constr: [ -| "forall" open_binders "," term200 -| "fun" open_binders "=>" term200 -| "let" name binders let_type_cstr ":=" term200 "in" term200 -| "let" "fix" fix_decl "in" term200 -| "let" "cofix" cofix_body "in" term200 -| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 -| "let" "'" pattern200 ":=" term200 "in" term200 -| "let" "'" pattern200 ":=" term200 case_type "in" term200 -| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 -| "if" term200 as_return_type "then" term200 "else" term200 -| "fix" fix_decls -| "cofix" cofix_decls -| "if" term200 "is" ssr_dthen ssr_else (* SSR plugin *) -| "if" term200 "isn't" ssr_dthen ssr_else (* SSR plugin *) -| "let" ":" ssr_mpat ":=" lconstr "in" lconstr (* SSR plugin *) -| "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) -| "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) -] - -arg: [ -| test_lpar_id_coloneq "(" identref ":=" lconstr ")" -| term9 -] - -atomic_constr: [ -| global univ_annot -| sort -| NUMBER -| string -| "_" -| "?" "[" identref "]" -| "?" "[" pattern_ident "]" -| pattern_ident evar_instance -] - -inst: [ -| identref ":=" lconstr -] - -evar_instance: [ -| "@{" LIST1 inst SEP ";" "}" -| -] - -univ_annot: [ -| "@{" LIST0 universe_level "}" -| -] - -universe_level: [ -| "Set" -| "Prop" -| "Type" -| "_" -| global -] - -fix_decls: [ -| fix_decl -| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref -] - -cofix_decls: [ -| cofix_body -| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref -] - -fix_decl: [ -| identref binders_fixannot type_cstr ":=" term200 -] - -cofix_body: [ -| identref binders type_cstr ":=" term200 -] - -term_match: [ -| "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" -] - -case_item: [ -| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] -] - -case_type: [ -| "return" term100 -] - -as_return_type: [ -| OPT [ OPT [ "as" name ] case_type ] -] - -branches: [ -| OPT "|" LIST0 eqn SEP "|" -] - -mult_pattern: [ -| LIST1 pattern200 SEP "," -] - -eqn: [ -| LIST1 mult_pattern SEP "|" "=>" lconstr -] - -record_pattern: [ -| global ":=" pattern200 -] - -record_patterns: [ -| record_pattern ";" record_patterns -| record_pattern -| -] - -pattern200: [ -| pattern100 -] - -pattern100: [ -| pattern99 ":" term200 -| pattern99 -] - -pattern99: [ -| pattern90 -] - -pattern90: [ -| pattern10 -] - -pattern10: [ -| pattern1 "as" name -| pattern1 LIST1 pattern1 -| "@" Prim.reference LIST0 pattern1 -| pattern1 -] - -pattern1: [ -| pattern0 "%" IDENT -| pattern0 -] - -pattern0: [ -| Prim.reference -| "{|" record_patterns bar_cbrace -| "_" -| "(" pattern200 ")" -| "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" -| NUMBER -| string -] - -fixannot: [ -| "{" "struct" identref "}" -| "{" "wf" constr identref "}" -| "{" "measure" constr OPT identref OPT constr "}" -] - -binders_fixannot: [ -| ensure_fixannot fixannot -| binder binders_fixannot -| -] - -open_binders: [ -| name LIST0 name ":" lconstr -| name LIST0 name binders -| name ".." name -| closed_binder binders -] - -binders: [ -| LIST0 binder -| Pcoq.Constr.binders -] - -binder: [ -| name -| closed_binder -] - -closed_binder: [ -| "(" name LIST1 name ":" lconstr ")" -| "(" name ":" lconstr ")" -| "(" name ":=" lconstr ")" -| "(" name ":" lconstr ":=" lconstr ")" -| "{" name "}" -| "{" name LIST1 name ":" lconstr "}" -| "{" name ":" lconstr "}" -| "{" name LIST1 name "}" -| "[" name "]" -| "[" name LIST1 name ":" lconstr "]" -| "[" name ":" lconstr "]" -| "[" name LIST1 name "]" -| "`(" LIST1 typeclass_constraint SEP "," ")" -| "`{" LIST1 typeclass_constraint SEP "," "}" -| "`[" LIST1 typeclass_constraint SEP "," "]" -| "'" pattern0 -| [ "of" | "&" ] term99 (* SSR plugin *) -] - -one_open_binder: [ -| name -| name ":" lconstr -| one_closed_binder -] - -one_closed_binder: [ -| "(" name ":" lconstr ")" -| "{" name "}" -| "{" name ":" lconstr "}" -| "[" name "]" -| "[" name ":" lconstr "]" -| "'" pattern0 -] - -typeclass_constraint: [ -| "!" term200 -| "{" name "}" ":" [ "!" | ] term200 -| test_name_colon name ":" [ "!" | ] term200 -| term200 -] - -type_cstr: [ -| ":" lconstr -| -] - -let_type_cstr: [ -| OPT [ ":" lconstr ] -] - -preident: [ -| IDENT -] - -ident: [ -| IDENT -] - -pattern_ident: [ -| LEFTQMARK ident -] - -identref: [ -| ident -] - -hyp: [ -| identref -] - -field: [ -| FIELD -] - -fields: [ -| field fields -| field -] - -fullyqualid: [ -| ident fields -| ident -] - -name: [ -| "_" -| ident -] - -reference: [ -| ident fields -| ident -] - -qualid: [ -| reference -] - -by_notation: [ -| ne_string OPT [ "%" IDENT ] -] - -smart_global: [ -| reference -| by_notation -] - -ne_string: [ -| STRING -] - -ne_lstring: [ -| ne_string -] - -dirpath: [ -| ident LIST0 field -] - -string: [ -| STRING -] - -lstring: [ -| string -] - -integer: [ -| bigint -] - -natural: [ -| bignat -] - -bigint: [ -| bignat -| test_minus_nat "-" bignat -] - -bignat: [ -| NUMBER -] - -bar_cbrace: [ -| test_pipe_closedcurly "|" "}" -] - -strategy_level: [ -| "expand" -| "opaque" -| integer -| "transparent" -] - simple_tactic: [ | "btauto" | "congruence" @@ -1778,7 +1778,6 @@ simple_tactic: [ | "zify_iter_let" tactic (* micromega plugin *) | "zify_elim_let" (* micromega plugin *) | "nsatz_compute" constr (* nsatz plugin *) -| "omega" (* omega plugin *) | "protect_fv" string "in" ident (* ring plugin *) | "protect_fv" string (* ring plugin *) | "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* ring plugin *) @@ -3283,7 +3282,7 @@ ltac2_expr6: [ ] ltac2_expr5: [ -| "fun" LIST1 G_LTAC2_input_fun "=>" ltac2_expr6 (* Ltac2 plugin *) +| "fun" LIST1 G_LTAC2_input_fun type_cast "=>" ltac2_expr6 (* Ltac2 plugin *) | "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" ltac2_expr6 (* Ltac2 plugin *) | "match" ltac2_expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) | "if" ltac2_expr5 "then" ltac2_expr5 "else" ltac2_expr5 (* Ltac2 plugin *) @@ -3371,8 +3370,13 @@ tac2expr_in_env: [ | ltac2_expr6 (* Ltac2 plugin *) ] +type_cast: [ +| (* Ltac2 plugin *) +| ":" ltac2_type5 (* Ltac2 plugin *) +] + G_LTAC2_let_clause: [ -| let_binder ":=" ltac2_expr6 (* Ltac2 plugin *) +| let_binder type_cast ":=" ltac2_expr6 (* Ltac2 plugin *) ] let_binder: [ @@ -3415,7 +3419,7 @@ G_LTAC2_input_fun: [ ] tac2def_body: [ -| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" ltac2_expr6 (* Ltac2 plugin *) +| G_LTAC2_binder LIST0 G_LTAC2_input_fun type_cast ":=" ltac2_expr6 (* Ltac2 plugin *) ] tac2def_val: [ diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 5674d28139..40bb980e90 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1856,7 +1856,6 @@ simple_tactic: [ | "zify_iter_let" ltac_expr (* micromega plugin *) | "zify_elim_let" (* micromega plugin *) | "nsatz_compute" one_term (* nsatz plugin *) -| "omega" (* omega plugin *) | "protect_fv" string OPT ( "in" ident ) | "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) | "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) @@ -2274,7 +2273,7 @@ ltac2_entry: [ ] tac2def_body: [ -| [ "_" | ident ] LIST0 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +| [ "_" | ident ] LIST0 tac2pat0 OPT ( ":" ltac2_type ) ":=" ltac2_expr (* Ltac2 plugin *) ] tac2typ_def: [ @@ -2315,13 +2314,13 @@ ltac2_expr: [ ] ltac2_expr5: [ -| "fun" LIST1 tac2pat0 "=>" ltac2_expr (* Ltac2 plugin *) +| "fun" LIST1 tac2pat0 OPT ( ":" ltac2_type ) "=>" ltac2_expr (* Ltac2 plugin *) | "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" ltac2_expr (* Ltac2 plugin *) | ltac2_expr3 (* Ltac2 plugin *) ] ltac2_let_clause: [ -| LIST1 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +| LIST1 tac2pat0 OPT ( ":" ltac2_type ) ":=" ltac2_expr (* Ltac2 plugin *) ] ltac2_expr3: [ @@ -35,3 +35,6 @@ (deps test-suite/summary.log)) ; (dirs (:standard _build_ci)) + +(documentation + (package coq)) diff --git a/engine/termops.ml b/engine/termops.ml index 4dc584cfa8..d60aa69ccb 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -979,69 +979,52 @@ let collapse_appl sigma c = match EConstr.kind sigma c with (* First utilities for avoiding telescope computation for subst_term *) -let prefix_application sigma eq_fun (k,c) t = +let prefix_application sigma eq_fun k l1 t = let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in + let t' = collapse_appl sigma t in + if 0 < l1 then match EConstr.kind sigma t' with + | App (f2,cl2) -> + let l2 = Array.length cl2 in if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + && eq_fun sigma k (mkApp (f2, Array.sub cl2 0 l1)) then + Some (Array.sub cl2 l1 (l2 - l1)) else None | _ -> None + else None -let my_prefix_application sigma eq_fun (k,c) by_c t = - let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp ((Vars.lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else - None - | _ -> None - -(* Recognizing occurrences of a given subterm in a term: [subst_term c t] - substitutes [(Rel 1)] for all occurrences of term [c] in a term [t]; - works if [c] has rels *) - -let subst_term_gen sigma eq_fun c t = - let open EConstr in - let open Vars in - let rec substrec (k,c as kc) t = - match prefix_application sigma eq_fun kc t with - | Some x -> x - | None -> - if eq_fun sigma c t then mkRel k - else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,lift 1 c)) substrec kc t +let eq_upto_lift cache c sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c in - substrec (1,c) t - -let subst_term sigma c t = subst_term_gen sigma EConstr.eq_constr c t + EConstr.eq_constr sigma c t (* Recognizing occurrences of a given subterm in a term : [replace_term c1 c2 t] substitutes [c2] for all occurrences of term [c1] in a term [t]; works if [c1] and [c2] have rels *) -let replace_term_gen sigma eq_fun c by_c in_t = - let rec substrec (k,c as kc) t = - match my_prefix_application sigma eq_fun kc by_c t with - | Some x -> x +let replace_term_gen sigma eq_fun ar by_c in_t = + let rec substrec k t = + match prefix_application sigma eq_fun k ar t with + | Some args -> EConstr.mkApp (EConstr.Vars.lift k by_c, args) | None -> - (if eq_fun sigma c t then (EConstr.Vars.lift k by_c) else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,EConstr.Vars.lift 1 c)) - substrec kc t) + (if eq_fun sigma k t then (EConstr.Vars.lift k by_c) else + EConstr.map_with_binders sigma succ substrec k t) in - substrec (0,c) in_t + substrec 0 in_t + +let replace_term sigma c byc t = + let cache = ref Int.Map.empty in + let c = collapse_appl sigma c in + let ar = Array.length (snd (decompose_app_vect sigma c)) in + let eq sigma k t = eq_upto_lift cache c sigma k t in + replace_term_gen sigma eq ar byc t -let replace_term sigma c byc t = replace_term_gen sigma EConstr.eq_constr c byc t +let subst_term sigma c t = replace_term sigma c (EConstr.mkRel 1) t let vars_of_env env = let s = Environ.ids_of_named_context_val (Environ.named_context_val env) in diff --git a/engine/termops.mli b/engine/termops.mli index 12df61e4c8..bdde2c450d 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -122,16 +122,12 @@ val pop : constr -> constr (** Substitution of an arbitrary large term. Uses equality modulo reduction of let *) -(** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq] - as equality *) -val subst_term_gen : Evd.evar_map -> - (Evd.evar_map -> constr -> constr -> bool) -> constr -> constr -> constr - -(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq] - as equality *) +(** [replace_term_gen eq arity e c] replaces matching subterms according to + [eq] by [e] in [c]. If [arity] is non-zero applications of larger length + are handled atomically. *) val replace_term_gen : - Evd.evar_map -> (Evd.evar_map -> constr -> constr -> bool) -> - constr -> constr -> constr -> constr + Evd.evar_map -> (Evd.evar_map -> int -> constr -> bool) -> + int -> constr -> constr -> constr (** [subst_term d c] replaces [d] by [Rel 1] in [c] *) val subst_term : Evd.evar_map -> constr -> constr -> constr diff --git a/engine/uState.ml b/engine/uState.ml index 20ea24dd87..81559778f2 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -296,9 +296,6 @@ let add_constraints uctx cstrs = universes = UGraph.merge_constraints cstrs' uctx.universes; weak_constraints = weak; } -(* let addconstrkey = CProfile.declare_profile "add_constraints_context";; *) -(* let add_constraints_context = CProfile.profile2 addconstrkey add_constraints_context;; *) - let add_universe_constraints uctx cstrs = let univs, local = uctx.local in let vars, weak, local' = process_universe_constraints uctx cstrs in diff --git a/engine/univGen.ml b/engine/univGen.ml index 278ca6bf34..b917d91512 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -13,14 +13,14 @@ open Names open Constr open Univ -type univ_unique_id = int (* Generator of levels *) -let new_univ_id, set_remote_new_univ_id = - RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> n) +let new_univ_id = + let cnt = ref 0 in + fun () -> incr cnt; !cnt let new_univ_global () = - Univ.Level.UGlobal.make (Global.current_dirpath ()) (new_univ_id ()) + let s = if Flags.async_proofs_is_worker() then !Flags.async_proofs_worker_id else "" in + Univ.Level.UGlobal.make (Global.current_dirpath ()) s (new_univ_id ()) let fresh_level () = Univ.Level.make (new_univ_global ()) diff --git a/engine/univGen.mli b/engine/univGen.mli index 05737411f5..743d819747 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -13,12 +13,6 @@ open Constr open Environ open Univ - -(** The global universe counter *) -type univ_unique_id -val set_remote_new_univ_id : univ_unique_id RemoteCounter.installer -val new_univ_id : unit -> univ_unique_id (** for the stm *) - (** Side-effecting functions creating new universe levels. *) val new_univ_global : unit -> Level.UGlobal.t diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 4ed6e97526..86bf2c9298 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -406,6 +406,3 @@ let normalize_context_set ~lbound g ctx us algs weak = in let us = normalize_opt_subst us in (us, algs), (ctx', Constraint.union noneqs eqs) - -(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *) -(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *) diff --git a/engine/univProblem.ml b/engine/univProblem.ml index 8d6689933c..10ee601f3f 100644 --- a/engine/univProblem.ml +++ b/engine/univProblem.ml @@ -9,7 +9,6 @@ (************************************************************************) open Univ -open UnivSubst type t = | ULe of Universe.t * Universe.t @@ -22,24 +21,6 @@ let is_trivial = function | ULe (u, v) | UEq (u, v) -> Universe.equal u v | ULub (u, v) | UWeak (u, v) -> Level.equal u v -let subst_univs fn = function - | ULe (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | UEq (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | ULub (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (ULub (u',v')) - | UWeak (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (UWeak (u',v')) - module Set = struct module S = Set.Make( struct @@ -88,11 +69,6 @@ module Set = struct let equal x y = x == y || equal x y - - let subst_univs subst csts = - fold - (fun c -> Option.fold_right add (subst_univs subst c)) - csts empty end type 'a accumulator = Set.t -> 'a -> 'a option diff --git a/engine/univProblem.mli b/engine/univProblem.mli index 575f5ac847..6c7a11f529 100644 --- a/engine/univProblem.mli +++ b/engine/univProblem.mli @@ -32,8 +32,6 @@ module Set : sig include Set.S with type elt = t val pr : t -> Pp.t - - val subst_univs : universe_subst_fn -> t -> t end type 'a accumulator = Set.t -> 'a -> 'a option diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 330ed5d0ad..c76a4cd751 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -83,12 +83,6 @@ let subst_univs_constr subst c = let f = Univ.make_subst subst in subst_univs_fn_constr f c -let subst_univs_constr = - if Flags.profile then - let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in - CProfile.profile2 subst_univs_constr_key subst_univs_constr - else subst_univs_constr - let normalize_univ_variable ~find = let rec aux cur = let b = find cur in diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 83c158e057..fd3ff25fc1 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -129,10 +129,12 @@ let tokens con = egram.gtokens; !list +(** Used to propagate possible presence of SELF/NEXT in a rule (binary and) *) type ('a, 'b, 'c) ty_and_rec = | NoRec2 : (norec, norec, norec) ty_and_rec | MayRec2 : ('a, 'b, mayrec) ty_and_rec +(** Used to propagate possible presence of SELF/NEXT in a tree (ternary and) *) type ('a, 'b, 'c, 'd) ty_and_rec3 = | NoRec3 : (norec, norec, norec, norec) ty_and_rec3 | MayRec3 : ('a, 'b, 'c, mayrec) ty_and_rec3 @@ -167,6 +169,7 @@ and ('self, 'trec, 'a) ty_symbol = | Sself : ('self, mayrec, 'self) ty_symbol | Snext : ('self, mayrec, 'self) ty_symbol | Snterm : 'a ty_entry -> ('self, norec, 'a) ty_symbol + (* norec but the entry can nevertheless introduce a loop with the current entry*) | Snterml : 'a ty_entry * string -> ('self, norec, 'a) ty_symbol | Stree : ('self, 'trec, Loc.t -> 'a) ty_tree -> ('self, 'trec, 'a) ty_symbol @@ -346,8 +349,11 @@ let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = fun ar symbols pf tree action -> match symbols, pf with - TCns (ars, s, sl), RelS pf -> insert_in_tree ar ars s sl pf tree action + TCns (ars, s, sl), RelS pf -> + (* descent in tree at symbol [s] *) + insert_in_tree ar ars s sl pf tree action | TNil, Rel0 -> + (* insert the action *) let node (type tb) ({node = s; son = son; brother = bro} : (_, _, _, tb, _, _) ty_node) = let ar : (norec, tb, tb) ty_and_ex = match get_rec_tree bro with MayRec -> NR10 | NoRec -> NR11 in @@ -381,43 +387,56 @@ let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and | MayRec2, _, NoRec -> Node (MayRec3, node NR11) | NoRec2, NoRec2, NoRec -> Node (NoRec3, node NR11) and try_insert : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_rec -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree option = - fun ar ars s sl pf tree action -> + fun ar ars symb symbl pf tree action -> match tree with - Node (arn, {node = s1; son = son; brother = bro}) -> - begin match eq_symbol s s1 with + Node (arn, {node = symb1; son = son; brother = bro}) -> + (* merging rule [symb; symbl -> action] in tree [symb1; son | bro] *) + begin match eq_symbol symb symb1 with | Some Refl -> - let MayRecNR arss = and_symbols_tree sl son in - let son = insert arss sl pf son action in - let node = {node = s1; son = son; brother = bro} in + (* reducing merge of [symb; symbl -> action] with [symb1; son] to merge of [symbl -> action] with [son] *) + let MayRecNR arss = and_symbols_tree symbl son in + let son = insert arss symbl pf son action in + let node = {node = symb1; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) begin match ar, ars, arn, arss with | MayRec2, _, _, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec2, NoRec3, NR11 -> Some (Node (NoRec3, node)) end | None -> let ar' = and_and_tree ar arn bro in - if is_before s1 s || derive_eps s && not (derive_eps s1) then + if is_before symb1 symb || derive_eps symb && not (derive_eps symb1) then + (* inserting new rule after current rule, i.e. in [bro] *) let bro = - match try_insert ar' ars s sl pf bro action with - Some bro -> bro + match try_insert ar' ars symb symbl pf bro action with + Some bro -> + (* could insert in [bro] *) + bro | None -> - let MayRecNR arss = and_symbols_tree sl DeadEnd in - let son = insert arss sl pf DeadEnd action in - let node = {node = s; son = son; brother = bro} in + (* not ok to insert in [bro] or after; we insert now *) + let MayRecNR arss = and_symbols_tree symbl DeadEnd in + let son = insert arss symbl pf DeadEnd action in + let node = {node = symb; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) match ar, ars, arn, arss with | MayRec2, _, _, _ -> Node (MayRec3, node) | NoRec2, NoRec2, NoRec3, NR11 -> Node (NoRec3, node) in - let node = {node = s1; son = son; brother = bro} in + let node = {node = symb1; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) match ar, arn with | MayRec2, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) else - match try_insert ar' ars s sl pf bro action with + (* should insert in [bro] or before the tree [symb1; son | bro] *) + match try_insert ar' ars symb symbl pf bro action with Some bro -> - let node = {node = s1; son = son; brother = bro} in + (* could insert in [bro] *) + let node = {node = symb1; son = son; brother = bro} in begin match ar, arn with | MayRec2, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) end - | None -> None + | None -> + (* should insert before [symb1; son | bro] *) + None end | LocAct (_, _) -> None | DeadEnd -> None in @@ -470,6 +489,7 @@ let is_level_labelled n (Level lev) = let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with | TCns (_, Sself, symbols) -> + (* Insert a rule of the form "SELF; ...." *) let Level slev = slev in let RelS pf = pf in let MayRecTree lsuffix = insert_tree entry_name symbols pf action slev.lsuffix in @@ -478,6 +498,7 @@ let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (p lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> + (* Insert a rule not starting with SELF *) let Level slev = slev in let MayRecTree lprefix = insert_tree entry_name symbols pf action slev.lprefix in Level @@ -1097,27 +1118,51 @@ let skip_if_empty bp p strm = if Stream.count strm == bp then fun a -> p strm else raise Stream.Failure -let continue entry bp a s son p1 (strm__ : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in +let continue entry bp a symb son p1 (strm__ : _ Stream.t) = + let a = (entry_of_symb entry symb).econtinue 0 bp a strm__ in let act = try p1 strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) + Stream.Failure -> raise (Stream.Error (tree_failed entry a symb son)) in fun _ -> act a -let do_recover parser_of_tree entry nlevn alevn bp a s son +(** Recover from a success on [symb] with result [a] followed by a + failure on [son] in a rule of the form [a = symb; son] *) +let do_recover parser_of_tree entry nlevn alevn bp a symb son (strm__ : _ Stream.t) = - try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with + try + (* Try to replay the son with the top occurrence of NEXT (by + default at level nlevn) and trailing SELF (by default at alevn) + replaced with self at top level; + This allows for instance to recover from a failure on the + second SELF of « SELF; "\/"; SELF » by doing as if it were + « SELF; "\/"; same-entry-at-top-level » with application e.g. to + accept "A \/ forall x, x = x" w/o requiring the expected + parentheses as in "A \/ (forall x, x = x)". *) + parser_of_tree entry nlevn alevn (top_tree entry son) strm__ + with Stream.Failure -> try + (* Discard the rule if what has been consumed before failing is + the empty sequence (due to some OPT or LIST0); example: + « OPT "!"; ident » fails to see an ident and the OPT was resolved + into the empty sequence, with application e.g. to being able to + safely write « LIST1 [ OPT "!"; id = ident -> id] ». *) skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure) strm__ with Stream.Failure -> - continue entry bp a s son (parser_of_tree entry nlevn alevn son) + (* In case of success on just SELF, NEXT or an explicit call to + a subentry followed by a failure on the rest (son), retry + parsing as if this entry had been called at its toplevel; + example: « "{"; entry-at-some-level; "}" » fails on "}" and + is retried with « "{"; same-entry-at-top-level; "}" », allowing + e.g. to parse « {1 + 1} » while « {(1 + 1)} » would + have been expected according to the level. *) + continue entry bp a symb son (parser_of_tree entry nlevn alevn son) strm__ -let recover parser_of_tree entry nlevn alevn bp a s son strm = - do_recover parser_of_tree entry nlevn alevn bp a s son strm +let recover parser_of_tree entry nlevn alevn bp a symb son strm = + do_recover parser_of_tree entry nlevn alevn bp a symb son strm let token_count = ref 0 @@ -1143,15 +1188,22 @@ let token_ematch gram tok = let tematch = L.tok_match tok in fun tok -> tematch tok +(** + nlevn: level for Snext + alevn: level for recursive calls on the left-hand side of the rule (depending on associativity) +*) + let rec parser_of_tree : type s tr r. s ty_entry -> int -> int -> (s, tr, r) ty_tree -> r parser_t = fun entry nlevn alevn -> function DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) | Node (_, {node = Sself; son = LocAct (act, _); brother = DeadEnd}) -> + (* SELF on the right-hand side of the last rule *) (fun (strm__ : _ Stream.t) -> let a = entry.estart alevn strm__ in act a) | Node (_, {node = Sself; son = LocAct (act, _); brother = bro}) -> + (* SELF on the right-hand side of a rule *) let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> match @@ -1394,6 +1446,33 @@ and parse_top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a parser fun entry symb -> parser_of_symbol entry 0 (top_symb entry symb) +(** [start_parser_of_levels entry clevn levels levn strm] goes + top-down from level [clevn] to the last level, ignoring rules + between [levn] and [clevn], as if starting from + [max(clevn,levn)]. On each rule of the form [prefix] (where + [prefix] is a rule not starting with [SELF]), it tries to consume + the stream [strm]. + + The interesting case is [entry.estart] which is + [start_parser_of_levels entry 0 entry.edesc], thus practically + going from [levn] to the end. + + More schematically, assuming each level has the form + + level n: [ a = SELF; b = suffix_tree_n -> action_n(a,b) + | a = prefix_tree_n -> action'_n(a) ] + + then the main loop does the following: + + estart n = + if prefix_tree_n matches the stream as a then econtinue n (action'_n(a)) + else start (n+1) + + econtinue n a = + if suffix_tree_n matches the stream as b then econtinue n (action_n(a,b)) + else if n=0 then a else econtinue (n-1) a +*) + let rec start_parser_of_levels entry clevn = function [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) @@ -1426,7 +1505,9 @@ let rec start_parser_of_levels entry clevn = entry.econtinue levn bp a strm) | _ -> fun levn strm -> - if levn > clevn then p1 levn strm + if levn > clevn then + (* Skip rules before [levn] *) + p1 levn strm else let (strm__ : _ Stream.t) = strm in let bp = Stream.count strm__ in @@ -1437,6 +1518,18 @@ let rec start_parser_of_levels entry clevn = entry.econtinue levn bp a strm | _ -> p1 levn strm__ +(** [continue_parser_of_levels entry clevn levels levn bp a strm] goes + bottom-up from the last level to level [clevn], ignoring rules + between [levn] and [clevn], as if stopping at [max(clevn,levn)]. + It tries to consume the stream [strm] on the suffix of rules of + the form [SELF; suffix] knowing that [a] is what consumed [SELF] + at level [levn] (or [levn+1] depending on associativity). + + The interesting case is [entry.econtinue levn bp a] which is [try + continue_parser_of_levels entry 0 entry.edesc levn bp a with + Failure -> a], thus practically going from the end to [levn]. +*) + let rec continue_parser_of_levels entry clevn = function [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) @@ -1452,7 +1545,9 @@ let rec continue_parser_of_levels entry clevn = in let p2 = parser_of_tree entry (succ clevn) alevn tree in fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm + if levn > clevn then + (* Skip rules before [levn] *) + p1 levn bp a strm else let (strm__ : _ Stream.t) = strm in try p1 levn bp a strm__ with diff --git a/ide/coqide/coq-ssreflect.lang b/ide/coqide/coq-ssreflect.lang index fc7bc64a68..d71277f42c 100644 --- a/ide/coqide/coq-ssreflect.lang +++ b/ide/coqide/coq-ssreflect.lang @@ -32,7 +32,7 @@ <define-regex id="qualit">(\%{ident}*\.)*\%{ident}</define-regex> <define-regex id="undotted_sep">[-+*{}]</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> - <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex> + <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Variant)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex> <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex> <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex> <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex> diff --git a/ide/coqide/coq.lang b/ide/coqide/coq.lang index e9eab48de7..e6e813aca2 100644 --- a/ide/coqide/coq.lang +++ b/ide/coqide/coq.lang @@ -29,7 +29,7 @@ <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> <define-regex id="bullet">([-+*]+|{)(\s|\z)|}(\s*})*</define-regex> - <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> + <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Variant|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> <define-regex id="mult_decl">Hypothes[ie]s|Axiom(s)?|Variable(s)?|Parameter(s)?|Context|Implicit\%{space}Type(s)?</define-regex> <define-regex id="locality">((Local|Global)\%{space})?</define-regex> <define-regex id="begin_proof">Theorem|Lemma|Fact|Remark|Corollary|Proposition|Property</define-regex> diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index 20e9f0134f..dc616066c2 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -538,7 +538,7 @@ struct let implicit = BoolOpt ["Printing"; "Implicit"] let coercions = BoolOpt ["Printing"; "Coercions"] - let raw_matching = BoolOpt ["Printing"; "Matching"] + let nested_matching = BoolOpt ["Printing"; "Matching"] let notations = BoolOpt ["Printing"; "Notations"] let parentheses = BoolOpt ["Printing"; "Parentheses"] let all_basic = BoolOpt ["Printing"; "All"] @@ -553,8 +553,8 @@ struct let bool_items = [ { opts = [implicit]; init = false; label = "Display _implicit arguments" }; { opts = [coercions]; init = false; label = "Display _coercions" }; - { opts = [raw_matching]; init = true; - label = "Display raw _matching expressions" }; + { opts = [nested_matching]; init = true; + label = "Display nested _matching expressions" }; { opts = [notations]; init = true; label = "Display _notations" }; { opts = [parentheses]; init = false; label = "Display _parentheses" }; { opts = [all_basic]; init = false; diff --git a/ide/coqide/coq_commands.ml b/ide/coqide/coq_commands.ml index 2d75ad9ff6..3a080d5f51 100644 --- a/ide/coqide/coq_commands.ml +++ b/ide/coqide/coq_commands.ml @@ -93,7 +93,6 @@ let commands = [ ]; ["Read Module"; "Record"; - "Variant"; "Remark"; "Remove LoadPath"; "Remove Printing Constructor"; @@ -151,6 +150,7 @@ let commands = [ "Unset Silent."; "Unset Undo";]; ["Variable"; + "Variant"; "Variables";]; ["Write State";]; ] diff --git a/ide/coqide/coqide_ui.ml b/ide/coqide/coqide_ui.ml index badfabf07e..82eca905ea 100644 --- a/ide/coqide/coqide_ui.ml +++ b/ide/coqide/coqide_ui.ml @@ -77,7 +77,7 @@ let init () = \n <separator/>\ \n <menuitem action='Display implicit arguments' />\ \n <menuitem action='Display coercions' />\ -\n <menuitem action='Display raw matching expressions' />\ +\n <menuitem action='Display nested matching expressions' />\ \n <menuitem action='Display notations' />\ \n <menuitem action='Display parentheses' />\ \n <menuitem action='Display all basic low-level contents' />\ diff --git a/ide/coqide/dune b/ide/coqide/dune index 4bb4672cd4..d2642f77bf 100644 --- a/ide/coqide/dune +++ b/ide/coqide/dune @@ -51,6 +51,9 @@ (modes exe byte) (libraries coqide_gui)) +(documentation + (package coqide)) + ; Input-method bindings (executable (name default_bindings_src) diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index a6a7f7d742..0a0b932c46 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -177,7 +177,6 @@ let concl_next_tac = "symmetry" ] @ [ "assumption"; - "omega"; "ring"; "auto"; "eauto"; @@ -490,11 +489,11 @@ let eval_call c = let print_xml = let m = Mutex.create () in fun oc xml -> - Mutex.lock m; - if !Flags.xml_debug then - Printf.printf "SENT --> %s\n%!" (Xml_printer.to_string_fmt xml); - try Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m - with e -> let e = Exninfo.capture e in Mutex.unlock m; Exninfo.iraise e + CThread.with_lock m ~scope:(fun () -> + if !Flags.xml_debug then + Printf.printf "SENT --> %s\n%!" (Xml_printer.to_string_fmt xml); + try Control.protect_sigalrm (Xml_printer.print oc) xml + with e -> let e = Exninfo.capture e in Exninfo.iraise e) let slave_feeder fmt xml_oc msg = let xml = Xmlprotocol.(of_feedback fmt msg) in diff --git a/ide/coqide/index.mld b/ide/coqide/index.mld new file mode 100644 index 0000000000..8852a2a7eb --- /dev/null +++ b/ide/coqide/index.mld @@ -0,0 +1,3 @@ +{0 coqide } + +The coqide package only contains the CoqIDE executable and no OCaml library. diff --git a/ide/coqide/preferences.ml b/ide/coqide/preferences.ml index 5a77f4ebcf..8361cc3940 100644 --- a/ide/coqide/preferences.ml +++ b/ide/coqide/preferences.ml @@ -304,7 +304,7 @@ let encoding = new preference ~name:["encoding"] ~init ~repr let automatic_tactics = - let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in + let init = ["trivial"; "tauto"; "auto"; "auto with *"; "intuition" ] in new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list) let cmd_print = diff --git a/index.mld b/index.mld new file mode 100644 index 0000000000..706688656e --- /dev/null +++ b/index.mld @@ -0,0 +1,5 @@ +{0 coq } + +The coq package is a virtual package gathering the coq-core and coq-stdlib packages. + +For the documentation of the OCaml API of Coq, see the {{: ../coq-core/index.html } coq-core } package. diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 4fb7861ca6..f687c4a640 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -27,6 +27,7 @@ open Glob_term open Glob_ops open Pattern open Detyping +open Structures module NamedDecl = Context.Named.Declaration (*i*) @@ -64,7 +65,7 @@ let print_parentheses = Notation_ops.print_parentheses (* This forces printing universe names of Type{.} *) let print_universes = Detyping.print_universes -(* This suppresses printing of primitive tokens (e.g. numeral) and notations *) +(* This suppresses printing of notations *) let print_no_symbol = ref false (* This tells to skip types if a variable has this type by default *) @@ -74,6 +75,9 @@ let print_use_implicit_types = ~key:["Printing";"Use";"Implicit";"Types"] ~value:true +(* Print primitive tokens, like strings *) +let print_raw_literal = ref false + (**********************************************************************) let hole = CAst.make @@ CHole (None, IntroAnonymous, None) @@ -229,7 +233,7 @@ let get_record_print = let is_record indsp = try - let _ = Recordops.lookup_structure indsp in + let _ = Structure.find indsp in true with Not_found -> false @@ -404,7 +408,7 @@ let pattern_printable_in_both_syntax (ind,_ as c) = let extern_record_pattern cstrsp args = try if !Flags.raw_print then raise Exit; - let projs = Recordops.lookup_projections (fst cstrsp) in + let projs = Structure.find_projections (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then @@ -434,7 +438,7 @@ let extern_record_pattern cstrsp args = (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = try - if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; + if !Flags.in_debugger || !Flags.raw_print || !print_raw_literal then raise No_match; let (na,p,key) = uninterp_prim_token_cases_pattern pat scopes in match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -611,9 +615,12 @@ let is_gvar id c = match DAst.get c with let is_projection nargs r = if not !Flags.in_debugger && not !Flags.raw_print && !print_projections then try - let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then Some n - else None + match r with + | GlobRef.ConstRef c -> + let n = Structure.projection_nparams c + 1 in + if n <= nargs then Some n + else None + | _ -> None with Not_found -> None else None @@ -686,33 +693,29 @@ let extern_record ref args = try if !Flags.raw_print then raise Exit; let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in - let struc = Recordops.lookup_structure (fst cstrsp) in + let struc = Structure.find (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then raise Exit else if not (get_record_print ()) then raise Exit; - let projs = struc.Recordops.s_PROJ in - let locals = struc.Recordops.s_PROJKIND in + let projs = struc.Structure.projections in let rec cut args n = if Int.equal n 0 then args else match args with | [] -> raise No_match | _ :: t -> cut t (n - 1) in - let args = cut args struc.Recordops.s_EXPECTEDPARAM in - let rec ip projs locs args acc = + let args = cut args struc.Structure.nparams in + let rec ip projs args acc = match projs with | [] -> acc - | None :: q -> raise No_match - | Some c :: q -> - match locs with - | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | { Recordops.pk_true_proj = false } :: locs' -> + | { Structure.proj_body = None } :: _ -> raise No_match + | { Structure.proj_body = Some c; proj_true = false } :: q -> (* we don't want to print locals *) - ip q locs' args acc - | { Recordops.pk_true_proj = true } :: locs' -> + ip q args acc + | { Structure.proj_body = Some c; proj_true = true } :: q -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) @@ -720,9 +723,9 @@ let extern_record ref args = let arg = Lazy.force arg in let loc = arg.CAst.loc in let ref = extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c) in - ip q locs' tail ((ref, arg) :: acc) + ip q tail ((ref, arg) :: acc) in - Some (List.rev (ip projs locals args [])) + Some (List.rev (ip projs args [])) with | Not_found | No_match | Exit -> None @@ -853,6 +856,7 @@ let same_binder_type ty nal c = (* one with no delimiter if possible) *) let extern_possible_prim_token (custom,scopes) r = + if !print_raw_literal then raise No_match; let (n,key) = uninterp_prim_token r scopes in match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -1261,11 +1265,12 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = make ?loc (pll,extern inctx scopes vars c) and extern_notations inctx scopes vars nargs t = - if !Flags.raw_print || !print_no_symbol then raise No_match; + if !Flags.raw_print then raise No_match; try extern_possible_prim_token scopes t with No_match -> - let t = flatten_application t in - extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) + if !print_no_symbol then raise No_match; + let t = flatten_application t in + extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) and extern_notation inctx (custom,scopes as allscopes) vars t rules = match rules with diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 298b52f0be..bb49c8697d 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -60,6 +60,7 @@ val print_parentheses : bool ref val print_universes : bool ref val print_no_symbol : bool ref val print_projections : bool ref +val print_raw_literal : bool ref (** Customization of the global_reference printer *) val set_extern_reference : diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7c63ebda3a..958e1408f8 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -24,6 +24,7 @@ open Glob_term open Glob_ops open Patternops open Pretyping +open Structures open Cases open Constrexpr open Constrexpr_ops @@ -34,6 +35,7 @@ open Inductiveops open Context.Rel.Declaration open NumTok + (** constr_expr -> glob_constr translation: - it adds holes for implicit arguments - it replaces notations by their value (scopes stuff are here) @@ -100,7 +102,7 @@ type internalization_error = | NonLinearPattern of Id.t | BadPatternsNumber of int * int | NotAProjection of qualid - | ProjectionsOfDifferentRecords of Recordops.struc_typ * Recordops.struc_typ + | ProjectionsOfDifferentRecords of Structure.t * Structure.t exception InternalizationError of internalization_error @@ -126,8 +128,8 @@ let explain_bad_patterns_number n1 n2 = str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++ str " but found " ++ int n2 -let inductive_of_record record = - let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in +let inductive_of_record s = + let inductive = GlobRef.IndRef (s.Structure.name) in Nametab.shortest_qualid_of_global Id.Set.empty inductive let explain_field_not_a_projection field_id = @@ -1130,8 +1132,10 @@ let intern_reference qid = let intern_projection qid = try - let gr = Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) in - (gr, Recordops.find_projection gr) + match Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) with + | GlobRef.ConstRef c as gr -> + (gr, Structure.find_from_projection c) + | _ -> raise Not_found with Not_found -> Loc.raise ?loc:qid.loc (InternalizationError (NotAProjection qid)) @@ -1296,8 +1300,8 @@ let check_applied_projection isproj realref qid = let is_prim = match realref with | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false | Some (ConstRef c) -> - if Recordops.is_primitive_projection c then true - else if Recordops.is_projection c then false + if PrimitiveProjections.mem c then true + else if Structure.is_projection c then false else error_nonprojection_syntax ?loc:qid.loc qid (* TODO check projargs, note we will need implicit argument info *) in @@ -1498,18 +1502,18 @@ let sort_fields ~complete loc fields completer = | (first_field_ref, _):: _ -> let (first_field_glob_ref, record) = intern_projection first_field_ref in (* the number of parameters *) - let nparams = record.Recordops.s_EXPECTEDPARAM in + let nparams = record.Structure.nparams in (* the reference constructor of the record *) - let base_constructor = GlobRef.ConstructRef record.Recordops.s_CONST in + let base_constructor = GlobRef.ConstructRef (record.Structure.name,1) in let () = check_duplicate ?loc fields in - let build_proj idx proj kind = - if proj = None && complete then + let build_proj idx proj = + if proj.Structure.proj_body = None && complete then (* we don't want anonymous fields *) user_err ?loc (str "This record contains anonymous fields.") else - (idx, proj, kind.Recordops.pk_true_proj) in + (idx, proj.Structure.proj_body, proj.Structure.proj_true) in let proj_list = - List.map2_i build_proj 1 record.Recordops.s_PROJ record.Recordops.s_PROJKIND in + List.map_i build_proj 1 record.Structure.projections in (* now we want to have all fields assignments indexed by their place in the constructor *) let rec index_fields fields remaining_projs acc = @@ -1538,7 +1542,7 @@ let sort_fields ~complete loc fields completer = (* For terms, we keep only regular fields *) None else - Some (idx, completer idx field_ref record.Recordops.s_CONST) in + Some (idx, completer idx field_ref (record.Structure.name,1)) in List.map_filter complete_field remaining_projs in List.rev_append remaining_fields acc in diff --git a/interp/reserve.ml b/interp/reserve.ml index 07160dcf6f..cdc95285fe 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -15,8 +15,6 @@ open Util open Pp open Names open Nameops -open Libobject -open Lib open Notation_term open Notation_ops open Globnames @@ -77,15 +75,11 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NRef (ref,_) -> RefKey(canonical_gr ref), None | _ -> Oth, None -let cache_reserved_type (_,(id,t)) = +let add_reserved_type (id,t) = let key = fst (notation_constr_key t) in reserve_table := Id.Map.add id t !reserve_table; reserve_revtable := keymap_add key (id, t) !reserve_revtable -let in_reserved : Id.t * notation_constr -> obj = - declare_object {(default_object "RESERVED-TYPE") with - cache_function = cache_reserved_type } - let declare_reserved_type_binding {CAst.loc;v=id} t = if not (Id.equal id (root_of_id id)) then user_err ?loc ~hdr:"declare_reserved_type" @@ -96,7 +90,7 @@ let declare_reserved_type_binding {CAst.loc;v=id} t = user_err ?loc ~hdr:"declare_reserved_type" ((Id.print id++str" is already bound to a type")) with Not_found -> () end; - add_anonymous_leaf (in_reserved (id,t)) + add_reserved_type (id,t) let declare_reserved_type idl t = List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 704eb1ef98..27287205f4 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -230,6 +230,12 @@ if (sp - num_args < coq_stack_threshold) { \ *sp = swap_accu_sp_tmp__; \ }while(0) +/* Turn a code pointer into a stack value usable as a return address, and conversely. + The least significant bit is set to 1 so that the GC does not mistake return + addresses for heap pointers. */ +#define StoreRA(p) ((value)(p) + 1) +#define LoadRA(p) ((code_t)((value)(p) - 1)) + #if OCAML_VERSION < 41000 /* For signal handling, we hijack some code from the caml runtime */ @@ -445,7 +451,7 @@ value coq_interprete Instruct(PUSH_RETADDR) { print_instr("PUSH_RETADDR"); sp -= 3; - sp[0] = (value) (pc + *pc); + sp[0] = StoreRA(pc + *pc); sp[1] = coq_env; sp[2] = Val_long(coq_extra_args); coq_extra_args = 0; @@ -466,7 +472,7 @@ value coq_interprete arg1 = sp[0]; sp -= 3; sp[0] = arg1; - sp[1] = (value)pc; + sp[1] = StoreRA(pc); sp[2] = coq_env; sp[3] = Val_long(coq_extra_args); print_instr("call stack="); @@ -489,7 +495,7 @@ value coq_interprete sp -= 3; sp[0] = arg1; sp[1] = arg2; - sp[2] = (value)pc; + sp[2] = StoreRA(pc); sp[3] = coq_env; sp[4] = Val_long(coq_extra_args); pc = Code_val(accu); @@ -511,7 +517,7 @@ value coq_interprete sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; - sp[3] = (value)pc; + sp[3] = StoreRA(pc); sp[4] = coq_env; sp[5] = Val_long(coq_extra_args); pc = Code_val(accu); @@ -531,7 +537,7 @@ value coq_interprete sp[1] = arg2; sp[2] = arg3; sp[3] = arg4; - sp[4] = (value)pc; + sp[4] = StoreRA(pc); sp[5] = coq_env; sp[6] = Val_long(coq_extra_args); pc = Code_val(accu); @@ -647,7 +653,7 @@ value coq_interprete coq_env = accu; } else { print_instr("extra args = 0"); - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -682,7 +688,7 @@ value coq_interprete for (i = 0; i < num_args; i++) Field(accu, i + 3) = sp[i]; Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ sp += num_args; - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -707,7 +713,7 @@ value coq_interprete Field(accu, 2) = coq_env; for (i = 0; i < num_args; i++) Field(accu, i + 3) = sp[i]; sp += num_args; - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -745,7 +751,7 @@ value coq_interprete Code_val(block) = accumulate; Field(block, 1) = Val_int(2); accu = block; - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -1031,7 +1037,7 @@ value coq_interprete mlsize_t i, nargs; sp -= 2; // Push the current instruction as the return address - sp[0] = (value)(pc - 1); + sp[0] = StoreRA(pc - 1); sp[1] = coq_env; coq_env = Field(accu, 0); // Pointer to suspension accu = sp[2]; // Save accumulator to accu register @@ -1142,7 +1148,7 @@ value coq_interprete for (i = size; i < sz; ++i) caml_initialize(&Field(accu, i), *sp++); } - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -1160,7 +1166,7 @@ value coq_interprete sp-=2; pc++; // Push the return address - sp[0] = (value) (pc + *pc); + sp[0] = StoreRA(pc + *pc); sp[1] = coq_env; coq_env = Field(accu,0); // Pointer to suspension accu = sp[2]; // Save accumulator to accu register @@ -1263,7 +1269,7 @@ value coq_interprete } Code_val(accu) = accumulate; Field(accu, 1) = Val_int(2); - pc = (code_t)(sp[0]); + pc = LoadRA(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; @@ -1916,7 +1922,7 @@ value coq_push_ra(value code) { code_t tcode = Code_val(code); print_instr("push_ra"); coq_sp -= 3; - coq_sp[0] = (value) tcode; + coq_sp[0] = StoreRA(tcode); coq_sp[1] = Val_unit; coq_sp[2] = Val_long(0); return Val_unit; diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index a55ff57c8d..f404cb2b1c 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -66,10 +66,6 @@ static void coq_scan_roots(scanning_action action) /* 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_in_heap_or_young(*i)) continue; -#endif (*action) (*i, i); }; /* Hook */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index b14ad5c558..4d2000bb52 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -1,5 +1,5 @@ (library - (name byterun) + (name coqrun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") (public_name coq-core.vm) (foreign_stubs diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 6ef0e9fa15..9e0f574fa3 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -295,38 +295,57 @@ let types = PITT_param 1)) in function - | Int63head0 | Int63tail0 -> [int_ty; int_ty] + | Int63head0 | Int63tail0 -> + [int_ty], int_ty | Int63add | Int63sub | Int63mul | Int63div | Int63mod | Int63divs | Int63mods | Int63lsr | Int63lsl | Int63asr - | Int63land | Int63lor | Int63lxor -> [int_ty; int_ty; int_ty] + | Int63land | Int63lor | Int63lxor -> + [int_ty; int_ty], int_ty | Int63addc | Int63subc | Int63addCarryC | Int63subCarryC -> - [int_ty; int_ty; PITT_ind (PIT_carry, int_ty)] + [int_ty; int_ty], PITT_ind (PIT_carry, int_ty) | Int63mulc | Int63diveucl -> - [int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] - | Int63eq | Int63lt | Int63le | Int63lts | Int63les -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] - | Int63compare | Int63compares -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] + [int_ty; int_ty], PITT_ind (PIT_pair, (int_ty, int_ty)) + | Int63eq | Int63lt | Int63le | Int63lts | Int63les -> + [int_ty; int_ty], PITT_ind (PIT_bool, ()) + | Int63compare | Int63compares -> + [int_ty; int_ty], PITT_ind (PIT_cmp, ()) | Int63div21 -> - [int_ty; int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] - | Int63addMulDiv -> [int_ty; int_ty; int_ty; int_ty] + [int_ty; int_ty; int_ty], PITT_ind (PIT_pair, (int_ty, int_ty)) + | Int63addMulDiv -> + [int_ty; int_ty; int_ty], int_ty | Float64opp | Float64abs | Float64sqrt - | Float64next_up | Float64next_down -> [float_ty; float_ty] - | Float64ofInt63 -> [int_ty; float_ty] - | Float64normfr_mantissa -> [float_ty; int_ty] - | Float64frshiftexp -> [float_ty; PITT_ind (PIT_pair, (float_ty, int_ty))] - | Float64eq | Float64lt | Float64le -> [float_ty; float_ty; PITT_ind (PIT_bool, ())] - | Float64compare -> [float_ty; float_ty; PITT_ind (PIT_f_cmp, ())] - | Float64classify -> [float_ty; PITT_ind (PIT_f_class, ())] - | Float64add | Float64sub | Float64mul - | Float64div -> [float_ty; float_ty; float_ty] - | Float64ldshiftexp -> [float_ty; int_ty; float_ty] - | Arraymake -> [int_ty; PITT_param 1; array_ty] - | Arrayget -> [array_ty; int_ty; PITT_param 1] - | Arraydefault -> [array_ty; PITT_param 1] - | Arrayset -> [array_ty; int_ty; PITT_param 1; array_ty] - | Arraycopy -> [array_ty; array_ty] - | Arraylength -> [array_ty; int_ty] + | Float64next_up | Float64next_down -> + [float_ty], float_ty + | Float64ofInt63 -> + [int_ty], float_ty + | Float64normfr_mantissa -> + [float_ty], int_ty + | Float64frshiftexp -> + [float_ty], PITT_ind (PIT_pair, (float_ty, int_ty)) + | Float64eq | Float64lt | Float64le -> + [float_ty; float_ty], PITT_ind (PIT_bool, ()) + | Float64compare -> + [float_ty; float_ty], PITT_ind (PIT_f_cmp, ()) + | Float64classify -> + [float_ty], PITT_ind (PIT_f_class, ()) + | Float64add | Float64sub | Float64mul | Float64div -> + [float_ty; float_ty], float_ty + | Float64ldshiftexp -> + [float_ty; int_ty], float_ty + | Arraymake -> + [int_ty; PITT_param 1], array_ty + | Arrayget -> + [array_ty; int_ty], PITT_param 1 + | Arraydefault -> + [array_ty], PITT_param 1 + | Arrayset -> + [array_ty; int_ty; PITT_param 1], array_ty + | Arraycopy -> + [array_ty], array_ty + | Arraylength -> + [array_ty], int_ty let one_param = (* currently if there's a parameter it's always this *) @@ -460,14 +479,17 @@ type args_red = arg_kind list (* Invariant only argument of type int63, float or an inductive can have kind Kwhnf *) -let arity t = let sign = types t in nparams t + List.length sign - 1 +let arity t = + nparams t + List.length (fst (types t)) let kind t = let rec params n = if n <= 0 then [] else Kparam :: params (n - 1) in let args = function PITT_type _ | PITT_ind _ -> Kwhnf | PITT_param _ -> Karg in - params (nparams t) @ List.map args (CList.drop_last (types t)) + params (nparams t) @ List.map args (fst (types t)) -let types t = params t, types t +let types t = + let args_ty, ret_ty = types t in + params t, args_ty, ret_ty (** Special Entries for Register **) diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index de90179726..6661851d53 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -140,8 +140,8 @@ val parse_op_or_type : ?loc:Loc.t -> string -> op_or_type val univs : t -> Univ.AUContext.t -val types : t -> Constr.rel_context * ind_or_type list -(** Parameters * Reduction relevant arguments and output type +val types : t -> Constr.rel_context * ind_or_type list * ind_or_type +(** Parameters * Reduction relevant arguments * output type XXX we could reify universes in ind_or_type (currently polymorphic types like array are assumed to use universe 0). *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index f82b754c59..87b1a71c9d 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -252,9 +252,6 @@ let cook_constant { from = cb; info } = cook_context = Some const_hyps; } -(* let cook_constant_key = CProfile.declare_profile "cook_constant" *) -(* let cook_constant = CProfile.profile2 cook_constant_key cook_constant *) - (********************************) (* Discharging mutual inductive *) diff --git a/kernel/dune b/kernel/dune index 0bf51f80ec..af88e9864f 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq-core.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_31 uint63_63 float64_31 float64_63)) - (libraries lib byterun dynlink)) + (libraries lib coqrun dynlink)) (executable (name genOpcodeFiles) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index eb18d4b90e..ddbd5fa0a7 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -717,7 +717,7 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = ienv_decompose_prod ienv' (n-1) b | _ -> assert false -let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) +let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) "" 0)) let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = let anon = Context.make_annot Anonymous Sorts.Relevant in @@ -1334,11 +1334,6 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = else () -(* -let cfkey = CProfile.declare_profile "check_fix";; -let check_fix env fix = CProfile.profile3 cfkey check_fix env fix;; -*) - (************************************************************************) (* Co-fixpoints. *) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index c5ac57a2cd..d2fb773dc4 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -291,6 +291,11 @@ let subst_ind sub (ind,i as indi) = let ind' = subst_mind sub ind in if ind' == ind then indi else ind',i +let subst_constructor subst (ind,j as ref) = + let ind' = subst_ind subst ind in + if ind==ind' then ref + else (ind',j) + let subst_pind sub (ind,u) = (subst_ind sub ind, u) diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 9cf270cff7..e7bfceb4de 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -127,6 +127,9 @@ val subst_mind : val subst_ind : substitution -> inductive -> inductive +val subst_constructor : + substitution -> constructor -> constructor + val subst_pind : substitution -> pinductive -> pinductive val subst_kn : diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index d517d215ed..22bbcb8a65 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -994,9 +994,8 @@ let extract_prim ml_of l = let decl = ref [] in let cond = ref [] in let type_args p = - let rec aux = function [] | [_] -> [] | h :: t -> h :: aux t in - let params, sign = CPrimitives.types p in - List.length params, Array.of_list (aux sign) in + let params, args_ty, _ = CPrimitives.types p in + List.length params, Array.of_list args_ty in let rec aux l = match l with | Lprim(prefix,kn,p,args) -> @@ -2130,7 +2129,7 @@ let compile_deps env sigma prefix init t = in aux env 0 init t -let compile_constant_field env _prefix con acc cb = +let compile_constant_field env con acc cb = let gl = compile_constant env empty_evars con cb in gl@acc diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 90525a19b2..17312ec8ea 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -65,7 +65,7 @@ val register_native_file : string -> unit val is_loaded_native_file : string -> bool -val compile_constant_field : env -> string -> Constant.t -> +val compile_constant_field : env -> Constant.t -> global list -> 'a constant_body -> global list val compile_mind_field : ModPath.t -> Label.t -> diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index f3b483467d..aa30a01134 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -381,10 +381,7 @@ let makeblock env ind tag nparams arity args = Lmakeblock(prefix, ind, tag, args) let makearray args def = - try - let p = Array.map get_value args in - Lval (Nativevalues.parray_of_array p (get_value def)) - with Not_found -> Lparray (args, def) + Lparray (args, def) (* Translation of constants *) diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 2e27fe071e..6dd7f315e0 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -17,21 +17,21 @@ open Nativecode (** This file implements separate compilation for libraries in the native compiler *) -let rec translate_mod prefix mp env mod_expr acc = +let rec translate_mod mp env mod_expr acc = match mod_expr with | NoFunctor struc -> let env' = add_structure mp struc empty_delta_resolver env in - List.fold_left (translate_field prefix mp env') acc struc + List.fold_left (translate_field mp env') acc struc | MoreFunctor _ -> acc -and translate_field prefix mp env acc (l,x) = +and translate_field mp env acc (l,x) = match x with | SFBconst cb -> let con = Constant.make2 mp l in (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Pp.str msg)); - compile_constant_field env prefix con acc cb + compile_constant_field env con acc cb | SFBmind mb -> (debug_native_compiler (fun () -> let id = mb.mind_packets.(0).mind_typename in @@ -45,7 +45,7 @@ and translate_field prefix mp env acc (l,x) = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in Pp.str msg)); - translate_mod prefix mp env md.mod_type acc + translate_mod mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in (debug_native_compiler (fun () -> @@ -53,19 +53,18 @@ and translate_field prefix mp env acc (l,x) = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in Pp.str msg)); - translate_mod prefix mp env mdtyp.mod_type acc + translate_mod mp env mdtyp.mod_type acc -let dump_library mp dp env mod_expr = +let dump_library mp env mod_expr = debug_native_compiler (fun () -> Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in - let prefix = mod_uid_of_dirpath dp ^ "." in let t0 = Sys.time () in clear_global_tbl (); clear_symbols (); let mlcode = - List.fold_left (translate_field prefix mp env) [] struc + List.fold_left (translate_field mp env) [] struc in let t1 = Sys.time () in let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index 8f58dfa8d3..1d0d56703d 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -15,5 +15,5 @@ open Nativecode (** This file implements separate compilation for libraries in the native compiler *) -val dump_library : ModPath.t -> DirPath.t -> env -> module_signature -> +val dump_library : ModPath.t -> env -> module_signature -> global list * Nativevalues.symbols diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 1e39756d47..18c3a3ec9c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -964,7 +964,8 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = compare_instances = infer_convert_instances; compare_cumul_instances = infer_inductive_instances; } -let gen_conv cv_pb l2r reds env evars univs t1 t2 = +let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _ -> None)) t1 t2 = + let univs = Environ.universes env in let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 @@ -974,16 +975,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = let _ = clos_gen_conv reds cv_pb l2r evars env univs (univs, checked_universes) t1 t2 in () -(* Profiling *) -let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None)) = - let univs = Environ.universes env in - if Flags.profile then - let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in - CProfile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs - else gen_conv cv_pb l2r reds env evars univs - let conv = gen_conv CONV - let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = @@ -992,7 +984,7 @@ let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = clos_gen_conv reds cv_pb l2r evars env graph univs t1 t2 in s -let infer_conv_universes cv_pb l2r evars reds env t1 t2 = +let infer_conv_universes cv_pb ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env t1 t2 = let univs = Environ.universes env in let b, cstrs = if cv_pb == CUMUL then Constr.leq_constr_univs_infer univs t1 t2 @@ -1001,37 +993,16 @@ let infer_conv_universes cv_pb l2r evars reds env t1 t2 = if b then cstrs else let state = ((univs, Univ.Constraint.empty), inferred_universes) in - let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs state t1 t2 in + let ((_,cstrs), _) = clos_gen_conv ts cv_pb l2r evars env univs state t1 t2 in cstrs -(* Profiling *) -let infer_conv_universes = - if Flags.profile then - let infer_conv_universes_key = CProfile.declare_profile "infer_conv_universes" in - CProfile.profile7 infer_conv_universes_key infer_conv_universes - else infer_conv_universes - -let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env t1 t2 = - infer_conv_universes CONV l2r evars ts env t1 t2 - -let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env t1 t2 = - infer_conv_universes CUMUL l2r evars ts env t1 t2 +let infer_conv = infer_conv_universes CONV +let infer_conv_leq = infer_conv_universes CUMUL let default_conv cv_pb ?l2r:_ env t1 t2 = gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL -(* -let convleqkey = CProfile.declare_profile "Kernel_reduction.conv_leq";; -let conv_leq env t1 t2 = - CProfile.profile4 convleqkey conv_leq env t1 t2;; - -let convkey = CProfile.declare_profile "Kernel_reduction.conv";; -let conv env t1 t2 = - CProfile.profile4 convleqkey conv env t1 t2;; -*) (* Application with on-the-fly reduction *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index a35f94e3ce..5f83e78eb0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1273,7 +1273,7 @@ let export ?except ~output_native_objects senv dir = in let ast, symbols = if output_native_objects then - Nativelibrary.dump_library mp dir senv.env str + Nativelibrary.dump_library mp senv.env str else [], Nativevalues.empty_symbols in let lib = { diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 1a4c786e43..627bf42570 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -226,6 +226,7 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = check_conv err cst poly (infer_conv_leq ?l2r:None ?evars:None ?ts:None) env t1 t2 in match info1 with + | IndType _ | IndConstr _ -> error DefinitionFieldExpected | Constant cb1 -> let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in let cb1 = Declareops.subst_const_body subst1 cb1 in @@ -254,18 +255,7 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in check_conv NotConvertibleBodyField cst poly (infer_conv ?l2r:None ?evars:None ?ts:None) env c1 c2)) - | IndType ((_kn,_i),_mind1) -> - CErrors.user_err Pp.(str @@ - "The kernel does not recognize yet that a parameter can be " ^ - "instantiated by an inductive type. Hint: you can rename the " ^ - "inductive type and give a definition to map the old name to the new " ^ - "name.") - | IndConstr (((_kn,_i),_j),_mind1) -> - CErrors.user_err Pp.(str @@ - "The kernel does not recognize yet that a parameter can be " ^ - "instantiated by a constructor. Hint: you can rename the " ^ - "constructor and give a definition to map the old name to the new " ^ - "name.") + let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 24aa4ed771..013892ad74 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -269,16 +269,14 @@ let build_constant_declaration env result = in Environ.really_needed env (Id.Set.union ids_typ ids_def), def | Some declared -> - let needed = Environ.really_needed env declared in - (* Transitive closure ensured by the upper layers *) - let () = assert (Id.Set.equal needed declared) in - (* We use the declared set and chain a check of correctness *) - declared, - match def with - | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) - | Def cs as x -> - let () = check_section_variables env declared typ (Mod_subst.force_constr cs) in - x + let declared = Environ.really_needed env declared in + (* We use the declared set and chain a check of correctness *) + declared, + match def with + | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) + | Def cs as x -> + let () = check_section_variables env declared typ (Mod_subst.force_constr cs) in + x in let univs = result.cook_universes in let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 741491c917..3a946fc03a 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -644,12 +644,6 @@ let infer env constr = let constr, t = execute env constr in make_judge constr t -let infer = - if Flags.profile then - let infer_key = CProfile.declare_profile "Fast_infer" in - CProfile.profile2 infer_key (fun b c -> infer b c) - else (fun b c -> infer b c) - let assumption_of_judgment env {uj_val=c; uj_type=t} = infer_assumption env c t @@ -785,15 +779,16 @@ let type_of_prim env u t = | PITT_type (ty,t) -> tr_prim_type (tr_type n) ty t | PITT_param i -> Constr.mkRel (n+i) in - let rec nary_op n = function - | [] -> assert false - | [ret_ty] -> tr_type n ret_ty + let rec nary_op n ret_ty = function + | [] -> tr_type n ret_ty | arg_ty :: r -> - Constr.mkProd(Context.nameR (Id.of_string "x"), tr_type n arg_ty, nary_op (n+1) r) + Constr.mkProd (Context.nameR (Id.of_string "x"), + tr_type n arg_ty, nary_op (n + 1) ret_ty r) in - let params, sign = types t in + let params, args_ty, ret_ty = types t in assert (AUContext.size (univs t) = Instance.length u); - Vars.subst_instance_constr u (Term.it_mkProd_or_LetIn (nary_op 0 sign) params) + Vars.subst_instance_constr u + (Term.it_mkProd_or_LetIn (nary_op 0 ret_ty args_ty) params) let type_of_prim_or_type env u = let open CPrimitives in function diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index b988ec40a7..6db54a3bb6 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -251,28 +251,3 @@ type node = G.node = let repr g = G.repr g.graph let pr_universes prl g = pr_pmap Pp.mt (pr_arc prl) g - -(** Profiling *) - -let merge_constraints = - if Flags.profile then - let key = CProfile.declare_profile "merge_constraints" in - CProfile.profile2 key merge_constraints - else merge_constraints -let check_constraints = - if Flags.profile then - let key = CProfile.declare_profile "check_constraints" in - CProfile.profile2 key check_constraints - else check_constraints - -let check_eq = - if Flags.profile then - let check_eq_key = CProfile.declare_profile "check_eq" in - CProfile.profile3 check_eq_key check_eq - else check_eq - -let check_leq = - if Flags.profile then - let check_leq_key = CProfile.declare_profile "check_leq" in - CProfile.profile3 check_leq_key check_leq - else check_leq diff --git a/kernel/univ.ml b/kernel/univ.ml index a2fd14025e..c2496f10b0 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -38,20 +38,22 @@ struct open Names module UGlobal = struct - type t = DirPath.t * int + type t = DirPath.t * string * int - let make dp i = (DirPath.hcons dp,i) + let make dp s i = (DirPath.hcons dp,s,i) let repr x : t = x - let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' + let equal (d, s, i) (d', s', i') = Int.equal i i' && DirPath.equal d d' && String.equal s s' - let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) + let hash (d,s,i) = Hashset.Combine.combine3 i (String.hash s) (DirPath.hash d) - let compare (d, i) (d', i') = - let c = Int.compare i i' in - if Int.equal c 0 then DirPath.compare d d' - else c + let compare (d, s, i) (d', s', i') = + if i < i' then -1 + else if i' < i then 1 + else let c = DirPath.compare d d' in + if not (Int.equal c 0) then c + else String.compare s s' end type t = @@ -84,10 +86,7 @@ struct | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 - | Level (dp1, i1), Level (dp2, i2) -> - if i1 < i2 then -1 - else if i1 > i2 then 1 - else DirPath.compare dp1 dp2 + | Level l1, Level l2 -> UGlobal.compare l1 l2 | Level _, _ -> -1 | _, Level _ -> 1 | Var n, Var m -> Int.compare n m @@ -98,8 +97,8 @@ struct | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true - | Level (n,d), Level (n',d') -> - n == n' && d == d' + | Level (d,s,n), Level (d',s',n') -> + n == n' && s==s' && d == d' | Var n, Var n' -> n == n' | _ -> false @@ -107,9 +106,10 @@ struct | SProp as x -> x | Prop as x -> x | Set as x -> x - | Level (d,n) as x -> + | Level (d,s,n) as x -> + let s' = CString.hcons s in let d' = Names.DirPath.hcons d in - if d' == d then x else Level (d',n) + if s' == s && d' == d then x else Level (d',s',n) | Var _n as x -> x open Hashset.Combine @@ -119,7 +119,7 @@ struct | Prop -> combinesmall 1 1 | Set -> combinesmall 1 2 | Var n -> combinesmall 2 n - | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) + | Level l -> combinesmall 3 (UGlobal.hash l) end @@ -200,7 +200,10 @@ module Level = struct | SProp -> "SProp" | Prop -> "Prop" | Set -> "Set" - | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n + | Level (d,s,n) -> + Names.DirPath.to_string d ^ + (if CString.is_empty s then "" else "." ^ s) ^ + "." ^ string_of_int n | Var n -> "Var(" ^ string_of_int n ^ ")" let pr u = str (to_string u) @@ -218,7 +221,7 @@ module Level = struct let name u = match data u with - | Level (d, n) -> Some (d, n) + | Level l -> Some l | _ -> None end diff --git a/kernel/univ.mli b/kernel/univ.mli index 7286fc84cb..eeaa1ad62d 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -15,8 +15,8 @@ sig module UGlobal : sig type t - val make : Names.DirPath.t -> int -> t - val repr : t -> Names.DirPath.t * int + val make : Names.DirPath.t -> string -> int -> t + val repr : t -> Names.DirPath.t * string * int val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int diff --git a/kernel/vars.ml b/kernel/vars.ml index b09577d4db..b9991391c2 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -123,11 +123,6 @@ let substn_many lamv n c = | _ -> Constr.map_with_binders succ substrec depth c in substrec n c -(* -let substkey = CProfile.declare_profile "substn_many";; -let substn_many lamv n c = CProfile.profile3 substkey substn_many lamv n c;; -*) - let make_subst = function | [] -> [||] | hd :: tl -> @@ -343,9 +338,6 @@ let univ_instantiate_constr u c = assert (Int.equal (Instance.length u) (AUContext.size c.univ_abstracted_binder)); subst_instance_constr u c.univ_abstracted_value -(* let substkey = CProfile.declare_profile "subst_instance_constr";; *) -(* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) - let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 1432fb9310..d31d7a03b6 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -196,8 +196,9 @@ let vm_conv_gen cv_pb env univs t1 t2 = TransparentState.full env univs t1 t2 else try - let v1 = val_of_constr env t1 in - let v2 = val_of_constr env t2 in + let sigma _ = assert false in + let v1 = val_of_constr env sigma t1 in + let v2 = val_of_constr env sigma t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index c2b087f061..b5604d0593 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -35,6 +35,7 @@ type instruction = | Kpush | Kpop of int | Kpush_retaddr of Label.t + | Kshort_apply of int | Kapply of int | Kappterm of int * int | Kreturn of int @@ -93,6 +94,7 @@ let rec pp_instr i = | Kpush -> str "push" | Kpop n -> str "pop " ++ int n | Kpush_retaddr lbl -> str "push_retaddr " ++ pp_lbl lbl + | Kshort_apply n -> str "short_apply " ++ int n | Kapply n -> str "apply " ++ int n | Kappterm(n, m) -> str "appterm " ++ int n ++ str ", " ++ int m @@ -146,8 +148,8 @@ let rec pp_instr i = (Constant.print (fst id)) | Kcamlprim (op, lbl) -> - str "camlcall " ++ str (CPrimitives.to_string op) ++ spc () ++ - pp_lbl lbl + str "camlcall " ++ str (CPrimitives.to_string op) ++ str ", branch " ++ + pp_lbl lbl ++ str " on accu" and pp_bytecodes c = match c with diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index eeca0d2ad1..d9e2d91177 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -30,6 +30,7 @@ type instruction = | Kpush (** sp = accu :: sp *) | Kpop of int (** sp = skipn n sp *) | Kpush_retaddr of Label.t (** sp = pc :: coq_env :: coq_extra_args :: sp ; coq_extra_args = 0 *) + | Kshort_apply of int (** number of arguments (arguments on top of stack) *) | Kapply of int (** number of arguments (arguments on top of stack) *) | Kappterm of int * int (** number of arguments, slot size *) | Kreturn of int (** slot size *) diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 20de4bc81b..b4d97228bf 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -461,7 +461,7 @@ let comp_app comp_fun comp_arg cenv f args sz cont = | None -> if nargs <= 4 then comp_args comp_arg cenv args sz - (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) + (Kpush :: (comp_fun cenv f (sz+nargs) (Kshort_apply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: @@ -757,26 +757,25 @@ 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 ((kn,u), op, args) when is_caml_prim op -> + | Lprim (kn, op, args) when is_caml_prim op -> let arity = CPrimitives.arity op in let nparams = CPrimitives.nparams op in let nargs = arity - nparams in - assert (arity = Array.length args && arity <= 4); + assert (arity = Array.length args && arity <= 4 && nargs >= 1); let (jump, cont) = make_branch cont in let lbl_default = Label.create () in let default = - let cont = [Kgetglobal kn; Kapply (arity + Univ.Instance.length u); jump] in + let cont = [Kshort_apply arity; jump] in + let cont = Kpush :: compile_get_global cenv kn (sz + arity) cont in let cont = - if Univ.Instance.is_empty u then cont - else comp_args compile_universe cenv (Univ.Instance.to_array u) (sz + arity) (Kpush::cont) - in - Klabel lbl_default :: - Kpush :: - if Int.equal nparams 0 then cont - else comp_args (compile_lam env) cenv (Array.sub args 0 nparams) (sz + nargs) (Kpush::cont) - in + if Int.equal nparams 0 then cont + else + let params = Array.sub args 0 nparams in + Kpush :: comp_args (compile_lam env) cenv params (sz + nargs) cont in + Klabel lbl_default :: cont in fun_code := Ksequence default :: !fun_code; - comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz (Kcamlprim (op, lbl_default) :: cont) + let cont = Kcamlprim (op, lbl_default) :: cont in + comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz cont | Lprim (kn, op, args) -> comp_args (compile_lam env) cenv args sz (Kprim(op, kn)::cont) @@ -840,21 +839,21 @@ let dump_bytecodes init code fvs = prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ fnl ()) -let compile ~fail_on_error ?universes:(universes=0) env c = +let compile ~fail_on_error ?universes:(universes=0) env sigma c = init_fun_code (); Label.reset_label_counter (); let cont = [Kstop] in try let cenv, init_code = if Int.equal universes 0 then - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let cenv = empty_comp_env () in cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. *) - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let params, body = decompose_Llam lam in let arity = Array.length params in let cenv = empty_comp_env () in @@ -896,7 +895,8 @@ let compile_constant_body ~fail_on_error env univs = function let con= Constant.make1 (Constant.canonical kn') in Some (BCalias (get_alias env con)) | _ -> - let res = compile ~fail_on_error ~universes:instance_size env body in + let sigma _ = assert false in + let res = compile ~fail_on_error ~universes:instance_size env sigma body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) diff --git a/kernel/vmbytegen.mli b/kernel/vmbytegen.mli index aef7ac3d6b..c724cad5ec 100644 --- a/kernel/vmbytegen.mli +++ b/kernel/vmbytegen.mli @@ -15,8 +15,10 @@ open Declarations open Environ (** Should only be used for monomorphic terms *) -val compile : fail_on_error:bool -> - ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option +val compile : + fail_on_error:bool -> ?universes:int -> + env -> (existential -> constr option) -> constr -> + (bytecodes * bytecodes * fv) option (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index caa263432e..44e933ef26 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -300,8 +300,11 @@ let emit_instr env = function out env opPOP; out_int env n | Kpush_retaddr lbl -> out env opPUSH_RETADDR; out_label env lbl + | Kshort_apply n -> + assert (1 <= n && n <= 4); + out env(opAPPLY1 + n - 1) | Kapply n -> - if n <= 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) + out env opAPPLY; out_int env n | Kappterm(n, sz) -> if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) else (out env opAPPTERM; out_int env n; out_int env sz) diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 91de58b0e6..ee32384ec9 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -494,10 +494,6 @@ let makeblock tag nparams arity args = else Lmakeblock(tag, args) let makearray args def = - try - let p = Array.map get_value args in - Lval (val_of_parray @@ Parray.unsafe_of_array p (get_value def)) - with Not_found -> let ar = Lmakeblock(0, args) in (* build the ocaml array *) let kind = Lmakeblock(0, [|ar; def|]) in (* Parray.Array *) Lmakeblock(0,[|kind|]) (* the reference *) @@ -591,12 +587,14 @@ struct type t = { global_env : env; + evar_body : existential -> constr option; name_rel : Name.t Vect.t; construct_tbl : (constructor, constructor_info) Hashtbl.t; } - let make env = { + let make env sigma = { global_env = env; + evar_body = sigma; name_rel = Vect.make 16 Anonymous; construct_tbl = Hashtbl.create 111 } @@ -633,9 +631,13 @@ open Renv let rec lambda_of_constr env c = match Constr.kind c with | Meta _ -> raise (Invalid_argument "Vmbytegen.lambda_of_constr: Meta") - | Evar (evk, args) -> - let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in - Levar (evk, args) + | Evar (evk, args as ev) -> + begin match env.evar_body ev with + | None -> + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in + Levar (evk, args) + | Some t -> lambda_of_constr env t + end | Cast (c, _, _) -> lambda_of_constr env c @@ -774,8 +776,8 @@ let optimize_lambda lam = let lam = simplify subst_id lam in remove_let subst_id lam -let lambda_of_constr ~optimize genv c = - let env = Renv.make genv in +let lambda_of_constr ~optimize genv sigma c = + let env = Renv.make genv sigma in let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in diff --git a/kernel/vmlambda.mli b/kernel/vmlambda.mli index ad5f81638f..03d3393219 100644 --- a/kernel/vmlambda.mli +++ b/kernel/vmlambda.mli @@ -33,7 +33,7 @@ and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array exception TooLargeInductive of Pp.t -val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda +val lambda_of_constr : optimize:bool -> env -> (existential -> constr option) -> Constr.t -> lambda val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda diff --git a/kernel/vmsymtable.ml b/kernel/vmsymtable.ml index ae0fa38571..90ee1c5378 100644 --- a/kernel/vmsymtable.ml +++ b/kernel/vmsymtable.ml @@ -144,7 +144,7 @@ let slot_for_proj_name key = ProjNameTable.add proj_name_tbl key n; n -let rec slot_for_getglobal env kn = +let rec slot_for_getglobal env sigma kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> @@ -155,22 +155,22 @@ let rec slot_for_getglobal env kn = | Some code -> match Vmemitcodes.force code with | BCdefined(code,pl,fv) -> - let v = eval_to_patch env (code,pl,fv) in + let v = eval_to_patch env sigma (code,pl,fv) in set_global v - | BCalias kn' -> slot_for_getglobal env kn' + | BCalias kn' -> slot_for_getglobal env sigma kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (CEphemeron.create pos); pos -and slot_for_fv env fv = +and slot_for_fv env sigma fv = let fill_fv_cache cache id v_of_id env_of_id b = let v,d = match b with | None -> v_of_id id, Id.Set.empty | Some c -> - val_of_constr (env_of_id id env) c, + val_of_constr (env_of_id id env) sigma c, Environ.global_vars_set env c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in @@ -194,11 +194,11 @@ and slot_for_fv env fv = | FVuniv_var _idu -> assert false -and eval_to_patch env (buff,pl,fv) = +and eval_to_patch env sigma (buff,pl,fv) = let slots = function | Reloc_annot a -> slot_for_annot a | Reloc_const sc -> slot_for_str_cst sc - | Reloc_getglobal kn -> slot_for_getglobal env kn + | Reloc_getglobal kn -> slot_for_getglobal env sigma kn | Reloc_proj_name p -> slot_for_proj_name p | Reloc_caml_prim op -> slot_for_caml_prim op in @@ -207,13 +207,13 @@ and eval_to_patch env (buff,pl,fv) = (* Environment should look like a closure, so free variables start at slot 2. *) let a = Array.make (Array.length fv + 2) crazy_val in a.(1) <- Obj.magic 2; - Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env v) fv; + Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env sigma v) fv; a in eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env -and val_of_constr env c = - match compile ~fail_on_error:true env c with - | Some v -> eval_to_patch env (to_memory v) +and val_of_constr env sigma c = + match compile ~fail_on_error:true env sigma c with + | Some v -> eval_to_patch env sigma (to_memory v) | None -> assert false let set_transparent_const _kn = () (* !?! *) diff --git a/kernel/vmsymtable.mli b/kernel/vmsymtable.mli index e480bfcec1..c6dc09d944 100644 --- a/kernel/vmsymtable.mli +++ b/kernel/vmsymtable.mli @@ -14,7 +14,7 @@ open Names open Constr open Environ -val val_of_constr : env -> constr -> Vmvalues.values +val val_of_constr : env -> (existential -> constr option) -> constr -> Vmvalues.values val set_opaque_const : Constant.t -> unit val set_transparent_const : Constant.t -> unit diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 9944458d6b..938d1f28f7 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -459,8 +459,6 @@ let val_of_int i = (Obj.magic i : values) let val_of_uint i = (Obj.magic i : structured_values) -let val_of_parray p = (Obj.magic p : structured_values) - let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index d15595766a..534a85d773 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -148,7 +148,6 @@ val val_of_atom : atom -> values val val_of_int : int -> structured_values val val_of_block : tag -> structured_values array -> structured_values val val_of_uint : Uint63.t -> structured_values -val val_of_parray : structured_values Parray.t -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" diff --git a/lib/cProfile.ml b/lib/cProfile.ml index a4f2da7080..7245b35d59 100644 --- a/lib/cProfile.ml +++ b/lib/cProfile.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +let enable_profile = false + let word_length = Sys.word_size / 8 let float_of_time t = float_of_int t /. 100. @@ -87,9 +89,9 @@ let init_alloc = ref 0.0 let reset_profile () = List.iter reset_record !prof_table let init_profile () = - (* We test Flags.profile as a way to support declaring profiled + (* We test enable_profile as a way to support declaring profiled functions in plugins *) - if !prof_table <> [] || Flags.profile then begin + if !prof_table <> [] || enable_profile then begin let outside = create_record () in stack := [outside]; last_alloc := get_alloc (); @@ -285,7 +287,7 @@ let format_profile (table, outside, total) = Printf.printf "%-23s %9s %9s %10s %10s %10s\n" "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; - let l = List.sort (fun (_,{tottime=p}) (_,{tottime=p'}) -> p' - p) table in + let l = List.sort (fun p p' -> (snd p').tottime - (snd p).tottime) table in List.iter (fun (name,e) -> Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n" diff --git a/lib/flags.ml b/lib/flags.ml index 57e879add7..c87a375356 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -51,8 +51,6 @@ let xml_debug = ref false let in_debugger = ref false let in_toplevel = ref false -let profile = false - let raw_print = ref false let we_are_parsing = ref false diff --git a/lib/flags.mli b/lib/flags.mli index e10e2c8cb8..2f59a0cc18 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -44,8 +44,6 @@ val xml_debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref -val profile : bool - (* development flag to detect race conditions, it should go away. *) val we_are_parsing : bool ref diff --git a/lib/future.ml b/lib/future.ml index 23d089fb6b..247b139798 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -112,8 +112,8 @@ let create_delegate ?(blocking=true) ~name fix_exn = if not blocking then (fun () -> raise (NotReady name)), ignore else let lock = Mutex.create () in let cond = Condition.create () in - (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock), - (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in + (fun () -> CThread.with_lock lock ~scope:(fun () -> Condition.wait cond lock)), + (fun () -> CThread.with_lock lock ~scope:(fun () -> Condition.broadcast cond)) in let ck = create ~name ~fix_exn (Delegated wait) in ck, assignment signal ck diff --git a/lib/pp.mli b/lib/pp.mli index b3c2301d34..865f97166f 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -171,7 +171,7 @@ val prvecti_with_sep : val pr_enum : ('a -> t) -> 'a list -> t (** [pr_enum pr [a ; b ; ... ; c]] outputs - [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *) + [pr a ++ str "," ++ spc () ++ pr b ++ str "," ++ spc () ++ ... ++ str "and" ++ spc () ++ pr c]. *) val pr_sequence : ('a -> t) -> 'a list -> t (** Sequence of objects separated by space (unless an element is empty). *) @@ -188,7 +188,6 @@ val pp_with : Format.formatter -> t -> unit val string_of_ppcmds : t -> string - (** Tag prefix to start a multi-token diff span *) val start_pfx : string diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml deleted file mode 100644 index 5e1150146e..0000000000 --- a/lib/remoteCounter.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -type 'a getter = unit -> 'a -type 'a installer = ('a getter) -> unit - -type remote_counters_status = (string * Obj.t) list - -let counters : remote_counters_status ref = ref [] - -let (!!) x = !(!x) - -let new_counter ~name a ~incr ~build = - assert(not (List.mem_assoc name !counters)); - let data = ref (ref a) in - counters := (name, Obj.repr data) :: !counters; - let m = Mutex.create () in - let mk_thsafe_local_getter f () = - (* - slaves must use a remote counter getter, not this one! *) - (* - in the main process there is a race condition between slave - managers (that are threads) and the main thread, hence the mutex *) - if Flags.async_proofs_is_worker () then - CErrors.anomaly(Pp.str"Slave processes must install remote counters."); - Mutex.lock m; let x = f () in Mutex.unlock m; - build x in - let mk_thsafe_remote_getter f () = - Mutex.lock m; let x = f () in Mutex.unlock m; x in - let getter = ref(mk_thsafe_local_getter (fun () -> !data := incr !!data; !!data)) in - let installer f = - if not (Flags.async_proofs_is_worker ()) then - CErrors.anomaly(Pp.str"Only slave processes can install a remote counter."); - getter := mk_thsafe_remote_getter f in - (fun () -> !getter ()), installer - -let backup () = !counters - -let snapshot () = - List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters - -let restore l = - List.iter (fun (name, data) -> - assert(List.mem_assoc name !counters); - let dataref = Obj.obj (List.assoc name !counters) in - !dataref := !!(Obj.obj data)) - l diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli deleted file mode 100644 index 42d1f8a8d1..0000000000 --- a/lib/remoteCounter.mli +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Remote counters are *global* counters for fresh ids. In the master/slave - * scenario, the slave installs a getter that asks the master for a fresh - * value. In the scenario of a slave that runs after the death of the master - * on some marshalled data, a backup of all counters status should be taken and - * restored to avoid reusing ids. - * Counters cannot be created by threads, they must be created once and forall - * as toplevel module declarations. *) - - -type 'a getter = unit -> 'a -type 'a installer = ('a getter) -> unit - -val new_counter : name:string -> - 'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer - -type remote_counters_status -val backup : unit -> remote_counters_status -(* like backup but makes a copy so that further increment does not alter - * the snapshot *) -val snapshot : unit -> remote_counters_status -val restore : remote_counters_status -> unit diff --git a/library/globnames.ml b/library/globnames.ml index 654349dea0..491c89e68e 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -31,10 +31,6 @@ let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" -let subst_constructor subst (ind,j as ref) = - let ind' = subst_ind subst ind in - if ind==ind' then ref - else (ind',j) let subst_global_reference subst ref = match ref with | VarRef var -> ref diff --git a/library/globnames.mli b/library/globnames.mli index 8acea5ef28..58e0efbc7a 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -34,7 +34,6 @@ val destConstructRef : GlobRef.t -> constructor val is_global : GlobRef.t -> constr -> bool [@@ocaml.deprecated "Use [Constr.isRefX] instead."] -val subst_constructor : substitution -> constructor -> constructor val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t diff --git a/library/lib.ml b/library/lib.ml index fa0a95d366..3172511c26 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -280,7 +280,7 @@ let start_mod is_type export id mp fs = else Nametab.exists_dir dir in if exists then - user_err ~hdr:"open_module" (Id.print id ++ str " already exists"); + user_err ~hdr:"open_module" (Id.print id ++ str " already exists."); add_entry (make_foname id) (OpenedModule (is_type,export,prefix,fs)); lib_state := { !lib_state with path_prefix = prefix} ; prefix diff --git a/man/coqdep.1 b/man/coqdep.1 index b0d9606969..5ca558b7c5 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -1,7 +1,7 @@ .TH COQ 1 .SH NAME -coqdep \- Compute inter-module dependencies for Coq and Caml programs +coqdep \- Compute inter-module dependencies for Coq programs .SH SYNOPSIS .B coqdep @@ -23,7 +23,7 @@ coqdep \- Compute inter-module dependencies for Coq and Caml programs .SH DESCRIPTION .B coqdep -compute inter-module dependencies for Coq and Caml programs, +compute inter-module dependencies for Coq programs, and prints the dependencies on the standard output in a format readable by make. When a directory is given as argument, it is recursively looked at. @@ -41,11 +41,6 @@ printed except if .BR \-boot \& is given. -Dependencies of Caml modules are computed by looking at -.IR open \& -directives and the dot notation -.IR module.value \&. - .SH OPTIONS .TP @@ -75,6 +70,21 @@ Output dependencies for .vos files (this is not the default as it breaks dune's .B \-boot For coq developers, prints dependencies over coq library files (omitted by default). +.TP +.B \-noinit +Currently no effect. + + +.SH EXIT STATUS +.IP "1" +A file given on the command line cannot be found or some file +cannot be opened. +.IP "0" +In all other cases. In particular, when a dependency cannot be +found or an invalid option is encountered, +.B coqdep +prints a warning and exits with status +.B 0\fR. .SH SEE ALSO diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0cad192332..30f90dd1fc 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -22,7 +22,6 @@ open Reductionops open Inductive open Termops open Inductiveops -open Recordops open Namegen open Miniml open Table @@ -428,6 +427,7 @@ and extract_really_ind env kn mib = (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in + let ndecls = List.length mib.mind_params_ctxt in let npar = mib.mind_nparams in let epar = push_rel_context mib.mind_params_ctxt env in let sg = Evd.from_env env in @@ -463,17 +463,17 @@ and extract_really_ind env kn mib = if not p.ip_logical then let types = arities_of_constructors env ((kn,i),u) in for j = 0 to Array.length types - 1 do - let t = snd (decompose_prod_n npar types.(j)) in + let t = snd (decompose_prod_n_assum ndecls types.(j)) in let prods,head = dest_prod epar t in let nprods = List.length prods in let args = match Constr.kind head with | App (f,args) -> args (* [Constr.kind f = Ind ip] *) | _ -> [||] in - let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in - let db = db_from_ind dbmap npar in + let dbmap = parse_ind_args p.ip_sign args (nprods + ndecls) in + let db = db_from_ind dbmap ndecls in p.ip_types.(j) <- - extract_type_cons epar sg db dbmap (EConstr.of_constr t) (npar+1) + extract_type_cons epar sg db dbmap (EConstr.of_constr t) (ndecls+1) done done; (* Third pass: we determine special cases. *) @@ -531,7 +531,7 @@ and extract_really_ind env kn mib = let n = nb_default_params env sg (EConstr.of_constr ty) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip in - List.iter (Option.iter check_proj) (lookup_projections ip) + List.iter (Option.iter check_proj) (Structures.Structure.find_projections ip) with Not_found -> () end; Record field_glob @@ -1129,7 +1129,7 @@ let extract_constant env kn cb = (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match Recordops.find_primitive_projection kn with + (match Structures.PrimitiveProjections.find_opt kn with | None -> mk_typ (get_body c) | Some p -> let body = fake_match_projection env p in @@ -1142,7 +1142,7 @@ let extract_constant env kn cb = (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_ax () | Def c -> - (match Recordops.find_primitive_projection kn with + (match Structures.PrimitiveProjections.find_opt kn with | None -> mk_def (get_body c) | Some p -> let body = fake_match_projection env p in diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index da4a50b674..cfdaac710b 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -217,13 +217,13 @@ module Mlenv = struct (* Adding a type with no [Tvar], hence no generalization needed. *) - let push_type {env=e;free=f} t = - { env = (0,t) :: e; free = find_free f t} + let push_type mle t = + { env = (0,t) :: mle.env; free = find_free mle.free t} (* Adding a type with no [Tvar] nor [Tmeta]. *) - let push_std_type {env=e;free=f} t = - { env = (0,t) :: e; free = f} + let push_std_type mle t = + { env = (0,t) :: mle.env; free = mle.free} end diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index c7bda43465..1640bff43b 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -373,11 +373,6 @@ end) = struct end -(* let my_type_of env evars c = Typing.e_type_of env evars c *) -(* let mytypeofkey = CProfile.declare_profile "my_type_of";; *) -(* let my_type_of = CProfile.profile3 mytypeofkey my_type_of *) - - let type_app_poly env env evd f args = let evars, c = app_poly_nocheck env evd f args in let evd', t = Typing.type_of env (goalevars evars) c in @@ -2066,9 +2061,6 @@ let get_hyp gl (c,l) clause l2r = let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } -(* let rewriteclaustac_key = CProfile.declare_profile "cl_rewrite_clause_tac";; *) -(* let cl_rewrite_clause_tac = CProfile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) - (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 5e88bf7c79..f2f5fc16a6 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -91,6 +91,13 @@ let to_int v = Some (out_gen (topwit wit_int) v) else None +let of_ident id = in_gen (topwit wit_ident) id + +let to_ident v = + if has_type v (topwit wit_ident) then + Some (out_gen (topwit wit_ident) v) + else None + let to_list v = prj Val.typ_list v let to_option v = prj Val.typ_opt v diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 8ca2510459..c748fb3d1a 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -39,6 +39,8 @@ sig val to_uconstr : t -> Ltac_pretype.closed_glob_constr option val of_int : int -> t val to_int : t -> int option + val of_ident : Id.t -> t + val to_ident : t -> Id.t option val to_list : t -> t list option val to_option : t -> t option option val to_pair : t -> (t * t) option diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index f2241e78d2..da95869abb 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1180,7 +1180,7 @@ and eval_tactic_ist ist tac : unit Proofview.tactic = match tac with | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) | TacArg {CAst.loc} -> Ftactic.run (val_interp (ensure_loc loc ist) tac) (fun v -> tactic_of_value ist v) - | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) + | TacSelect (sel, tac) -> Goal_select.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in @@ -2148,7 +2148,8 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun poly env sigma ty tac = + let eval ?loc ~poly env sigma tycon tac = + let lfun = GlobEnv.lfun env in let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in let tac = eval_tactic_ist ist tac in @@ -2156,8 +2157,13 @@ let _ = poly seems like enough to get reasonable behavior in practice *) let name = Id.of_string "ltac_gen" in - let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in - (EConstr.of_constr c, sigma) + let sigma, ty = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma ty tac in + let j = { Environ.uj_val = EConstr.of_constr c; uj_type = ty } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 53aa619d10..1018271751 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -449,6 +449,8 @@ let bound_monomials (sys : WithProof.t list) = in List.map snd (List.filter has_mon bounds) @ snd l +let bound_monomials = tr_sys "bound_monomials" bound_monomials + let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth; @@ -1181,10 +1183,12 @@ let nlia enum prfdepth sys = It would only be safe if the variable is linear... *) let sys1 = - elim_simple_linear_equality (WithProof.subst_constant true sys) + normalise + (elim_simple_linear_equality (WithProof.subst_constant true sys)) in + let bnd1 = bound_monomials sys1 in let sys2 = saturate_by_linear_equalities sys1 in - let sys3 = nlinear_preprocess (sys1 @ sys2) in + let sys3 = nlinear_preprocess (rev_concat [bnd1; sys1; sys2]) in let sys4 = make_cstr_system (*sys2@*) sys3 in (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) xlia (List.map fst sys) enum reduction_equations sys4 diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 74b0708743..d18065088c 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -24,17 +24,17 @@ let warn_deprecated_Spec = DECLARE PLUGIN "zify_plugin" VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF -| ["Add" "Zify" "InjTyp" constr(t) ] -> { Zify.InjTable.register t } -| ["Add" "Zify" "BinOp" constr(t) ] -> { Zify.BinOp.register t } -| ["Add" "Zify" "UnOp" constr(t) ] -> { Zify.UnOp.register t } -| ["Add" "Zify" "CstOp" constr(t) ] -> { Zify.CstOp.register t } -| ["Add" "Zify" "BinRel" constr(t) ] -> { Zify.BinRel.register t } -| ["Add" "Zify" "PropOp" constr(t) ] -> { Zify.PropBinOp.register t } -| ["Add" "Zify" "PropBinOp" constr(t) ] -> { Zify.PropBinOp.register t } -| ["Add" "Zify" "PropUOp" constr(t) ] -> { Zify.PropUnOp.register t } -| ["Add" "Zify" "BinOpSpec" constr(t) ] -> { Zify.BinOpSpec.register t } -| ["Add" "Zify" "UnOpSpec" constr(t) ] -> { Zify.UnOpSpec.register t } -| ["Add" "Zify" "Saturate" constr(t) ] -> { Zify.Saturate.register t } +| ["Add" "Zify" "InjTyp" reference(t) ] -> { Zify.InjTable.register t } +| ["Add" "Zify" "BinOp" reference(t) ] -> { Zify.BinOp.register t } +| ["Add" "Zify" "UnOp" reference(t) ] -> { Zify.UnOp.register t } +| ["Add" "Zify" "CstOp" reference(t) ] -> { Zify.CstOp.register t } +| ["Add" "Zify" "BinRel" reference(t) ] -> { Zify.BinRel.register t } +| ["Add" "Zify" "PropOp" reference(t) ] -> { Zify.PropBinOp.register t } +| ["Add" "Zify" "PropBinOp" reference(t) ] -> { Zify.PropBinOp.register t } +| ["Add" "Zify" "PropUOp" reference(t) ] -> { Zify.PropUnOp.register t } +| ["Add" "Zify" "BinOpSpec" reference(t) ] -> { Zify.BinOpSpec.register t } +| ["Add" "Zify" "UnOpSpec" reference(t) ] -> { Zify.UnOpSpec.register t } +| ["Add" "Zify" "Saturate" reference(t) ] -> { Zify.Saturate.register t } END TACTIC EXTEND ITER diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 61966b60c0..b780c1833e 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -23,6 +23,19 @@ let zify str = (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref ("ZifyClasses." ^ str))) +(** classes *) +let coq_InjTyp = lazy (Coqlib.lib_ref "ZifyClasses.InjTyp") + +let coq_BinOp = lazy (Coqlib.lib_ref "ZifyClasses.BinOp") +let coq_UnOp = lazy (Coqlib.lib_ref "ZifyClasses.UnOp") +let coq_CstOp = lazy (Coqlib.lib_ref "ZifyClasses.CstOp") +let coq_BinRel = lazy (Coqlib.lib_ref "ZifyClasses.BinRel") +let coq_PropBinOp = lazy (Coqlib.lib_ref "ZifyClasses.PropBinOp") +let coq_PropUOp = lazy (Coqlib.lib_ref "ZifyClasses.PropUOp") +let coq_BinOpSpec = lazy (Coqlib.lib_ref "ZifyClasses.BinOpSpec") +let coq_UnOpSpec = lazy (Coqlib.lib_ref "ZifyClasses.UnOpSpec") +let coq_Saturate = lazy (Coqlib.lib_ref "ZifyClasses.Saturate") + (* morphism like lemma *) let mkapp2 = lazy (zify "mkapp2") @@ -46,7 +59,7 @@ let op_iff_morph = lazy (zify "iff_morph") let op_not = lazy (zify "not") let op_not_morph = lazy (zify "not_morph") let op_True = lazy (zify "True") -let whd = Reductionops.clos_whd_flags CClosure.all +let op_I = lazy (zify "I") (** [unsafe_to_constr c] returns a [Constr.t] without considering an evar_map. This is useful for calling Constr.hash *) @@ -59,6 +72,7 @@ let gl_pr_constr e = let evd = Evd.from_env genv in pr_constr genv evd e +let whd = Reductionops.clos_whd_flags CClosure.all let is_convertible env evd t1 t2 = Reductionops.(is_conv env evd t1 t2) (** [get_type_of] performs beta reduction ; @@ -66,14 +80,36 @@ let is_convertible env evd t1 t2 = Reductionops.(is_conv env evd t1 t2) let get_type_of env evd e = Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) +(* arguments are dealt with in a second step *) + let rec find_option pred l = match l with | [] -> raise Not_found | e :: l -> ( match pred e with Some r -> r | None -> find_option pred l ) -(** [HConstr] is a map indexed by EConstr.t. - It should only be used using closed terms. - *) +module ConstrMap = struct + open Names.GlobRef + + type 'a t = 'a list Map.t + + let add gr e m = + Map.update gr (function None -> Some [e] | Some l -> Some (e :: l)) m + + let empty = Map.empty + + let find evd h m = + match Map.find (fst (EConstr.destRef evd h)) m with + | e :: _ -> e + | [] -> assert false + + let find_all evd h m = Map.find (fst (EConstr.destRef evd h)) m + + let fold f m acc = + Map.fold + (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) + m acc +end + module HConstr = struct module M = Map.Make (struct type t = EConstr.t @@ -81,20 +117,11 @@ module HConstr = struct let compare c c' = Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') end) - type 'a t = 'a list M.t - - let lfind h m = try M.find h m with Not_found -> [] - - let add h e m = - let l = lfind h m in - M.add h (e :: l) m + type 'a t = 'a M.t + let add h e m = M.add h e m let empty = M.empty - let find h m = match lfind h m with e :: _ -> e | [] -> raise Not_found - let find_all = lfind - - let fold f m acc = - M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc + let find = M.find end (** [get_projections_from_constant (evd,c) ] @@ -331,7 +358,8 @@ module type Elt = sig (** name *) val name : string - val table : (term_kind * decl_kind) HConstr.t ref + val gref : GlobRef.t Lazy.t + val table : (term_kind * decl_kind) ConstrMap.t ref val cast : elt decl -> decl_kind val dest : decl_kind -> elt decl option @@ -346,12 +374,12 @@ module type Elt = sig (* val arity : int*) end -let table = Summary.ref ~name:"zify_table" HConstr.empty -let saturate = Summary.ref ~name:"zify_saturate" HConstr.empty -let specs = Summary.ref ~name:"zify_specs" HConstr.empty -let table_cache = ref HConstr.empty -let saturate_cache = ref HConstr.empty -let specs_cache = ref HConstr.empty +let table = Summary.ref ~name:"zify_table" ConstrMap.empty +let saturate = Summary.ref ~name:"zify_saturate" ConstrMap.empty +let specs = Summary.ref ~name:"zify_specs" ConstrMap.empty +let table_cache = ref ConstrMap.empty +let saturate_cache = ref ConstrMap.empty +let specs_cache = ref ConstrMap.empty (** Each type-class gives rise to a different table. They only differ on how projections are extracted. *) @@ -362,6 +390,7 @@ module EInj = struct type elt = EInjT.t let name = "EInj" + let gref = coq_InjTyp let table = table let cast x = InjTyp x let dest = function InjTyp x -> Some x | _ -> None @@ -419,6 +448,7 @@ module EBinOp = struct open EBinOpT let name = "BinOp" + let gref = coq_BinOp let table = table let mk_elt evd i a = @@ -460,6 +490,7 @@ module ECstOp = struct open ECstOpT let name = "CstOp" + let gref = coq_CstOp let table = table let cast x = CstOp x let dest = function CstOp x -> Some x | _ -> None @@ -486,6 +517,7 @@ module EUnOp = struct open EUnOpT let name = "UnOp" + let gref = coq_UnOp let table = table let cast x = UnOp x let dest = function UnOp x -> Some x | _ -> None @@ -518,6 +550,7 @@ module EBinRel = struct open EBinRelT let name = "BinRel" + let gref = coq_BinRel let table = table let cast x = BinRel x let dest = function BinRel x -> Some x | _ -> None @@ -544,6 +577,7 @@ module EPropBinOp = struct open EPropBinOpT let name = "PropBinOp" + let gref = coq_PropBinOp let table = table let cast x = PropOp x let dest = function PropOp x -> Some x | _ -> None @@ -556,7 +590,8 @@ module EPropUnOp = struct open EPropUnOpT - let name = "PropUnOp" + let name = "PropUOp" + let gref = coq_PropUOp let table = table let cast x = PropUnOp x let dest = function PropUnOp x -> Some x | _ -> None @@ -567,7 +602,7 @@ end let constr_of_term_kind = function Application c -> c | OtherTerm c -> c module type S = sig - val register : Constrexpr.constr_expr -> unit + val register : Libnames.qualid -> unit val print : unit -> unit end @@ -589,14 +624,17 @@ module MakeTable (E : Elt) = struct let register_hint evd t elt = match EConstr.kind evd t with | App (c, _) -> - E.table := HConstr.add c (Application t, E.cast elt) !E.table - | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table + let gr = fst (EConstr.destRef evd c) in + E.table := ConstrMap.add gr (Application t, E.cast elt) !E.table + | _ -> + let gr = fst (EConstr.destRef evd t) in + E.table := ConstrMap.add gr (OtherTerm t, E.cast elt) !E.table let register_constr env evd c = let c = EConstr.of_constr c in let t = get_type_of env evd c in match EConstr.kind evd t with - | App (intyp, args) -> + | App (intyp, args) when EConstr.isRefX evd (Lazy.force E.gref) intyp -> let styp = args.(E.get_key) in let elt = {decl = c; deriv = make_elt (evd, c)} in register_hint evd styp elt @@ -605,10 +643,11 @@ module MakeTable (E : Elt) = struct raise (CErrors.user_err Pp.( - str ": Cannot register term " - ++ pr_constr env evd c ++ str ". It has type " - ++ pr_constr env evd t - ++ str " which should be of the form [F X1 .. Xn]")) + str "Cannot register " ++ pr_constr env evd c + ++ str ". It has type " ++ pr_constr env evd t + ++ str " instead of type " + ++ Printer.pr_global (Lazy.force E.gref) + ++ str " X1 ... Xn")) let register_obj : Constr.constr -> Libobject.obj = let cache_constr (_, c) = @@ -622,22 +661,24 @@ module MakeTable (E : Elt) = struct ("register-zify-" ^ E.name) ~cache:cache_constr ~subst:(Some subst_constr) - (** [register c] is called from the VERNACULAR ADD [name] constr(t). + (** [register c] is called from the VERNACULAR ADD [name] reference(t). The term [c] is interpreted and registered as a [superglobal_object_nodischarge]. TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. *) let register c = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, c = Constrintern.interp_open_constr env evd c in - let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in - () + try + let c = UnivGen.constr_of_monomorphic_global (Nametab.locate c) in + let _ = Lib.add_anonymous_leaf (register_obj c) in + () + with Not_found -> + raise + (CErrors.user_err Pp.(Libnames.pr_qualid c ++ str " does not exist.")) let pp_keys () = let env = Global.env () in let evd = Evd.from_env env in - HConstr.fold + ConstrMap.fold (fun _ (k, d) acc -> match E.dest d with | None -> acc @@ -656,6 +697,7 @@ module ESat = struct open ESatT let name = "Saturate" + let gref = coq_Saturate let table = saturate let cast x = Saturate x let dest = function Saturate x -> Some x | _ -> None @@ -669,6 +711,7 @@ module EUnopSpec = struct type elt = ESpecT.t let name = "UnopSpec" + let gref = coq_UnOpSpec let table = specs let cast x = UnOpSpec x let dest = function UnOpSpec x -> Some x | _ -> None @@ -682,6 +725,7 @@ module EBinOpSpec = struct type elt = ESpecT.t let name = "BinOpSpec" + let gref = coq_BinOpSpec let table = specs let cast x = BinOpSpec x let dest = function BinOpSpec x -> Some x | _ -> None @@ -947,9 +991,11 @@ let app_binop evd src binop arg1 prf1 arg2 prf2 = type typed_constr = {constr : EConstr.t; typ : EConstr.t; inj : EInjT.t} let get_injection env evd t = - match snd (HConstr.find t !table_cache) with - | InjTyp i -> i - | _ -> raise Not_found + try + match snd (ConstrMap.find evd t !table_cache) with + | InjTyp i -> i + | _ -> raise Not_found + with DestKO -> raise Not_found (* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) let arrow = @@ -1087,7 +1133,7 @@ let declared_term env evd hd args = | PropUnOp _ -> decomp t 1 | _ -> None ) in - find_option match_operator (HConstr.find_all hd !table) + find_option match_operator (ConstrMap.find_all evd hd !table) let rec trans_expr env evd e = let inj = e.inj in @@ -1099,7 +1145,7 @@ let rec trans_expr env evd e = let k, t = find_option (match_operator env evd c a) - (HConstr.find_all c !table_cache) + (ConstrMap.find_all evd c !table_cache) in let n = Array.length a in match k with @@ -1243,7 +1289,7 @@ let rec trans_prop env evd e = let k, t = find_option (match_operator env evd c a) - (HConstr.find_all c !table_cache) + (ConstrMap.find_all evd c !table_cache) in let n = Array.length a in match k with @@ -1262,7 +1308,7 @@ let rec trans_prop env evd e = in trans_binrel evd e rop a.(n - 2) a1 a.(n - 1) a2 | _ -> IProof - with Not_found -> IProof ) + with Not_found | DestKO -> IProof ) let trans_check_prop env evd t = if is_prop env evd t then Some (trans_prop env evd t) else None @@ -1359,7 +1405,7 @@ let do_let tac (h : Constr.named_declaration) = find_option (match_operator env evd eq [|EConstr.of_constr ty; EConstr.mkVar x; EConstr.of_constr t|]) - (HConstr.find_all eq !table_cache)); + (ConstrMap.find_all evd eq !table_cache)); tac x (EConstr.of_constr t) (EConstr.of_constr ty) with Not_found -> Tacticals.New.tclIDTAC) @@ -1453,12 +1499,12 @@ let rec spec_of_term env evd (senv : spec_env) t = try (EConstr.mkVar (HConstr.find t' senv'.map), senv') with Not_found -> ( try - match snd (HConstr.find c !specs_cache) with + match snd (ConstrMap.find evd c !specs_cache) with | UnOpSpec s | BinOpSpec s -> let thm = EConstr.mkApp (s.deriv.ESpecT.spec, a') in register_constr senv' t' thm | _ -> (get_name t' senv', senv') - with Not_found -> (t', senv') ) + with Not_found | DestKO -> (t', senv') ) let interp_pscript s = match s with @@ -1493,47 +1539,58 @@ let spec_of_hyps = let iter_specs = spec_of_hyps let find_hyp evd t l = - try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) + try + Some + (EConstr.mkVar + (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l))) with Not_found -> None -let sat_constr c d = - Proofview.Goal.enter (fun gl -> - let evd = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - let hyps = Tacmach.New.pf_hyps_types gl in - match EConstr.kind evd c with - | App (c, args) -> - if Array.length args = 2 then - let h1 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) - in - let h2 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) - in - match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with - | Some h1, Some h2 -> - let n = - Tactics.fresh_id_in_env Id.Set.empty - (Names.Id.of_string "__sat") - env - in - let trm = - EConstr.mkApp - ( d.ESatT.satOK - , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] ) - in - Tactics.pose_proof (Names.Name n) trm - | _, _ -> Tacticals.New.tclIDTAC - else Tacticals.New.tclIDTAC - | _ -> Tacticals.New.tclIDTAC) +let find_proof evd t l = + if EConstr.eq_constr evd t (Lazy.force op_True) then Some (Lazy.force op_I) + else find_hyp evd t l + +(** [sat_constr env evd sub taclist hyps c d]= (sub',taclist',hyps') where + - sub' is a fresh subscript obtained from sub + - taclist' is obtained from taclist by posing the lemma 'd' applied to 'c' + - hyps' is obtained from hyps' + taclist and hyps are threaded to avoid adding duplicates + *) +let sat_constr env evd (sub,taclist, hyps) c d = + match EConstr.kind evd c with + | App (c, args) -> + if Array.length args = 2 then + let h1 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) + in + let h2 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) + in + let n = Nameops.add_subscript (Names.Id.of_string "__sat") sub in + let trm = + match (find_proof evd h1 hyps, find_proof evd h2 hyps) with + | Some h1, Some h2 -> + (EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1); h1; h2|])) + | Some h1, _ -> + EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1); h1|]) + | _, _ -> EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1)|]) + in + let rtrm = Tacred.cbv_beta env evd trm in + let typ = Retyping.get_type_of env evd rtrm in + match find_hyp evd typ hyps with + | None -> (Nameops.Subscript.succ sub, (Tactics.pose_proof (Names.Name n) rtrm :: taclist) , (n,typ)::hyps) + | Some _ -> (sub, taclist, hyps) + else (sub,taclist,hyps) + | _ -> (sub,taclist,hyps) + let get_all_sat env evd c = List.fold_left (fun acc e -> match e with _, Saturate s -> s :: acc | _ -> acc) [] - (HConstr.find_all c !saturate_cache) + ( try ConstrMap.find_all evd c !saturate_cache + with DestKO | Not_found -> [] ) let saturate = Proofview.Goal.enter (fun gl -> @@ -1550,8 +1607,10 @@ let saturate = Array.iter sat args; if Array.length args = 2 then let ds = get_all_sat env evd c in - if ds = [] then () - else List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds + if ds = [] || CstrTable.HConstr.mem table t + then () + else List.iter (fun x -> + CstrTable.HConstr.add table t x.deriv) ds else () | Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous -> sat t1; sat t2 @@ -1560,5 +1619,6 @@ let saturate = (* Collect all the potential saturation lemma *) sat concl; List.iter (fun (_, t) -> sat t) hyps; - Tacticals.New.tclTHENLIST - (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table [])) + let s0 = fresh_subscript env in + let (_,tacs,_) = CstrTable.HConstr.fold (fun c d acc -> sat_constr env evd acc c d) table (s0,[],hyps) in + Tacticals.New.tclTHENLIST tacs) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 555bb4c7fb..68f23393ee 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -7,10 +7,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Constrexpr module type S = sig - val register : constr_expr -> unit + val register : Libnames.qualid -> unit val print : unit -> unit end diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml deleted file mode 100644 index 9d92ffde74..0000000000 --- a/plugins/omega/coq_omega.ml +++ /dev/null @@ -1,1939 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -open CErrors -open Util -open Names -open Constr -open Context -open Nameops -open EConstr -open Tacticals.New -open Tacmach.New -open Tactics -open Libnames -open Nametab -open Contradiction -open Tactypes -open Context.Named.Declaration - -module NamedDecl = Context.Named.Declaration - -module ZOmega = struct - type bigint = Z.t - let equal = Z.equal - let less_than = Z.lt - let add = Z.add - let sub = Z.sub - let mult = Z.mul - let euclid = Z.div_rem - let neg = Z.neg - let zero = Z.zero - let one = Z.one - let to_string = Z.to_string -end - -module OmegaSolver = Omega.MakeOmegaSolver (ZOmega) -open OmegaSolver - -(* Added by JCF, 09/03/98 *) - -let elim_id id = simplest_elim (mkVar id) - -let resolve_id id = apply (mkVar id) - -let display_system_flag = ref false -let display_action_flag = ref false -let old_style_flag = ref false -let letin_flag = ref true - -(* Should we reset all variable labels between two runs of omega ? *) - -let reset_flag = ref true - -(* Coq < 8.5 was not performing such resets, hence omega was slightly - non-deterministic: successive runs of omega on the same problem may - lead to distinct proof-terms. - At the very least, these terms differed on the inner - variable names, but they could even be non-convertible : - the OmegaSolver relies on Hashtbl.iter, it can hence find a different - solution when variable indices differ. *) - -let read f () = !f -let write f x = f:=x - -open Goptions - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"System"]; - optread = read display_system_flag; - optwrite = write display_system_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"Action"]; - optread = read display_action_flag; - optwrite = write display_action_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"OldStyle"]; - optread = read old_style_flag; - optwrite = write old_style_flag } - -let () = - declare_bool_option - { optdepr = true; - optkey = ["Stable";"Omega"]; - optread = read reset_flag; - optwrite = write reset_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"UseLocalDefs"]; - optread = read letin_flag; - optwrite = write letin_flag } - -let intref, reset_all_references = - let refs = ref [] in - (fun n -> let r = ref n in refs := (r,n) :: !refs; r), - (fun () -> List.iter (fun (r,n) -> r:=n) !refs) - -let new_identifier = - let cpt = intref 0 in - (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) - -let new_identifier_var = - let cpt = intref 0 in - (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) - -let new_id = - let cpt = intref 0 in fun () -> incr cpt; !cpt - -let new_var_num = - let cpt = intref 1000 in (fun () -> incr cpt; !cpt) - -let new_var = - let cpt = intref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) - -let display_var i = Printf.sprintf "X%d" i - -let intern_id,unintern_id,reset_intern_tables = - let cpt = ref 0 in - let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : Id.t) -> - try Hashtbl.find table name with Not_found -> - let idx = !cpt in - Hashtbl.add table name idx; - Hashtbl.add co_table idx name; - incr cpt; idx), - (fun idx -> - try Hashtbl.find co_table idx with Not_found -> - let v = new_var () in - Hashtbl.add table v idx; Hashtbl.add co_table idx v; v), - (fun () -> cpt := 0; Hashtbl.clear table) - -let mk_then tacs = tclTHENLIST tacs - -let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) - -let generalize_tac t = generalize t -let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] -let pf_nf gl c = pf_apply Tacred.simpl gl c - -let rev_assoc k = - let rec loop = function - | [] -> raise Not_found - | (v,k')::_ when Int.equal k k' -> v - | _ :: l -> loop l - in - loop - -let tag_hypothesis, hyp_of_tag, clear_tags = - let l = ref ([]:(Id.t * int) list) in - (fun h id -> l := (h,id):: !l), - (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), - (fun () -> l := []) - -let hide_constr,find_constr,clear_constr_tables,dump_tables = - let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in - (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun sigma h -> - try List.assoc_f (eq_constr_nounivs sigma) h !l with Not_found -> failwith "find_contr"), - (fun () -> l := []), - (fun () -> !l) - -let reset_all () = - if !reset_flag then begin - reset_all_references (); - reset_intern_tables (); - clear_tags (); - clear_constr_tables () - end - -(* Lazy evaluation is used for Coq constants, because this code - is evaluated before the compiled modules are loaded. - To use the constant Zplus, one must type "Lazy.force coq_Zplus" - This is the right way to access to Coq constants in tactics ML code *) - -let gen_constant k = lazy (k |> Coqlib.lib_ref |> UnivGen.constr_of_monomorphic_global - |> EConstr.of_constr) - - -(* Zarith *) -let coq_xH = gen_constant "num.pos.xH" -let coq_xO = gen_constant "num.pos.xO" -let coq_xI = gen_constant "num.pos.xI" -let coq_Z0 = gen_constant "num.Z.Z0" -let coq_Zpos = gen_constant "num.Z.Zpos" -let coq_Zneg = gen_constant "num.Z.Zneg" -let coq_Z = gen_constant "num.Z.type" -let coq_comparison = gen_constant "core.comparison.type" -let coq_Gt = gen_constant "core.comparison.Gt" -let coq_Zplus = gen_constant "num.Z.add" -let coq_Zmult = gen_constant "num.Z.mul" -let coq_Zopp = gen_constant "num.Z.opp" -let coq_Zminus = gen_constant "num.Z.sub" -let coq_Zsucc = gen_constant "num.Z.succ" -let coq_Zpred = gen_constant "num.Z.pred" -let coq_Z_of_nat = gen_constant "num.Z.of_nat" -let coq_inj_plus = gen_constant "num.Nat2Z.inj_add" -let coq_inj_mult = gen_constant "num.Nat2Z.inj_mul" -let coq_inj_minus1 = gen_constant "num.Nat2Z.inj_sub" -let coq_inj_minus2 = gen_constant "plugins.omega.inj_minus2" -let coq_inj_S = gen_constant "num.Nat2Z.inj_succ" -let coq_inj_eq = gen_constant "plugins.omega.inj_eq" -let coq_inj_neq = gen_constant "plugins.omega.inj_neq" -let coq_inj_le = gen_constant "plugins.omega.inj_le" -let coq_inj_lt = gen_constant "plugins.omega.inj_lt" -let coq_inj_ge = gen_constant "plugins.omega.inj_ge" -let coq_inj_gt = gen_constant "plugins.omega.inj_gt" -let coq_fast_Zplus_assoc_reverse = gen_constant "plugins.omega.fast_Zplus_assoc_reverse" -let coq_fast_Zplus_assoc = gen_constant "plugins.omega.fast_Zplus_assoc" -let coq_fast_Zmult_assoc_reverse = gen_constant "plugins.omega.fast_Zmult_assoc_reverse" -let coq_fast_Zplus_permute = gen_constant "plugins.omega.fast_Zplus_permute" -let coq_fast_Zplus_comm = gen_constant "plugins.omega.fast_Zplus_comm" -let coq_fast_Zmult_comm = gen_constant "plugins.omega.fast_Zmult_comm" -let coq_Zmult_le_approx = gen_constant "plugins.omega.Zmult_le_approx" -let coq_OMEGA1 = gen_constant "plugins.omega.OMEGA1" -let coq_OMEGA2 = gen_constant "plugins.omega.OMEGA2" -let coq_OMEGA3 = gen_constant "plugins.omega.OMEGA3" -let coq_OMEGA4 = gen_constant "plugins.omega.OMEGA4" -let coq_OMEGA5 = gen_constant "plugins.omega.OMEGA5" -let coq_OMEGA6 = gen_constant "plugins.omega.OMEGA6" -let coq_OMEGA7 = gen_constant "plugins.omega.OMEGA7" -let coq_OMEGA8 = gen_constant "plugins.omega.OMEGA8" -let coq_OMEGA9 = gen_constant "plugins.omega.OMEGA9" -let coq_fast_OMEGA10 = gen_constant "plugins.omega.fast_OMEGA10" -let coq_fast_OMEGA11 = gen_constant "plugins.omega.fast_OMEGA11" -let coq_fast_OMEGA12 = gen_constant "plugins.omega.fast_OMEGA12" -let coq_fast_OMEGA13 = gen_constant "plugins.omega.fast_OMEGA13" -let coq_fast_OMEGA14 = gen_constant "plugins.omega.fast_OMEGA14" -let coq_fast_OMEGA15 = gen_constant "plugins.omega.fast_OMEGA15" -let coq_fast_OMEGA16 = gen_constant "plugins.omega.fast_OMEGA16" -let coq_OMEGA17 = gen_constant "plugins.omega.OMEGA17" -let coq_OMEGA18 = gen_constant "plugins.omega.OMEGA18" -let coq_OMEGA19 = gen_constant "plugins.omega.OMEGA19" -let coq_OMEGA20 = gen_constant "plugins.omega.OMEGA20" -let coq_fast_Zred_factor0 = gen_constant "plugins.omega.fast_Zred_factor0" -let coq_fast_Zred_factor1 = gen_constant "plugins.omega.fast_Zred_factor1" -let coq_fast_Zred_factor2 = gen_constant "plugins.omega.fast_Zred_factor2" -let coq_fast_Zred_factor3 = gen_constant "plugins.omega.fast_Zred_factor3" -let coq_fast_Zred_factor4 = gen_constant "plugins.omega.fast_Zred_factor4" -let coq_fast_Zred_factor5 = gen_constant "plugins.omega.fast_Zred_factor5" -let coq_fast_Zred_factor6 = gen_constant "plugins.omega.fast_Zred_factor6" -let coq_fast_Zmult_plus_distr_l = gen_constant "plugins.omega.fast_Zmult_plus_distr_l" -let coq_fast_Zopp_plus_distr = gen_constant "plugins.omega.fast_Zopp_plus_distr" -let coq_fast_Zopp_mult_distr_r = gen_constant "plugins.omega.fast_Zopp_mult_distr_r" -let coq_fast_Zopp_eq_mult_neg_1 = gen_constant "plugins.omega.fast_Zopp_eq_mult_neg_1" -let coq_Zegal_left = gen_constant "plugins.omega.Zegal_left" -let coq_Zne_left = gen_constant "plugins.omega.Zne_left" -let coq_Zlt_left = gen_constant "plugins.omega.Zlt_left" -let coq_Zge_left = gen_constant "plugins.omega.Zge_left" -let coq_Zgt_left = gen_constant "plugins.omega.Zgt_left" -let coq_Zle_left = gen_constant "plugins.omega.Zle_left" -let coq_new_var = gen_constant "plugins.omega.new_var" -let coq_intro_Z = gen_constant "plugins.omega.intro_Z" - -let coq_dec_eq = gen_constant "num.Z.eq_decidable" -let coq_dec_Zne = gen_constant "plugins.omega.dec_Zne" -let coq_dec_Zle = gen_constant "num.Z.le_decidable" -let coq_dec_Zlt = gen_constant "num.Z.lt_decidable" -let coq_dec_Zgt = gen_constant "plugins.omega.dec_Zgt" -let coq_dec_Zge = gen_constant "plugins.omega.dec_Zge" - -let coq_not_Zeq = gen_constant "plugins.omega.not_Zeq" -let coq_not_Zne = gen_constant "plugins.omega.not_Zne" -let coq_Znot_le_gt = gen_constant "plugins.omega.Znot_le_gt" -let coq_Znot_lt_ge = gen_constant "plugins.omega.Znot_lt_ge" -let coq_Znot_ge_lt = gen_constant "plugins.omega.Znot_ge_lt" -let coq_Znot_gt_le = gen_constant "plugins.omega.Znot_gt_le" -let coq_neq = gen_constant "plugins.omega.neq" -let coq_Zne = gen_constant "plugins.omega.Zne" -let coq_Zle = gen_constant "num.Z.le" -let coq_Zlt = gen_constant "num.Z.lt" -let coq_Zge = gen_constant "num.Z.ge" -let coq_Zgt = gen_constant "num.Z.gt" - -(* Peano/Datatypes *) -let coq_nat = gen_constant "num.nat.type" -let coq_O = gen_constant "num.nat.O" -let coq_S = gen_constant "num.nat.S" -let coq_le = gen_constant "num.nat.le" -let coq_lt = gen_constant "num.nat.lt" -let coq_ge = gen_constant "num.nat.ge" -let coq_gt = gen_constant "num.nat.gt" -let coq_plus = gen_constant "num.nat.add" -let coq_minus = gen_constant "num.nat.sub" -let coq_mult = gen_constant "num.nat.mul" -let coq_pred = gen_constant "num.nat.pred" - -(* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = gen_constant "num.nat.pred_of_minus" -let coq_le_gt_dec = gen_constant "num.nat.le_gt_dec" -let coq_dec_eq_nat = gen_constant "num.nat.eq_dec" -let coq_dec_le = gen_constant "num.nat.dec_le" -let coq_dec_lt = gen_constant "num.nat.dec_lt" -let coq_dec_ge = gen_constant "num.nat.dec_ge" -let coq_dec_gt = gen_constant "num.nat.dec_gt" -let coq_not_eq = gen_constant "num.nat.not_eq" -let coq_not_le = gen_constant "num.nat.not_le" -let coq_not_lt = gen_constant "num.nat.not_lt" -let coq_not_ge = gen_constant "num.nat.not_ge" -let coq_not_gt = gen_constant "num.nat.not_gt" - -(* Logic/Decidable *) -let coq_eq_ind_r = gen_constant "core.eq.ind_r" - -let coq_dec_or = gen_constant "core.dec.or" -let coq_dec_and = gen_constant "core.dec.and" -let coq_dec_imp = gen_constant "core.dec.imp" -let coq_dec_iff = gen_constant "core.dec.iff" -let coq_dec_not = gen_constant "core.dec.not" -let coq_dec_False = gen_constant "core.dec.False" -let coq_dec_not_not = gen_constant "core.dec.not_not" -let coq_dec_True = gen_constant "core.dec.True" - -let coq_not_or = gen_constant "core.dec.not_or" -let coq_not_and = gen_constant "core.dec.not_and" -let coq_not_imp = gen_constant "core.dec.not_imp" -let coq_not_iff = gen_constant "core.dec.not_iff" -let coq_not_not = gen_constant "core.dec.dec_not_not" -let coq_imp_simp = gen_constant "core.dec.imp_simp" -let coq_iff = gen_constant "core.iff.type" -let coq_not = gen_constant "core.not.type" -let coq_and = gen_constant "core.and.type" -let coq_or = gen_constant "core.or.type" -let coq_eq = gen_constant "core.eq.type" -let coq_ex = gen_constant "core.ex.type" -let coq_False = gen_constant "core.False.type" -let coq_True = gen_constant "core.True.type" - -(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) - -(* For unfold *) -let evaluable_ref_of_constr s c = - let env = Global.env () in - let evd = Evd.from_env env in - let open Tacred in - match EConstr.kind evd (Lazy.force c) with - | Const (kn,u) when is_evaluable env (EvalConstRef kn) -> - EvalConstRef kn - | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) - -let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) -let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) -let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) -let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) -let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) -let sp_not = lazy (evaluable_ref_of_constr "not" coq_not) - -let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) -let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) -let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_gen_eq ty t1 t2 = mkApp (Lazy.force coq_eq, [| ty; t1; t2 |]) -let mk_eq t1 t2 = mk_gen_eq (Lazy.force coq_Z) t1 t2 -let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) -let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) -let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) -let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) -let mk_not t = mkApp (Lazy.force coq_not, [| t |]) -let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) - -let mk_integer n = - let rec loop n = - if n =? one then Lazy.force coq_xH else - mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/two) |]) - in - if n =? zero then Lazy.force coq_Z0 - else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), - [| loop (abs n) |]) - -type omega_constant = - | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred - | Plus | Mult | Minus | Pred | S | O - | Zpos | Zneg | Z0 | Z_of_nat - | Eq | Neq - | Zne | Zle | Zlt | Zge | Zgt - | Z | Nat - | And | Or | False | True | Not | Iff - | Le | Lt | Ge | Gt - | Other of string - -type result = - | Kvar of Id.t - | Kapp of omega_constant * constr list - | Kimp of constr * constr - | Kufo - -(* Nota: Kimp correspond to a binder (Prod), but hopefully we won't - have to bother with term lifting: Kimp will correspond to anonymous - product, for which (Rel 1) doesn't occur in the right term. - Moreover, we'll work on fully introduced goals, hence no Rel's in - the term parts that we manipulate, but rather Var's. - Said otherwise: all constr manipulated here are closed *) - -let destructurate_prop sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let c, args = decompose_app sigma t in - match EConstr.kind sigma c, args with - | _, [_;_;_] when eq_constr (Lazy.force coq_eq) c -> Kapp (Eq,args) - | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_and) -> Kapp (And,args) - | _, [_;_] when eq_constr c (Lazy.force coq_or) -> Kapp (Or,args) - | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) - | _, [_] when eq_constr c (Lazy.force coq_not) -> Kapp (Not,args) - | _, [] when eq_constr c (Lazy.force coq_False) -> Kapp (False,args) - | _, [] when eq_constr c (Lazy.force coq_True) -> Kapp (True,args) - | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) - | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) - | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) - | Const (sp,_), args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.ConstRef sp))),args) - | Construct (csp,_) , args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.ConstructRef csp))), args) - | Ind (isp,_), args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.IndRef isp))),args) - | Var id,[] -> Kvar id - | Prod ({binder_name=Anonymous},typ,body), [] -> Kimp(typ,body) - | Prod ({binder_name=Name _},_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") - | _ -> Kufo - -let nf = Tacred.simpl - -let destructurate_type env sigma t = - let is_conv = Reductionops.is_conv env sigma in - let c, args = decompose_app sigma (nf env sigma t) in - match EConstr.kind sigma c, args with - | _, [] when is_conv c (Lazy.force coq_Z) -> Kapp (Z,args) - | _, [] when is_conv c (Lazy.force coq_nat) -> Kapp (Nat,args) - | _ -> Kufo - -let destructurate_term sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let c, args = decompose_app sigma t in - match EConstr.kind sigma c, args with - | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) - | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args) - | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args) - | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args) - | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args) - | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args) - | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args) - | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args) - | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args) - | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args) - | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args) - | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args) - | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args) - | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args) - | Var id,[] -> Kvar id - | _ -> Kufo - -let recognize_number sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let rec loop t = - match decompose_app sigma t with - | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t - | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t - | f, [] when eq_constr f (Lazy.force coq_xH) -> one - | _ -> failwith "not a number" - in - match decompose_app sigma t with - | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t - | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) - | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero - | _ -> failwith "not a number" - -type constr_path = - | P_APP of int - (* Abstraction and product *) - | P_TYPE - -let context sigma operation path (t : constr) = - let rec loop i p0 t = - match (p0,EConstr.kind sigma t) with - | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) - | ([], _) -> operation i t - | ((P_APP n :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') - | (p, Fix ((_,n as ln),(tys,lna,v))) -> - let l = Array.length v in - let v' = Array.copy v in - v'.(n)<- loop (Util.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) - | ((P_TYPE :: p), Prod (n,t,c)) -> - (mkProd (n,loop i p t,c)) - | ((P_TYPE :: p), Lambda (n,t,c)) -> - (mkLambda (n,loop i p t,c)) - | ((P_TYPE :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,loop i p t,c)) - | (p, _) -> - failwith ("abstract_path " ^ string_of_int(List.length p)) - in - loop 1 path t - -let occurrence sigma path (t : constr) = - let rec loop p0 t = match (p0,EConstr.kind sigma t) with - | (p, Cast (c,_,_)) -> loop p c - | ([], _) -> t - | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) - | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) - | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term - | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term - | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term - | (p, _) -> - failwith ("occurrence " ^ string_of_int(List.length p)) - in - loop path t - -let abstract_path sigma typ path t = - let term_occur = ref (mkRel 0) in - let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (make_annot (Name (Id.of_string "x")) Sorts.Relevant, typ, abstract), !term_occur - -let focused_simpl path = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl ~check:false newc DEFAULTcast - end - -let focused_simpl path = focused_simpl path - -type oformula = - | Oplus of oformula * oformula - | Otimes of oformula * oformula - | Oatom of Id.t - | Oz of bigint - | Oufo of constr - -let rec oprint = function - | Oplus(t1,t2) -> - print_string "("; oprint t1; print_string "+"; - oprint t2; print_string ")" - | Otimes (t1,t2) -> - print_string "("; oprint t1; print_string "*"; - oprint t2; print_string ")" - | Oatom s -> print_string (Id.to_string s) - | Oz i -> print_string (string_of_bigint i) - | Oufo f -> print_string "?" - -let rec weight = function - | Oatom c -> intern_id c - | Oz _ -> -1 - | Otimes(c,_) -> weight c - | Oplus _ -> failwith "weight" - | Oufo _ -> -1 - -let rec val_of = function - | Oatom c -> mkVar c - | Oz c -> mk_integer c - | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) - | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) - | Oufo c -> c - -let compile name kind = - let rec loop accu = function - | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r - | Oz n -> - let id = new_id () in - tag_hypothesis name id; - {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly (Pp.str "compile_equation.") - in - loop [] - -let decompile af = - let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) - | [] -> Oz af.constant - in - loop af.body - -(** Backward compat to emulate the old Refine: normalize the goal conclusion *) -let new_hole env sigma c = - let c = Reductionops.nf_betaiota env sigma c in - Evarutil.new_evar env sigma c - -let clever_rewrite_base_poly typ p result theorem = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let full = pf_concl gl in - let env = pf_env gl in - let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in - Refine.refine ~typecheck:false begin fun sigma -> - let t = - applist - (mkLambda - (make_annot (Name (Id.of_string "P")) Sorts.Relevant, - mkArrow typ Sorts.Relevant mkProp, - mkLambda - (make_annot (Name (Id.of_string "H")) Sorts.Relevant, - applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, - [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), - [abstracted]) - in - let argt = mkApp (abstracted, [|result|]) in - let (sigma, hole) = new_hole env sigma argt in - (sigma, applist (t, [hole])) - end - end - -let clever_rewrite_base p result theorem = - clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem - -let clever_rewrite_base_nat p result theorem = - clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem - -let clever_rewrite_gen p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base p result theorem - -let clever_rewrite_gen_nat p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base_nat p result theorem - -(** Solve using the term the term [t _] *) -let refine_app gl t = - let open Tacmach.New in - Refine.refine ~typecheck:false begin fun sigma -> - let env = pf_env gl in - let ht = match EConstr.kind sigma (pf_get_type_of gl t) with - | Prod (_, t, _) -> t - | _ -> assert false - in - let (sigma, hole) = new_hole env sigma ht in - (sigma, applist (t, [hole])) - end - -let clever_rewrite p vpath t = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let full = pf_concl gl in - let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in - let t' = applist(t, (vargs @ [abstracted])) in - refine_app gl t' - end - -(** simpl_coeffs : - The subterm at location [path_init] in the current goal should - look like [(v1*c1 + (v2*c2 + ... (vn*cn + k)))], and we reduce - via "simpl" each [ci] and the final constant [k]. - The path [path_k] gives the location of constant [k]. - Earlier, the whole was a mere call to [focused_simpl], - leading to reduction inside the atoms [vi], which is bad, - for instance when the atom is an evaluable definition - (see #4132). *) - -let simpl_coeffs path_init path_k = - Proofview.Goal.enter begin fun gl -> - let sigma = project gl in - let rec loop n t = - if Int.equal n 0 then pf_nf gl t - else - (* t should be of the form ((v * c) + ...) *) - match EConstr.kind sigma t with - | App(f,[|t1;t2|]) -> - (match EConstr.kind sigma t1 with - | App (g,[|v;c|]) -> - let c' = pf_nf gl c in - let t2' = loop (pred n) t2 in - mkApp (f,[|mkApp (g,[|v;c'|]);t2'|]) - | _ -> assert false) - | _ -> assert false - in - let n = Util.(-) (List.length path_k) (List.length path_init) in - let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) - in - convert_concl ~check:false newc DEFAULTcast - end - -let rec shuffle p (t1,t2) = - match t1,t2 with - | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - (clever_rewrite p [[P_APP 1;P_APP 1]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1,t')) - else - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t')) - | Oplus(l1,r1), t2 -> - if weight l1 > weight t2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1, t') - else - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight l2 > weight t1 then - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t') - else [],Oplus(t1,t2) - | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Z.add t1 t2) - | t1,t2 -> - if weight t1 < weight t2 then - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - else [],Oplus(t1,t2) - -let shuffle_mult p_init k1 e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA10) - in - if Z.add (Z.mul k1 c1) (Z.mul k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [simpl_coeffs p_init p] - in - loop p_init (e1,e2) - -let shuffle_mult_right p_init e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - let tac = - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA15) - in - if Z.add c1 (Z.mul k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) - in - tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [simpl_coeffs p_init p] - in - loop p_init (e1,e2) - -let rec shuffle_cancel p = function - | [] -> [focused_simpl p] - | ({c=c1}::l1) -> - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] - (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) - in - tac :: shuffle_cancel p l1 - -let rec scalar p n = function - | Oplus(t1,t2) -> - let tac1,t1' = scalar (P_APP 1 :: p) n t1 and - tac2,t2' = scalar (P_APP 2 :: p) n t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_plus_distr_l) :: - (tac1 @ tac2), Oplus(t1',t2') - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_assoc_reverse); - focused_simpl (P_APP 2 :: p)], - Otimes(t1,Oz (n*x)) - | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") - | (Oatom _ as t) -> [], Otimes(t,Oz n) - | Oz i -> [focused_simpl p],Oz(n*i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) - -let scalar_norm p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | (_::l) -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l - in - loop p_init - -let norm_add p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | _:: l -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l - in - loop p_init - -let scalar_norm_add p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | _ :: l -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l - in - loop p_init - -let rec negate p = function - | Oplus(t1,t2) -> - let tac1,t1' = negate (P_APP 1 :: p) t1 and - tac2,t2' = negate (P_APP 2 :: p) t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_plus_distr) :: - (tac1 @ tac2), - Oplus(t1',t2') - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_mult_distr_r); - focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) - | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") - | (Oatom _ as t) -> - let r = Otimes(t,Oz(negone)) in - [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r - | Oz i -> [focused_simpl p],Oz(neg i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) - -let rec transform sigma p t = - let default isnat t' = - try - let v,th,_ = find_constr sigma t' in - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with e when CErrors.noncritical e -> - let v = new_identifier_var () - and th = new_identifier () in - hide_constr t' v th isnat; - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - in - try match destructurate_term sigma t with - | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform sigma (P_APP 1 :: p) t1 - and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in - let tac,t' = shuffle p (t1',t2') in - tac1 @ tac2 @ tac, t' - | Kapp(Zminus,[t1;t2]) -> - let tac,t = - transform sigma p - (mkApp (Lazy.force coq_Zplus, - [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t - | Kapp(Zsucc,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t - | Kapp(Zpred,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer negone |])) in - unfold sp_Zpred :: tac,t - | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform sigma (P_APP 1 :: p) t1 - and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in - begin match t1',t2' with - | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' - | (Oz n,_) -> - let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_comm) in - let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' - | _ -> default false t - end - | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number sigma t)) - with e when CErrors.noncritical e -> default false t) - | Kvar s -> [],Oatom s - | Kapp(Zopp,[t]) -> - let tac,t' = transform sigma (P_APP 1 :: p) t in - let tac',t'' = negate p t' in - tac @ tac', t'' - | Kapp(Z_of_nat,[t']) -> default true t' - | _ -> default false t - with e when noncritical e -> default false t - -let shrink_pair p f1 f2 = - match f1,f2 with - | Oatom v,Oatom _ -> - let r = Otimes(Oatom v,Oz two) in - clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r - | Oatom v, Otimes(_,c2) -> - let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor2), r - | Otimes (v1,c1),Oatom v -> - let r = Otimes(Oatom v,Oplus(c1,Oz one)) in - clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zred_factor3), r - | Otimes (Oatom v,c1),Otimes (v2,c2) -> - let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p - [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor4),r - | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); - flush stdout; CErrors.user_err Pp.(str "shrink.1") - end - -let reduce_factor p = function - | Oatom v -> - let r = Otimes(Oatom v,Oz one) in - [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r - | Otimes(Oatom v,Oz n) as f -> [],f - | Otimes(Oatom v,c) -> - let rec compute = function - | Oz n -> n - | Oplus(t1,t2) -> Z.add (compute t1) (compute t2) - | _ -> CErrors.user_err Pp.(str "condense.1") - in - [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) - | t -> oprint t; CErrors.user_err Pp.(str "reduce_factor.1") - -let rec condense p = function - | Oplus(f1,(Oplus(f2,r) as t)) -> - if Int.equal (weight f1) (weight f2) then begin - let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = - clever_rewrite p - [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc) in - let tac_list,t' = condense p (Oplus(t,r)) in - (assoc_tac :: shrink_tac :: tac_list), t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') - end - | Oplus(f1,Oz n) -> - let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) - | Oplus(f1,f2) -> - if Int.equal (weight f1) (weight f2) then begin - let tac_shrink,t = shrink_pair p f1 f2 in - let tac,t' = condense p t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') - end - | Oz _ as t -> [],t - | t -> - let tac,t' = reduce_factor p t in - let final = Oplus(t',Oz zero) in - let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in - tac @ [tac'], final - -let rec clear_zero p = function - | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> - let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - let tac',t = clear_zero p r in - tac :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) - | t -> [],t - -open Proofview -open Proofview.Notations - -let replay_history tactic_normalisation = - let aux = Id.of_string "auxiliary" in - let aux1 = Id.of_string "auxiliary_1" in - let aux2 = Id.of_string "auxiliary_2" in - let izero = mk_integer zero in - let rec loop t : unit Proofview.tactic = - match t with - | HYP e :: l -> - begin - try - tclTHEN - (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) - (loop l) - with Not_found -> loop l end - | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let k = if b then negone else one in - let p_initial = [P_APP 1;P_TYPE] in - let tac= shuffle_mult_right p_initial e1.body k e2.body in - tclTHENLIST [ - generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| - val_of eq1; - val_of eq2; - mk_integer k; - mkVar id1; mkVar id2 |])]; - mk_then tac; - intro_using_then aux (fun aux -> - resolve_id aux); - reflexivity - ] - | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac = shuffle_cancel p_initial e1.body in - let solve_le = - let not_sup_sup = mkApp (Lazy.force coq_eq, - [| - Lazy.force coq_comparison; - Lazy.force coq_Gt; - Lazy.force coq_Gt |]) - in - tclTHENS - (tclTHENLIST [ - unfold sp_Zle; - simpl_in_concl; - intro; - (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] - in - let theorem = - mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; - mkVar (hyp_of_tag e1.id); - mkVar (hyp_of_tag e2.id) |]) - in - Proofview.tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) solve_le - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let rhs = mk_plus (mk_times eq2 kk) dd in - let state_eg = mk_eq eq1 rhs in - let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) - [ tclTHENS - (intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intro_mustbe_force id); - (cut (mk_gt kk dd)) ])) - [ tclTHENS - (cut (mk_gt kk izero)) - [ intro_using_then aux1 (fun aux1 -> - intro_using_then aux2 (fun aux2 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Zmult_le_approx, - [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); - (clear [aux1;aux2;id]); - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] - ]; - tclTHEN (mk_then tac) reflexivity ] - - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let c = floor_div e1.constant k in - let d = Z.sub e1.constant (Z.mul c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; - body = map_eq_linear (fun c -> c / k) e1.body } in - let eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, - [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - unfold sp_not; - intro_using_then aux (fun aux -> - tclTHENLIST [ - resolve_id aux; - mk_then tac; - assumption - ])])) ; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] - | EXACT_DIVIDE (e1,k) :: l -> - let id = hyp_of_tag e1.id in - let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k in - let state_eq = mk_eq eq1 (mk_times eq2 kk) in - if e1.kind == DISE then - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS - (cut state_eq) - [ intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, - [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intro_mustbe_force id); - (loop l) ]); - tclTHEN (mk_then tac) reflexivity ] - else - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) - [ - tclTHENS - (cut (mk_gt kk izero)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, - [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); - (clear [aux1;aux2;id]); - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] - | (MERGE_EQ(e3,e1,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) - and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] - (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - scalar_norm [P_APP 3] e1.body - in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) - [ intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intro_mustbe_force id); - (loop l) ]); - tclTHEN (mk_then tac) reflexivity] - - | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () - and id2 = hyp_of_tag orig.id in - tag_hypothesis id e.id; - let eq1 = val_of(decompile def) - and eq2 = val_of(decompile orig) in - let vid = unintern_id v in - let theorem = - mkApp (Lazy.force coq_ex, [| - Lazy.force coq_Z; - mkLambda - (make_annot (Name vid) Sorts.Relevant, - Lazy.force coq_Z, - mk_eq (mkRel 1) eq1) |]) - in - let mm = mk_integer m in - let p_initial = [P_APP 2;P_TYPE] in - let tac = - clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) - [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - shuffle_mult_right p_initial - orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) - [ tclTHENLIST [ intro_using_then aux (fun aux -> - (elim_id aux) <*> - (clear [aux])); - intro_using_then vid (fun vid -> - intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, - [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - mk_then tac; - (clear [aux]); - (intro_mustbe_force id); - (loop l) ]))]; - tclTHEN (exists_tac eq1) reflexivity ] - | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () - and id2 = new_identifier () in - tag_hypothesis id1 e1; tag_hypothesis id2 e2; - let id = hyp_of_tag e.id in - let tac1 = norm_add [P_APP 2;P_TYPE] e.body in - let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in - let eq = val_of(decompile e) in - tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ mk_then tac1; (intro_mustbe_force id1); (loop act1) ]; - tclTHENLIST [ mk_then tac2; (intro_mustbe_force id2); (loop act2) ]] - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - if k1 =? one && e2.kind == EQUA then - let tac_thm = - match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 - in - let kk = mk_integer k2 in - let p_initial = - if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in - let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - tclTHENLIST [ - (generalize_tac - [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - mk_then tac; - (intro_mustbe_force id); - (loop l) - ] - else - let kk1 = mk_integer k1 - and kk2 = mk_integer k2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - mk_then tac; - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] - | CONSTANT_NOT_NUL(e,k) :: l -> - tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl - | CONSTANT_NUL(e) :: l -> - tclTHEN (resolve_id (hyp_of_tag e)) reflexivity - | CONSTANT_NEG(e,k) :: l -> - tclTHENLIST [ - (generalize_tac [mkVar (hyp_of_tag e)]); - unfold sp_Zle; - simpl_in_concl; - unfold sp_not; - intro_using_then aux (fun aux -> - resolve_id aux <*> reflexivity) - ] - | _ -> Proofview.tclUNIT () - in - loop - -let normalize sigma p_initial t = - let (tac,t') = transform sigma p_initial t in - let (tac',t'') = condense p_initial t' in - let (tac'',t''') = clear_zero p_initial t'' in - tac @ tac' @ tac'' , t''' - -let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = - let p_initial = [P_APP pos ;P_TYPE] in - let (tac,t') = normalize sigma p_initial t in - let shift_left = - tclTHEN - (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) - (tclTRY (clear [id])) - in - if not (List.is_empty tac) then - let id' = new_identifier () in - ((id',(tclTHENLIST [ shift_left; mk_then tac; (intro_mustbe_force id') ])) - :: tactic, - compile id' flag t' :: defs) - else - (tactic,defs) - -let destructure_omega env sigma tac_def (id,c) = - if String.equal (atompart_of_id id) "State" then - tac_def - else - try match destructurate_prop sigma c with - | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type env sigma typ with Kapp(Z,[]) -> true | _ -> false end -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def - | Kapp(Zne,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def - | Kapp(Zle,[t1;t2]) -> - let t = mk_plus t2 (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def - | Kapp(Zlt,[t1;t2]) -> - let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def - | Kapp(Zge,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def - | Kapp(Zgt,[t1;t2]) -> - let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def - | _ -> tac_def - with e when noncritical e -> tac_def - -let reintroduce id = - (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using_then id (fun _ -> tclUNIT())) - -let coq_omega = - Proofview.Goal.enter begin fun gl -> - clear_constr_tables (); - let hyps_types = Tacmach.New.pf_hyps_types gl in - let destructure_omega = Tacmach.New.pf_apply destructure_omega gl in - let tactic_normalisation, system = - List.fold_left destructure_omega ([],[]) hyps_types in - let prelude,sys = - List.fold_left - (fun (tac,sys) (t,(v,th,b)) -> - if b then - let id = new_identifier () in - let i = new_id () in - tag_hypothesis id i; - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_mustbe_force [v; id]); - (elim_id id); - (clear [id]); - (intros_mustbe_force [th;id]); - tac ]), - {kind = INEQ; - body = [{v=intern_id v; c=one}]; - constant = zero; id = i} :: sys - else - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_mustbe_force [v;th]); - tac ]), - sys) - (Proofview.tclUNIT (),[]) (dump_tables ()) - in - let system = system @ sys in - if !display_system_flag then display_system display_var system; - if !old_style_flag then begin - try - let _ = simplify (new_id,new_var_num,display_var) false system in - Proofview.tclUNIT () - with UNSOLVABLE -> - let _,path = depend [] [] (history ()) in - if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) - end else begin - try - let path = simplify_strong (new_id,new_var_num,display_var) system in - if !display_action_flag then display_action display_var path; - tclTHEN prelude (replay_history tactic_normalisation path) - with NO_CONTRADICTION as e -> - let _, info = Exninfo.capture e in - tclZEROMSG ~info (Pp.str"Omega can't solve this system") - end - end - -let coq_omega = coq_omega - -let nat_inject = - Proofview.Goal.enter begin fun gl -> - let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in - let rec explore p t : unit Proofview.tactic = - Proofview.tclEVARMAP >>= fun sigma -> - try match destructurate_term sigma t with - | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_plus),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Mult,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_mult),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Minus,[t1;t2]) -> - let id = new_identifier () in - tclTHENS - (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intro_mustbe_force id)) - [ - tclTHENLIST [ - (clever_rewrite_gen p - (mk_minus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); - (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) ]; - (tclTHEN - (clever_rewrite_gen p (mk_integer zero) - ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) - (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) - ] - | Kapp(S,[t']) -> - let rec is_number t = - try match destructurate_term sigma t with - Kapp(S,[t]) -> is_number t - | Kapp(O,[]) -> true - | _ -> false - with e when noncritical e -> false - in - let rec loop p t : unit Proofview.tactic = - try match destructurate_term sigma t with - Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p - (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) - (loop (P_APP 1 :: p) t)) - | _ -> explore p t - with e when noncritical e -> explore p t - in - if is_number t' then focused_simpl p else loop p t - | Kapp(Pred,[t]) -> - let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; - mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in - tclTHEN - (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one - ((Lazy.force coq_pred_of_minus),[t])) - (explore p t_minus_one) - | Kapp(O,[]) -> focused_simpl p - | _ -> Proofview.tclUNIT () - with e when noncritical e -> Proofview.tclUNIT () - - and loop = function - | [] -> Proofview.tclUNIT () - | (i,t)::lit -> - Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma t with - Kapp(Le,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Lt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Ge,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Gt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Neq,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Eq,[typ;t1;t2]) -> - if is_conv typ (Lazy.force coq_nat) then - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 2; P_TYPE] t1); - (explore [P_APP 3; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - else loop lit - | _ -> loop lit - with e when noncritical e -> loop lit end - in - let hyps_types = Tacmach.New.pf_hyps_types gl in - loop (List.rev hyps_types) - end - -let dec_binop = function - | Zne -> coq_dec_Zne - | Zle -> coq_dec_Zle - | Zlt -> coq_dec_Zlt - | Zge -> coq_dec_Zge - | Zgt -> coq_dec_Zgt - | Le -> coq_dec_le - | Lt -> coq_dec_lt - | Ge -> coq_dec_ge - | Gt -> coq_dec_gt - | _ -> raise Not_found - -let not_binop = function - | Zne -> coq_not_Zne - | Zle -> coq_Znot_le_gt - | Zlt -> coq_Znot_lt_ge - | Zge -> coq_Znot_ge_lt - | Zgt -> coq_Znot_gt_le - | Le -> coq_not_le - | Lt -> coq_not_lt - | Ge -> coq_not_ge - | Gt -> coq_not_gt - | _ -> raise Not_found - -(** A decidability check : for some [t], could we build a term - of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise - [Undecidable]. Note that a successful check implies that - [t] has type Prop. -*) - -exception Undecidable - -let rec decidability env sigma t = - match destructurate_prop sigma t with - | Kapp(Or,[t1;t2]) -> - mkApp (Lazy.force coq_dec_or, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(And,[t1;t2]) -> - mkApp (Lazy.force coq_dec_and, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(Iff,[t1;t2]) -> - mkApp (Lazy.force coq_dec_iff, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kimp(t1,t2) -> - (* This is the only situation where it's not obvious that [t] - is in Prop. The recursive call on [t2] will ensure that. *) - mkApp (Lazy.force coq_dec_imp, - [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(Not,[t1]) -> - mkApp (Lazy.force coq_dec_not, [| t1; decidability env sigma t1 |]) - | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type env sigma typ with - | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) - | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> raise Undecidable - end - | Kapp(op,[t1;t2]) -> - (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) - with Not_found -> raise Undecidable) - | Kapp(False,[]) -> Lazy.force coq_dec_False - | Kapp(True,[]) -> Lazy.force coq_dec_True - | _ -> raise Undecidable - -let fresh_id avoid id gl = - fresh_id_in_env avoid id (Proofview.Goal.env gl) - -let onClearedName id tac = - (* We cannot ensure that hyps can be cleared (because of dependencies), *) - (* so renaming may be necessary *) - tclTHEN - (tclTRY (clear [id])) - (Proofview.Goal.enter begin fun gl -> - let id = fresh_id Id.Set.empty id gl in - tclTHEN (introduction id) (tac id) - end) - -let onClearedName2 id tac = - tclTHEN - (tclTRY (clear [id])) - (Proofview.Goal.enter begin fun gl -> - let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in - let id2 = fresh_id (Id.Set.singleton id1) (add_suffix id "_right") gl in - tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] - end) - -let destructure_hyps = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let decidability = decidability env sigma in - let rec loop = function - | [] -> (tclTHEN nat_inject coq_omega) - | LocalDef (i,body,typ) :: lit when !letin_flag -> - Proofview.tclEVARMAP >>= fun sigma -> - begin - try - match destructurate_type env sigma typ with - | Kapp(Nat,_) | Kapp(Z,_) -> - let hid = fresh_id Id.Set.empty (add_suffix i.binder_name "_eqn") gl in - let hty = mk_gen_eq typ (mkVar i.binder_name) body in - tclTHEN - (assert_by (Name hid) hty reflexivity) - (loop (LocalAssum (make_annot hid Sorts.Relevant, hty) :: lit)) - | _ -> loop lit - with e when noncritical e -> loop lit - end - | decl :: lit -> (* variable without body (or !letin_flag isn't set) *) - let i = NamedDecl.get_id decl in - Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma (NamedDecl.get_type decl) with - | Kapp(False,[]) -> elim_id i - | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit - | Kapp(Or,[t1;t2]) -> - (tclTHENS - (elim_id i) - [ onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t1)::lit))); - onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t2)::lit))) ]) - | Kapp(And,[t1;t2]) -> - tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (make_annot i1 Sorts.Relevant,t1) :: - LocalAssum (make_annot i2 Sorts.Relevant,t2) :: lit))) - | Kapp(Iff,[t1;t2]) -> - tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (make_annot i1 Sorts.Relevant,mkArrow t1 Sorts.Relevant t2) :: - LocalAssum (make_annot i2 Sorts.Relevant,mkArrow t2 Sorts.Relevant t1) :: lit))) - | Kimp(t1,t2) -> - (* t1 and t2 might be in Type rather than Prop. - For t1, the decidability check will ensure being Prop. *) - if Termops.is_Prop sigma (Retyping.get_type_of env sigma t2) - then - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; d1; mkVar i|])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) t2) :: lit)))) - ] - else - loop lit - | Kapp(Not,[t]) -> - begin match destructurate_prop sigma t with - Kapp(Or,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and (mk_not t1) (mk_not t2)) :: lit)))) - ] - | Kapp(And,[t1;t2]) -> - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_and, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) (mk_not t2)) :: lit)))) - ] - | Kapp(Iff,[t1;t2]) -> - let d1 = decidability t1 in - let d2 = decidability t2 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_iff, - [| t1; t2; d1; d2; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2)) :: lit)))) - ] - | Kimp(t1,t2) -> - (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. - For t1, being decidable implies being Prop. *) - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and t1 (mk_not t2)) :: lit)))) - ] - | Kapp(Not,[t]) -> - let d = decidability t in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t) :: lit)))) - ] - | Kapp(op,[t1;t2]) -> - (try - let thm = not_binop op in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - with Not_found -> loop lit) - | Kapp(Eq,[typ;t1;t2]) -> - if !old_style_flag then begin - match destructurate_type env sigma typ with - | Kapp(Nat,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Z,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | _ -> loop lit - end else begin - match destructurate_type env sigma typ with - | Kapp(Nat,_) -> - (tclTHEN - (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) - decl)) - (loop lit)) - | Kapp(Z,_) -> - (tclTHEN - (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) - decl)) - (loop lit)) - | _ -> loop lit - end - | _ -> loop lit - end - | _ -> loop lit - with - | Undecidable -> loop lit - | e when noncritical e -> loop lit - end - in - let hyps = Proofview.Goal.hyps gl in - loop hyps - end - -let destructure_goal = - Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let decidability = decidability env sigma in - let rec loop t = - Proofview.tclEVARMAP >>= fun sigma -> - let prop () = Proofview.tclUNIT (destructurate_prop sigma t) in - Proofview.V82.wrap_exceptions prop >>= fun prop -> - match prop with - | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) - destructure_hyps) - | Kimp(a,b) -> (tclTHEN intro (loop b)) - | Kapp(False,[]) -> destructure_hyps - | _ -> - let goal_tac = - try - let dec = decidability t in - tclTHEN - (Proofview.Goal.enter begin fun gl -> - refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) - end) - intro - with Undecidable -> Tactics.elim_type (Lazy.force coq_False) - | e when Proofview.V82.catchable_exception e -> - let e, info = Exninfo.capture e in - Proofview.tclZERO ~info e - in - tclTHEN goal_tac destructure_hyps - in - (loop concl) - end - -let destructure_goal = destructure_goal - -let warn_omega_is_deprecated = - let name = "omega-is-deprecated" in - let category = "deprecated" in - CWarnings.create ~name ~category (fun () -> - Pp.str "omega is deprecated since 8.12; use “lia” instead.") - -let omega_solver = - Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) - warn_omega_is_deprecated (); - Coqlib.check_required_library ["Coq";"omega";"Omega"]; - reset_all (); - destructure_goal diff --git a/plugins/omega/coq_omega.mli b/plugins/omega/coq_omega.mli deleted file mode 100644 index e723082803..0000000000 --- a/plugins/omega/coq_omega.mli +++ /dev/null @@ -1,11 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -val omega_solver : unit Proofview.tactic diff --git a/plugins/omega/dune b/plugins/omega/dune index a3c9342322..e69de29bb2 100644 --- a/plugins/omega/dune +++ b/plugins/omega/dune @@ -1,7 +0,0 @@ -(library - (name omega_plugin) - (public_name coq-core.plugins.omega) - (synopsis "Coq's omega plugin") - (libraries coq-core.plugins.ltac)) - -(coq.pp (modules g_omega)) diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg deleted file mode 100644 index 888a62b2bc..0000000000 --- a/plugins/omega/g_omega.mlg +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - - -DECLARE PLUGIN "omega_plugin" - -{ - -open Ltac_plugin - -} - -TACTIC EXTEND omega -| [ "omega" ] -> { Coq_omega.omega_solver } -END diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml deleted file mode 100644 index 24cd342e42..0000000000 --- a/plugins/omega/omega.ml +++ /dev/null @@ -1,708 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(* 13/10/2002 : modified to cope with an external numbering of equations *) -(* and hypothesis. Its use for Omega is not more complex and it makes *) -(* things much simpler for the reflexive version where we should limit *) -(* the number of source of numbering. *) -(**************************************************************************) - -module type INT = sig - type bigint - val equal : bigint -> bigint -> bool - val less_than : bigint -> bigint -> bool - val add : bigint -> bigint -> bigint - val sub : bigint -> bigint -> bigint - val mult : bigint -> bigint -> bigint - val euclid : bigint -> bigint -> bigint * bigint - val neg : bigint -> bigint - val zero : bigint - val one : bigint - val to_string : bigint -> string -end - -let debug = ref false - -module MakeOmegaSolver (I:INT) = struct - -type bigint = I.bigint -let (=?) = I.equal -let (<?) = I.less_than -let (<=?) x y = I.less_than x y || x = y -let (>?) x y = I.less_than y x -let (>=?) x y = I.less_than y x || x = y -let (+) = I.add -let (-) = I.sub -let ( * ) = I.mult -let (/) x y = fst (I.euclid x y) -let (mod) x y = snd (I.euclid x y) -let zero = I.zero -let one = I.one -let two = one + one -let negone = I.neg one -let abs x = if I.less_than x zero then I.neg x else x -let string_of_bigint = I.to_string -let neg = I.neg - -(* To ensure that polymorphic (<) is not used mistakenly on big integers *) -(* Warning: do not use (=) either on big int *) -let (<) = ((<) : int -> int -> bool) -let (>) = ((>) : int -> int -> bool) -let (<=) = ((<=) : int -> int -> bool) -let (>=) = ((>=) : int -> int -> bool) - -let pp i = print_int i; print_newline (); flush stdout - -let push v l = l := v :: !l - -let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) - -let pgcd_l = function - | [] -> failwith "pgcd_l" - | x :: l -> List.fold_left pgcd x l - -let floor_div a b = - match a >=? zero , b >? zero with - | true,true -> a / b - | false,false -> a / b - | true, false -> (a-one) / b - one - | false,true -> (a+one) / b - one - -type coeff = {c: bigint ; v: int} - -type linear = coeff list - -type eqn_kind = EQUA | INEQ | DISE - -type afine = { - (* a number uniquely identifying the equation *) - id: int ; - (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) - kind: eqn_kind; - (* the variables and their coefficient *) - body: coeff list; - (* a constant *) - constant: bigint } - -type state_action = { - st_new_eq : afine; - st_def : afine; (* /!\ this represents [st_def = st_var] *) - st_orig : afine; - st_coef : bigint; - st_var : int } - -type action = - | DIVIDE_AND_APPROX of afine * afine * bigint * bigint - | NOT_EXACT_DIVIDE of afine * bigint - | FORGET_C of int - | EXACT_DIVIDE of afine * bigint - | SUM of int * (bigint * afine) * (bigint * afine) - | STATE of state_action - | HYP of afine - | FORGET of int * int - | FORGET_I of int * int - | CONTRADICTION of afine * afine - | NEGATE_CONTRADICT of afine * afine * bool - | MERGE_EQ of int * afine * int - | CONSTANT_NOT_NUL of int * bigint - | CONSTANT_NUL of int - | CONSTANT_NEG of int * bigint - | SPLIT_INEQ of afine * (int * action list) * (int * action list) - | WEAKEN of int * bigint - -exception UNSOLVABLE - -exception NO_CONTRADICTION - -let display_eq print_var (l,e) = - let _ = - List.fold_left - (fun not_first f -> - print_string - (if f.c <? zero then "- " else if not_first then "+ " else ""); - let c = abs f.c in - if c =? one then - Printf.printf "%s " (print_var f.v) - else - Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); - true) - false l - in - if e >? zero then - Printf.printf "+ %s " (string_of_bigint e) - else if e <? zero then - Printf.printf "- %s " (string_of_bigint (abs e)) - -let rec trace_length l = - let action_length accu = function - | SPLIT_INEQ (_,(_,l1),(_,l2)) -> - accu + one + trace_length l1 + trace_length l2 - | _ -> accu + one in - List.fold_left action_length zero l - -let operator_of_eq = function - | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" - -let kind_of = function - | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" - -let display_system print_var l = - List.iter - (fun { kind=b; body=e; constant=c; id=id} -> - Printf.printf "E%d: " id; - display_eq print_var (e,c); - Printf.printf "%s 0\n" (operator_of_eq b)) - l; - print_string "------------------------\n\n" - -let display_inequations print_var l = - List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; - print_string "------------------------\n\n" - -let sbi = string_of_bigint - -let rec display_action print_var = function - | act :: l -> begin match act with - | DIVIDE_AND_APPROX (e1,e2,k,d) -> - Printf.printf - "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by subtracting %s.\n" e1.id (sbi k) (sbi d) - | NOT_EXACT_DIVIDE (e,k) -> - Printf.printf - "Constant in equation E%d is not divisible by the pgcd \ - %s of its other coefficients.\n" e.id (sbi k) - | EXACT_DIVIDE (e,k) -> - Printf.printf - "Equation E%d is divided by the pgcd \ - %s of its coefficients.\n" e.id (sbi k) - | WEAKEN (e,k) -> - Printf.printf - "To ensure a solution in the dark shadow \ - the equation E%d is weakened by %s.\n" e (sbi k) - | SUM (e,(c1,e1),(c2,e2)) -> - Printf.printf - "We state %s E%d = %s %s E%d + %s %s E%d.\n" - (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) - (kind_of e2.kind) e2.id - | STATE { st_new_eq = e } -> - Printf.printf "We define a new equation E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0" - | HYP e -> - Printf.printf "We define E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0\n" - | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e - | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | MERGE_EQ (e,e1,e2) -> - Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e - | CONTRADICTION (e1,e2) -> - Printf.printf - "Equations E%d and E%d imply a contradiction on their \ - constant factors.\n" e1.id e2.id - | NEGATE_CONTRADICT(e1,e2,b) -> - Printf.printf - "Equations E%d and E%d state that their body is at the same time \ - equal and different\n" e1.id e2.id - | CONSTANT_NOT_NUL (e,k) -> - Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) - | CONSTANT_NEG(e,k) -> - Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) - | CONSTANT_NUL e -> - Printf.printf "Inequation E%d states 0 != 0.\n" e - | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> - Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; - display_action print_var l1; - print_newline (); - display_action print_var l2; - print_newline () - end; display_action print_var l - | [] -> - flush stdout - -let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) - -(*""*) -let add_event, history, clear_history = - let accu = ref [] in - (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), - (fun () -> !accu), - (fun () -> accu := []) - -let nf_linear = List.sort (fun x y -> Util.(-) y.v x.v) - -let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) - -let map_eq_linear f = - let rec loop = function - | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l - | [] -> [] - in - loop - -let map_eq_afine f e = - { id = e.id; kind = e.kind; body = map_eq_linear f e.body; - constant = f e.constant } - -let negate_eq = map_eq_afine (fun x -> neg x) - -let rec sum p0 p1 = match (p0,p1) with - | ([], l) -> l | (l, []) -> l - | (((x1::l1) as l1'), ((x2::l2) as l2')) -> - if x1.v = x2.v then - let c = x1.c + x2.c in - if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 - else if x1.v > x2.v then - x1 :: sum l1 l2' - else - x2 :: sum l1' l2 - -let sum_afine new_eq_id eq1 eq2 = - { kind = eq1.kind; id = new_eq_id (); - body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } - -exception FACTOR1 - -let rec chop_factor_1 = function - | x :: l -> - if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') - | [] -> raise FACTOR1 - -exception CHOPVAR - -let rec chop_var v = function - | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') - | [] -> raise CHOPVAR - -let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = - if e = [] then begin - match eq_flag with - | EQUA -> - if x =? zero then [] else begin - add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE - end - | DISE -> - if x <> zero then [] else begin - add_event (CONSTANT_NUL id); raise UNSOLVABLE - end - | INEQ -> - if x >=? zero then [] else begin - add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE - end - end else - let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in - if eq_flag=EQUA && x mod gcd <> zero then begin - add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE - end else if eq_flag=DISE && x mod gcd <> zero then begin - add_event (FORGET_C eq.id); [] - end else if gcd <> one then begin - let c = floor_div x gcd in - let d = x - c * gcd in - let new_eq = {id=id; kind=eq_flag; constant=c; - body=map_eq_linear (fun c -> c / gcd) e} in - add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd) - else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); - [new_eq] - end else [eq] - -let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 - ({body=e1; constant=c1} as eq1) = - try - let (f,_) = chop_var v e1 in - let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c - else failwith "eliminate_with_in" in - let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in - add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res - with CHOPVAR -> eq1 - -let omega_mod a b = a - b * floor_div (two * a + b) (two * b) -let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = - let e = original.body in - let sigma = new_var_id () in - if e == [] then begin - display_system print_var [original] ; failwith "TL" - end; - let smallest,var = - List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) - (abs (List.hd e).c, (List.hd e).v) (List.tl e) - in - let m = smallest + one in - let new_eq = - { constant = omega_mod original.constant m; - body = {c= neg m;v=sigma} :: - map_eq_linear (fun a -> omega_mod a m) original.body; - id = new_eq_id (); kind = EQUA } in - let definition = - { constant = neg (floor_div (two * original.constant + m) (two * m)); - body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) - original.body; - id = new_eq_id (); kind = EQUA } in - add_event (STATE {st_new_eq = new_eq; st_def = definition; - st_orig = original; st_coef = m; st_var = sigma}); - let new_eq = List.hd (normalize new_eq) in - let eliminated_var, def = chop_var var new_eq.body in - let other_equations = - Util.List.map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in - let inequations = - Util.List.map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in - let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in - let mod_original = map_eq_afine (fun c -> c / m) original' in - add_event (EXACT_DIVIDE (original',m)); - List.hd (normalize mod_original),other_equations,inequations - -let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = - if !debug then display_system print_var (e::other); - try - let v,def = chop_factor_1 e.body in - (Util.List.map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, - Util.List.map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) - with FACTOR1 -> - eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) - -let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = - let rec fst_eq_1 = function - (eq::l) -> - if List.exists (fun x -> abs x.c =? one) eq.body then eq,l - else let (eq',l') = fst_eq_1 l in (eq',eq::l') - | [] -> raise Not_found in - match sys_eq with - [] -> if !debug then display_system print_var sys_ineq; sys_ineq - | (e1::rest) -> - let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in - if eq.body = [] then - if eq.constant =? zero then begin - add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) - end else begin - add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE - end - else - banerjee new_ids - (eliminate_one_equation new_ids (eq,other,sys_ineq)) - -type kind = INVERTED | NORMAL - -let redundancy_elimination new_eq_id system = - let normal = function - ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter - (fun e -> - let ({body=ne} as nx) ,kind = normal e in - if ne = [] then - if nx.constant <? zero then begin - add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE - end else add_event (FORGET_C nx.id) - else - try - let (optnormal,optinvert) = Hashtbl.find table ne in - let final = - if kind = NORMAL then begin - match optnormal with - Some v -> - let kept = - if v.constant <? nx.constant - then begin add_event (FORGET (v.id,nx.id));v end - else begin add_event (FORGET (nx.id,v.id));nx end in - (Some(kept),optinvert) - | None -> Some nx,optinvert - end else begin - match optinvert with - Some v -> - let _kept = - if v.constant >? nx.constant - then begin add_event (FORGET_I (v.id,nx.id));v end - else begin add_event (FORGET_I (nx.id,v.id));nx end in - (optnormal,Some(if v.constant >? nx.constant then v else nx)) - | None -> optnormal,Some nx - end in - begin match final with - (Some high, Some low) -> - if high.constant <? low.constant then begin - add_event(CONTRADICTION (high,negate_eq low)); - raise UNSOLVABLE - end - | _ -> () end; - Hashtbl.remove table ne; - Hashtbl.add table ne final - with Not_found -> - Hashtbl.add table ne - (if kind = NORMAL then (Some nx,None) else (None,Some nx))) - system; - let accu_eq = ref [] in - let accu_ineq = ref [] in - Hashtbl.iter - (fun p0 p1 -> match (p0,p1) with - | (e, (Some x, Some y)) when x.constant =? y.constant -> - let id=new_eq_id () in - add_event (MERGE_EQ(id,x,y.id)); - push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq - | (e, (optnorm,optinvert)) -> - begin match optnorm with - Some x -> push x accu_ineq | _ -> () end; - begin match optinvert with - Some x -> push (negate_eq x) accu_ineq | _ -> () end) - table; - !accu_eq,!accu_ineq - -exception SOLVED_SYSTEM - -let select_variable system = - let table = Hashtbl.create 7 in - let push v c= - try let r = Hashtbl.find table v in r := max !r (abs c) - with Not_found -> Hashtbl.add table v (ref (abs c)) in - List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; - let vmin,cmin = ref (-1), ref zero in - let var_cpt = ref 0 in - Hashtbl.iter - (fun v ({contents = c}) -> - incr var_cpt; - if c <? !cmin || !vmin = (-1) then begin vmin := v; cmin := c end) - table; - if !var_cpt < 1 then raise SOLVED_SYSTEM; - !vmin - -let classify v system = - List.fold_left - (fun (not_occ,below,over) eq -> - try let f,eq' = chop_var v eq.body in - if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) - else (not_occ,below,((neg f.c,eq) :: over)) - with CHOPVAR -> (eq::not_occ,below,over)) - ([],[],[]) system - -let product new_eq_id dark_shadow low high = - List.fold_left - (fun accu (a,eq1) -> - List.fold_left - (fun accu (b,eq2) -> - let eq = - sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) - (map_eq_afine (fun c -> c * a) eq2) in - add_event(SUM(eq.id,(b,eq1),(a,eq2))); - match normalize eq with - | [eq] -> - let final_eq = - if dark_shadow then - let delta = (a - one) * (b - one) in - add_event(WEAKEN(eq.id,delta)); - {id = eq.id; kind=INEQ; body = eq.body; - constant = eq.constant - delta} - else eq - in final_eq :: accu - | (e::_) -> failwith "Product dardk" - | [] -> accu) - accu high) - [] low - -let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = - let v = select_variable system in - let (ineq_out, ineq_low,ineq_high) = classify v system in - let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in - if !debug then display_system print_var expanded; expanded - -let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = - if List.exists (fun e -> e.kind = DISE) system then - failwith "disequation in simplify"; - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - let system = Util.List.map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in - let system = (eqs @ simp_eq,simp_ineq) in - let rec loop1a system = - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in - if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids dark_shadow system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> - if !debug then display_system print_var system; system - in - loop2 (loop1a system) - -let rec depend relie_on accu = function - | act :: l -> - begin match act with - | DIVIDE_AND_APPROX (e,_,_,_) -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | EXACT_DIVIDE (e,_) -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | WEAKEN (e,_) -> - if Int.List.mem e relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> - if Int.List.mem e relie_on then - depend (e1.id::e2.id::relie_on) (act::accu) l - else - depend relie_on accu l - | STATE {st_new_eq=e;st_orig=o} -> - if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l - else depend relie_on accu l - | HYP e -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | FORGET_C _ -> depend relie_on accu l - | FORGET _ -> depend relie_on accu l - | FORGET_I _ -> depend relie_on accu l - | MERGE_EQ (e,e1,e2) -> - if Int.List.mem e relie_on then - depend (e1.id::e2::relie_on) (act::accu) l - else - depend relie_on accu l - | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | SPLIT_INEQ _ -> failwith "depend" - end - | [] -> relie_on, accu - -let negation (eqs,ineqs) = - let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in - let normal = function - | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter (fun e -> - let {body=ne;constant=c} ,kind = normal e in - Hashtbl.add table (ne,c) (kind,e)) diseq; - List.iter (fun e -> - assert (e.kind = EQUA); - let {body=ne;constant=c},kind = normal e in - try - let (kind',e') = Hashtbl.find table (ne,c) in - add_event (NEGATE_CONTRADICT (e,e',kind=kind')); - raise UNSOLVABLE - with Not_found -> ()) eqs - -exception FULL_SOLUTION of action list * int list - -let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - (* Initial simplification phase *) - let rec loop1a system = - negation system; - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - if simp_eq = [] then dise @ simp_ineq - else loop1a (simp_eq,dise @ simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids false system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system print_var system; system - in - let rec explode_diseq = function - | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () - and id2 = new_eq_id () in - let e1 = - {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; - constant = neg de.constant - one} in - let new_sys = - List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ - List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs - in - explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) - | ([],ineqs,expl_map) -> ineqs,expl_map - in - try - let system = Util.List.map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - let system = (eqs @ simp_eq,simp_ineq @ dise) in - let system' = loop1a system in - let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in - let first_segment = history () in - let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in - let all_solutions = - List.map - (fun (decomp,sys) -> - clear_history (); - try let _ = loop2 sys in raise NO_CONTRADICTION - with UNSOLVABLE -> - let relie_on,path = depend [] [] (history ()) in - let dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in - let red = List.map (fun (x,_,_) -> x) dc in - (red,relie_on,decomp,path)) - sys_exploded - in - let max_count sys = - let tbl = Hashtbl.create 7 in - let augment x = - try incr (Hashtbl.find tbl x) - with Not_found -> Hashtbl.add tbl x (ref 1) in - let eq = ref (-1) and c = ref 0 in - List.iter (function - | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) - | (l,_,_,_) -> List.iter augment l) sys; - Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; - !eq - in - let rec solve systems = - try - let id = max_count systems in - let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l - | [] -> failwith "solve" in - let s1,s2 = - List.partition (fun (_,_,decomp,_) -> sign decomp) systems in - let remove_int (dep,ro,dc,pa) = - (Util.List.except Int.equal id dep,ro,dc,pa) - in - let s1' = List.map remove_int s1 in - let s2' = List.map remove_int s2 in - let (r1,relie1) = solve s1' - and (r2,relie2) = solve s2' in - let (eq,id1,id2) = Int.List.assoc id explode_map in - [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], - eq.id :: Util.List.union Int.equal relie1 relie2 - with FULL_SOLUTION (x0,x1) -> (x0,x1) - in - let act,relie_on = solve all_solutions in - snd(depend relie_on act first_segment) - with UNSOLVABLE -> snd (depend [] [] (history ())) - -end diff --git a/plugins/omega/omega_plugin.mlpack b/plugins/omega/omega_plugin.mlpack deleted file mode 100644 index df7f1047f2..0000000000 --- a/plugins/omega/omega_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Omega -Coq_omega -G_omega diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 935cef58b9..ad85f68b03 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -46,6 +46,7 @@ open Ssrtacticals open Ssrbwd open Ssrequality open Ssripats +open Libobject (** Ssreflect load check. *) @@ -79,8 +80,39 @@ let ssrtac_entry name = { mltac_index = 0; } -let register_ssrtac name f = - Tacenv.register_ml_tactic (ssrtac_name name) [|f|] +let cache_tactic_notation (_, (key, body, parule)) = + Tacenv.register_alias key body; + Pptactic.declare_notation_tactic_pprule key parule + +type tactic_grammar_obj = KerName.t * Tacenv.alias_tactic * Pptactic.pp_tactic + +let inSsrGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "SsrGrammar") with + load_function = (fun _ -> cache_tactic_notation); + cache_function = cache_tactic_notation; + classify_function = (fun x -> Keep x)} + +let path = MPfile (DirPath.make @@ List.map Id.of_string ["ssreflect"; "ssr"; "Coq"]) + +let register_ssrtac name f prods = + let open Pptactic in + Tacenv.register_ml_tactic (ssrtac_name name) [|f|]; + let map id = Reference (Locus.ArgVar (CAst.make id)) in + let get_id = function + | TacTerm s -> None + | TacNonTerm (_, (_, ido)) -> ido in + let ids = List.map_filter get_id prods in + let tac = TacML (CAst.make (ssrtac_entry name, List.map map ids)) in + let key = KerName.make path (Label.make ("ssrparser_" ^ name)) in + let body = Tacenv.{ alias_args = ids; alias_body = tac; alias_deprecation = None } in + let parule = { + pptac_level = 0; + pptac_prods = prods + } in + let obj () = + Lib.add_anonymous_leaf (inSsrGrammar (key, body, parule)) in + Mltop.declare_cache_obj obj __coq_plugin_name; + key let cast_arg wit v = Taccoerce.Value.cast (Genarg.topwit wit) v @@ -933,7 +965,7 @@ END { let pr_intros sep intrs = - if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs + if intrs = [] then mt() else sep () ++ str "=>" ++ sep () ++ pr_ipats intrs let pr_ssrintros _ _ _ = pr_intros mt } @@ -963,15 +995,6 @@ END { -let () = register_ssrtac "tclintros" begin fun args ist -> match args with -| [arg] -> - let arg = cast_arg wit_ssrintrosarg arg in - let tac, intros = arg in - ssrevaltac ist tac <*> tclIPATssr intros -| _ -> assert false -end - - (** Defined identifier *) let pr_ssrfwdid id = pr_spc () ++ pr_id id @@ -1672,20 +1695,28 @@ let _ = add_internal_name (is_tagged perm_tag) { -type ssrargfmt = ArgSsr of string | ArgSep of string + let ssrtac_expr ?loc key args = + TacAlias (CAst.make ?loc (key, (List.map (fun x -> Tacexpr.TacGeneric (None, x)) args))) -let set_pr_ssrtac name prec afmt = (* FIXME *) () (* - let fmt = List.map (function - | ArgSep s -> Egramml.GramTerminal s - | ArgSsr s -> Egramml.GramTerminal s - | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in - let tacname = ssrtac_name name in () *) +let mk_non_term wit id = + let open Pptactic in + TacNonTerm (None, (Extend.Uentry (Genarg.ArgT.Any (Genarg.get_arg_tag wit)), Some id)) -let ssrtac_expr ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name, args)) +let tclintroskey = + let prods = + [ mk_non_term wit_ssrintrosarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [arg] -> + let arg = cast_arg wit_ssrintrosarg arg in + let tac, intros = arg in + ssrevaltac ist tac <*> tclIPATssr intros + | _ -> assert false + end in + register_ssrtac "tclintros" tac prods let tclintros_expr ?loc tac ipats = - let args = [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in - ssrtac_expr ?loc "tclintros" args + let args = [in_gen (rawwit wit_ssrintrosarg) (tac, ipats)] in + ssrtac_expr ?loc tclintroskey args } @@ -1768,18 +1799,20 @@ END { -let () = register_ssrtac "tcldo" begin fun args ist -> match args with -| [arg] -> - let arg = cast_arg wit_ssrdoarg arg in - ssrdotac ist arg -| _ -> assert false -end - -let _ = set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] +let tcldokey = + let open Pptactic in + let prods = [ TacTerm "do"; mk_non_term wit_ssrdoarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [arg] -> + let arg = cast_arg wit_ssrdoarg arg in + ssrdotac ist arg + | _ -> assert false + end in + register_ssrtac "tcldo" tac prods let ssrdotac_expr ?loc n m tac clauses = let arg = ((n, m), tac), clauses in - ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrdoarg) arg)] + ssrtac_expr ?loc tcldokey [in_gen (rawwit wit_ssrdoarg) arg] } @@ -1815,22 +1848,26 @@ END { -let () = register_ssrtac "tclseq" begin fun args ist -> match args with -| [tac; dir; arg] -> - let tac = cast_arg wit_ssrtclarg tac in - let dir = cast_arg wit_ssrseqdir dir in - let arg = cast_arg wit_ssrseqarg arg in - tclSEQAT ist tac dir arg -| _ -> assert false -end - -let _ = set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] +let tclseqkey = + let prods = + [ mk_non_term wit_ssrtclarg (Names.Id.of_string "tac") + ; mk_non_term wit_ssrseqdir (Names.Id.of_string "dir") + ; mk_non_term wit_ssrseqarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [tac; dir; arg] -> + let tac = cast_arg wit_ssrtclarg tac in + let dir = cast_arg wit_ssrseqdir dir in + let arg = cast_arg wit_ssrseqarg arg in + tclSEQAT ist tac dir arg + | _ -> assert false + end in + register_ssrtac "tclseq" tac prods let tclseq_expr ?loc tac dir arg = let arg1 = in_gen (rawwit wit_ssrtclarg) tac in let arg2 = in_gen (rawwit wit_ssrseqdir) dir in let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in - ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric (None, x)) [arg1; arg2; arg3]) + ssrtac_expr ?loc tclseqkey [arg1; arg2; arg3] } @@ -2453,8 +2490,9 @@ GRAMMAR EXTEND Gram GLOBAL: ltac_expr; ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> - { ssrtac_expr ~loc "abstract" - [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; + { TacML (CAst.make ~loc ( + ssrtac_entry "abstract", [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)])) + } ]]; END TACTIC EXTEND ssrabstract | [ "abstract" ssrdgens(gens) ] -> { diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 7774258fca..805be1fc87 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -22,7 +22,6 @@ open Vars open Libnames open Tactics open Termops -open Recordops open Tacmach open Glob_term open Util @@ -333,7 +332,8 @@ type tpattern = { let all_ok _ _ = true let proj_nparams c = - try 1 + Recordops.find_projection_nparams (GlobRef.ConstRef c) with _ -> 0 + try 1 + Structures.Structure.projection_nparams c + with Not_found -> 0 let isRigid c = match kind c with | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true @@ -429,9 +429,13 @@ let ungen_upat lhs (sigma, uc, t) u = | _ -> KpatRigid in sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} -let nb_cs_proj_args pc f u = +let nb_cs_proj_args ise pc f u = + let open Structures in + let open ValuePattern in let na k = - List.length (snd (lookup_canonical_conversion (Global.env()) (GlobRef.ConstRef pc, k))).o_TCOMPS in + let open CanonicalSolution in + let _, { cvalue_arguments } = find (Global.env()) ise (GlobRef.ConstRef pc, k) in + List.length cvalue_arguments 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 @@ -441,7 +445,7 @@ let nb_cs_proj_args pc f u = | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) | Const (c',_) when Constant.CanOrd.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.CanOrd.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.CanOrd.equal (Names.Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 @@ -467,7 +471,7 @@ let splay_app ise = | Cast _ | Evar _ -> loop c [| |] | _ -> c, [| |] -let filter_upat i0 f n u fpats = +let filter_upat ise i0 f n u fpats = let na = Array.length u.up_a in if n < na then fpats else let np = match u.up_k with @@ -479,7 +483,7 @@ let filter_upat i0 f n u fpats = | KpatRigid when isRigid f -> na | KpatFlex -> na | KpatProj pc -> - let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + let np = na + nb_cs_proj_args ise pc f u in if n < np then -1 else np | _ -> -1 in if np < na then fpats else let () = if !i0 < np then i0 := n in (u, np) :: fpats @@ -568,7 +572,7 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + let fpats = List.fold_right (filter_upat ise i0 f (Array.length a)) upats [] in while !i0 >= 0 do let i = !i0 in i0 := -1; let one_match (u, np) = diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index ac89dfd747..9b25d63640 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -30,29 +30,6 @@ type cl_typ = | CL_IND of inductive | CL_PROJ of Projection.Repr.t -type cl_info_typ = { - cl_param : int -} - -type coe_typ = GlobRef.t - -module CoeTypMap = GlobRef.Map_env - -type coe_info_typ = { - coe_value : GlobRef.t; - coe_local : bool; - coe_is_identity : bool; - coe_is_projection : Projection.Repr.t option; - coe_param : int; -} - -let coe_info_typ_equal c1 c2 = - GlobRef.equal c1.coe_value c2.coe_value && - c1.coe_local == c2.coe_local && - c1.coe_is_identity == c2.coe_is_identity && - c1.coe_is_projection == c2.coe_is_projection && - Int.equal c1.coe_param c2.coe_param - let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 @@ -60,81 +37,76 @@ let cl_typ_ord t1 t2 = match t1, t2 with | CL_IND i1, CL_IND i2 -> Ind.CanOrd.compare i1 i2 | _ -> pervasives_compare t1 t2 (** OK *) +let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 + module ClTyp = struct type t = cl_typ let compare = cl_typ_ord end -module ClTypMap = Map.Make(ClTyp) - -let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 +module ClPairOrd = +struct + type t = cl_typ * cl_typ + let compare (i1, j1) (i2, j2) = + let c = cl_typ_ord i1 i2 in + if Int.equal c 0 then cl_typ_ord j1 j2 else c +end -type inheritance_path = coe_info_typ list +module ClTypSet = Set.Make(ClTyp) +module ClTypMap = Map.Make(ClTyp) +module ClPairMap = Map.Make(ClPairOrd) -(* table des classes, des coercions et graphe d'heritage *) +type cl_info_typ = { + (* The number of parameters of the coercion class. *) + cl_param : int; + (* The sets of coercion classes respectively reachable from and to the + coercion class. *) + cl_reachable_from : ClTypSet.t; + cl_reachable_to : ClTypSet.t; + (* The representative class of the strongly connected component. *) + cl_repr : cl_typ; +} -module Bijint : -sig - module Index : - sig - type t - val compare : t -> t -> int - val equal : t -> t -> bool - val print : t -> Pp.t - end - type 'a t - val empty : 'a t - val mem : cl_typ -> 'a t -> bool - val map : Index.t -> 'a t -> cl_typ * 'a - val revmap : cl_typ -> 'a t -> Index.t * 'a - val add : cl_typ -> 'a -> 'a t -> 'a t - val dom : 'a t -> cl_typ list -end -= -struct +type coe_typ = GlobRef.t - module Index = struct include Int let print = Pp.int end +module CoeTypMap = GlobRef.Map_env - type 'a t = { v : (cl_typ * 'a) Int.Map.t; s : int; inv : int ClTypMap.t } - let empty = { v = Int.Map.empty; s = 0; inv = ClTypMap.empty } - let mem y b = ClTypMap.mem y b.inv - let map x b = Int.Map.find x b.v - let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (Int.Map.find n b.v)) - let add x y b = - { v = Int.Map.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } - let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv []) -end +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_source : cl_typ; + coe_target : cl_typ; + coe_param : int; +} -type cl_index = Bijint.Index.t +type inheritance_path = coe_info_typ list let init_class_tab = - let open Bijint in - add CL_FUN { cl_param = 0 } (add CL_SORT { cl_param = 0 } empty) + let open ClTypMap in + let cl_info params cl = + let cl_singleton = ClTypSet.singleton cl in + { cl_param = params; + cl_reachable_from = cl_singleton; + cl_reachable_to = cl_singleton; + cl_repr = cl } + in + add CL_FUN (cl_info 0 CL_FUN) (add CL_SORT (cl_info 0 CL_SORT) empty) let class_tab = - Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ Bijint.t) + Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ ClTypMap.t) let coercion_tab = Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) -module ClPairOrd = -struct - type t = cl_index * cl_index - let compare (i1, j1) (i2, j2) = - let c = Bijint.Index.compare i1 i2 in - if Int.equal c 0 then Bijint.Index.compare j1 j2 else c -end - -module ClPairMap = Map.Make(ClPairOrd) - let inheritance_graph = Summary.ref ~name:"inheritance_graph" (ClPairMap.empty : inheritance_path ClPairMap.t) (* ajout de nouveaux "objets" *) let add_new_class cl s = - if not (Bijint.mem cl !class_tab) then - class_tab := Bijint.add cl s !class_tab + class_tab := ClTypMap.add cl s !class_tab let add_new_coercion coe s = coercion_tab := CoeTypMap.add coe s !coercion_tab @@ -144,17 +116,11 @@ let add_new_path x y = (* class_info : cl_typ -> int * cl_info_typ *) -let class_info cl = Bijint.revmap cl !class_tab - -let class_exists cl = Bijint.mem cl !class_tab - -(* class_info_from_index : int -> cl_typ * cl_info_typ *) - -let class_info_from_index i = Bijint.map i !class_tab +let class_info cl = ClTypMap.find cl !class_tab -let cl_fun_index = fst(class_info CL_FUN) +let class_nparams cl = (class_info cl).cl_param -let cl_sort_index = fst(class_info CL_SORT) +let class_exists cl = ClTypMap.mem cl !class_tab let coercion_info coe = CoeTypMap.find coe !coercion_tab @@ -200,20 +166,18 @@ let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, u, args) = + let (t, n1, cl, u, args) = try let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, u, args) + let { cl_param = n1 } = class_info cl in + (t, n1, cl, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, u, args) + let { cl_param = n1 } = class_info cl in + (t, n1, cl, u, args) in - if Int.equal (List.length args) n1 then t, i else raise Not_found - -let inductive_class_of ind = fst (class_info (CL_IND ind)) + if Int.equal (List.length args) n1 then t, cl else raise Not_found let class_args_of env sigma c = pi3 (find_class_type env sigma c) @@ -238,26 +202,26 @@ let lookup_path_between_class (s,t) = ClPairMap.find (s,t) !inheritance_graph let lookup_path_to_fun_from_class s = - lookup_path_between_class (s,cl_fun_index) + lookup_path_between_class (s, CL_FUN) let lookup_path_to_sort_from_class s = - lookup_path_between_class (s,cl_sort_index) + lookup_path_between_class (s, CL_SORT) (* advanced path lookup *) let apply_on_class_of env sigma t cont = try let (cl,u,args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in + let { cl_param = n1 } = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - t, cont i + t, cont cl with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in + let { cl_param = n1 } = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - t, cont i + t, cont cl let lookup_path_between env sigma (s,t) = let (s,(t,p)) = @@ -287,25 +251,25 @@ let get_coercion_constructor env coe = | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = - let i = inductive_class_of s in - let j = inductive_class_of t in - List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) + List.map (get_coercion_constructor env) + (ClPairMap.find (CL_IND s, CL_IND t) !inheritance_graph) (* rajouter une coercion dans le graphe *) -let path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) ref = +let path_printer : ((cl_typ * cl_typ) * inheritance_path -> Pp.t) ref = ref (fun _ -> str "<a class path>") let install_path_printer f = path_printer := f let print_path x = !path_printer x -let path_comparator : (Environ.env -> Evd.evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) ref = +let path_comparator : + (Environ.env -> Evd.evar_map -> cl_typ -> inheritance_path -> inheritance_path -> bool) ref = ref (fun _ _ _ _ _ -> false) let install_path_comparator f = path_comparator := f -let compare_path p q = !path_comparator p q +let compare_path env sigma cl p q = !path_comparator env sigma cl p q let warn_ambiguous_path = CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" @@ -316,88 +280,105 @@ let warn_ambiguous_path = else str" is ambiguous with existing " ++ print_path (c, q) ++ str".") l) -(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit +(* add_coercion_in_graph : coe_index * cl_typ * cl_typ -> unit coercion,source,target *) -let different_class_params env i = - let ci = class_info_from_index i in - if (snd ci).cl_param > 0 then true - else - match fst ci with - | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) - | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) - | _ -> false - -let add_coercion_in_graph env sigma (ic,source,target) = +let different_class_params env ci = + if (class_info ci).cl_param > 0 then true + else + match ci with + | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) + | _ -> false + +let add_coercion_in_graph env sigma ic = + let source = ic.coe_source in + let target = ic.coe_target in + let source_info = class_info source in + let target_info = class_info target in let old_inheritance_graph = !inheritance_graph in - let ambig_paths = - (ref [] : ((cl_index * cl_index) * inheritance_path * inheritance_path) list ref) in + let ambig_paths : + ((cl_typ * cl_typ) * inheritance_path * inheritance_path) list ref = + ref [] in + let check_coherence (i, j as ij) p q = + let i_info = class_info i in + let j_info = class_info j in + let between_ij = ClTypSet.inter i_info.cl_reachable_from j_info.cl_reachable_to in + if cl_typ_eq i_info.cl_repr i && + cl_typ_eq j_info.cl_repr j && + ClTypSet.is_empty + (ClTypSet.diff (ClTypSet.inter between_ij source_info.cl_reachable_to) + i_info.cl_reachable_to) && + ClTypSet.is_empty + (ClTypSet.diff + (ClTypSet.inter between_ij target_info.cl_reachable_from) + j_info.cl_reachable_from) && + not (compare_path env sigma i p q) + then + ambig_paths := (ij, p, q) :: !ambig_paths + in let try_add_new_path (i,j as ij) p = - (* If p is a cycle, we check whether p is definitionally an identity - function or not. If it is not, we report p as an ambiguous inheritance - path. *) - if Bijint.Index.equal i j && not (compare_path env sigma i p []) then - ambig_paths := (ij,p,[])::!ambig_paths; - if not (Bijint.Index.equal i j) || different_class_params env i then + if cl_typ_eq i j then check_coherence ij p []; + if not (cl_typ_eq i j) || different_class_params env i then match lookup_path_between_class ij with - | q -> - (* p has the same source and target classes as an existing path q. We - report them as ambiguous inheritance paths if - 1. p and q have no common element, and - 2. p and q are not convertible. - If 1 does not hold, say p = p1 @ [c] @ p2 and q = q1 @ [c] @ q2, - convertibility of p1 and q1, also, p2 and q2 should be checked; thus, - checking the ambiguity of p and q is redundant with them. *) - if not (List.exists (fun c -> List.exists (coe_info_typ_equal c) q) p || - compare_path env sigma i p q) then - ambig_paths := (ij,p,q)::!ambig_paths; - false - | exception Not_found -> (add_new_path ij p; true) + | q -> (if not (cl_typ_eq i j) then check_coherence ij p q); false + | exception Not_found -> add_new_path ij p; true else false in let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () in - if try_add_new_path (source,target) [ic] then begin + if try_add_new_path (source, target) [ic] then begin ClPairMap.iter (fun (s,t) p -> - if not (Bijint.Index.equal s t) then begin - if Bijint.Index.equal t source then begin - try_add_new_path1 (s,target) (p@[ic]); + if not (cl_typ_eq s t) then begin + if cl_typ_eq t source then begin + try_add_new_path1 (s, target) (p@[ic]); ClPairMap.iter (fun (u,v) q -> - if not (Bijint.Index.equal u v) && Bijint.Index.equal u target then + if not (cl_typ_eq u v) && cl_typ_eq u target then try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; - if Bijint.Index.equal s target then try_add_new_path1 (source,t) (ic::p) + if cl_typ_eq s target then try_add_new_path1 (source, t) (ic::p) end) old_inheritance_graph end; + class_tab := ClTypMap.mapi (fun k k_info -> + let reachable_k_source = ClTypSet.mem k source_info.cl_reachable_to in + let reachable_target_k = ClTypSet.mem k target_info.cl_reachable_from in + { k_info with + cl_reachable_from = + if reachable_k_source then + ClTypSet.union + k_info.cl_reachable_from target_info.cl_reachable_from + else + k_info.cl_reachable_from; + cl_reachable_to = + if reachable_target_k then + ClTypSet.union k_info.cl_reachable_to source_info.cl_reachable_to + else + k_info.cl_reachable_to; + cl_repr = + if reachable_k_source && reachable_target_k then + target_info.cl_repr + else + k_info.cl_repr + }) !class_tab; match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths -type coercion = { - coercion_type : coe_typ; - coercion_local : bool; - coercion_is_id : bool; - coercion_is_proj : Projection.Repr.t option; - coercion_source : cl_typ; - coercion_target : cl_typ; - coercion_params : int; -} - let subst_coercion subst c = let env = Global.env () in - let coe = subst_coe_typ subst c.coercion_type in - let cls = subst_cl_typ env subst c.coercion_source in - let clt = subst_cl_typ env subst c.coercion_target in - let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in - if c.coercion_type == coe && c.coercion_source == cls && - c.coercion_target == clt && c.coercion_is_proj == clp + let coe = subst_coe_typ subst c.coe_value in + let cls = subst_cl_typ env subst c.coe_source in + let clt = subst_cl_typ env subst c.coe_target in + let clp = Option.Smart.map (subst_proj_repr subst) c.coe_is_projection in + if c.coe_value == coe && c.coe_source == cls && c.coe_target == clt && + c.coe_is_projection == clp then c - else { c with coercion_type = coe; coercion_source = cls; - coercion_target = clt; coercion_is_proj = clp; } + else { c with coe_value = coe; coe_source = cls; coe_target = clt; + coe_is_projection = clp; } (* Computation of the class arity *) @@ -419,27 +400,23 @@ let class_params env sigma = function (* add_class : cl_typ -> locality_flag option -> bool -> unit *) let add_class env sigma cl = - add_new_class cl { cl_param = class_params env sigma cl } + if not (class_exists cl) then + let cl_singleton = ClTypSet.singleton cl in + add_new_class cl { + cl_param = class_params env sigma cl; + cl_reachable_from = cl_singleton; + cl_reachable_to = cl_singleton; + cl_repr = cl } let declare_coercion env sigma c = - let () = add_class env sigma c.coercion_source in - let () = add_class env sigma c.coercion_target in - let is, _ = class_info c.coercion_source in - let it, _ = class_info c.coercion_target in - let xf = - { coe_value = c.coercion_type; - coe_local = c.coercion_local; - coe_is_identity = c.coercion_is_id; - coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params; - } in - let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph env sigma (xf,is,it) + let () = add_class env sigma c.coe_source in + let () = add_class env sigma c.coe_target in + let () = add_new_coercion c.coe_value c in + add_coercion_in_graph env sigma c (* For printing purpose *) -let pr_cl_index = Bijint.Index.print - -let classes () = Bijint.dom !class_tab +let classes () = + List.rev (ClTypMap.fold (fun x _ acc -> x :: acc) !class_tab []) let coercions () = List.rev (CoeTypMap.fold (fun _ y acc -> y::acc) !coercion_tab []) diff --git a/pretyping/coercionops.mli b/pretyping/coercionops.mli index 073500b155..af91dd1d0e 100644 --- a/pretyping/coercionops.mli +++ b/pretyping/coercionops.mli @@ -31,10 +31,6 @@ val subst_cl_typ : env -> substitution -> cl_typ -> cl_typ (** Comparison of [cl_typ] *) val cl_typ_ord : cl_typ -> cl_typ -> int -(** This is the type of infos for declared classes *) -type cl_info_typ = { - cl_param : int } - (** This is the type of coercion kinds *) type coe_typ = GlobRef.t @@ -44,12 +40,11 @@ type coe_info_typ = { coe_local : bool; coe_is_identity : bool; coe_is_projection : Projection.Repr.t option; + coe_source : cl_typ; + coe_target : cl_typ; coe_param : int; } -(** [cl_index] is the type of class keys *) -type cl_index - (** This is the type of paths from a class to another *) type inheritance_path = coe_info_typ list @@ -57,37 +52,21 @@ type inheritance_path = coe_info_typ list val class_exists : cl_typ -> bool -val class_info : cl_typ -> (cl_index * cl_info_typ) (** @raise Not_found if this type is not a class *) - -val class_info_from_index : cl_index -> cl_typ * cl_info_typ +val class_nparams : cl_typ -> int (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) val find_class_type : env -> evar_map -> types -> cl_typ * EInstance.t * constr list (** raises [Not_found] if not convertible to a class *) -val class_of : env -> evar_map -> types -> types * cl_index - -(** raises [Not_found] if not mapped to a class *) -val inductive_class_of : inductive -> cl_index +val class_of : env -> evar_map -> types -> types * cl_typ val class_args_of : env -> evar_map -> types -> constr list -(** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) -type coercion = { - coercion_type : coe_typ; - coercion_local : bool; - coercion_is_id : bool; - coercion_is_proj : Projection.Repr.t option; - coercion_source : cl_typ; - coercion_target : cl_typ; - coercion_params : int; -} - -val subst_coercion : substitution -> coercion -> coercion +val subst_coercion : substitution -> coe_info_typ -> coe_info_typ -val declare_coercion : env -> evar_map -> coercion -> unit +val declare_coercion : env -> evar_map -> coe_info_typ -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool @@ -98,7 +77,7 @@ val coercion_info : coe_typ -> coe_info_typ (** @raise Not_found in the following functions when no path exists *) -val lookup_path_between_class : cl_index * cl_index -> inheritance_path +val lookup_path_between_class : cl_typ * cl_typ -> inheritance_path val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path val lookup_path_to_fun_from : env -> evar_map -> types -> @@ -111,16 +90,15 @@ val lookup_pattern_path_between : (**/**) (* Crade *) val install_path_printer : - ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit + ((cl_typ * cl_typ) * inheritance_path -> Pp.t) -> unit val install_path_comparator : - (env -> evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) -> unit + (env -> evar_map -> cl_typ -> inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t -val pr_cl_index : cl_index -> Pp.t -val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list +val inheritance_graph : unit -> ((cl_typ * cl_typ) * inheritance_path) list val classes : unit -> cl_typ list val coercions : unit -> coe_info_typ list diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index e1d6fff3e4..5eb8a88698 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -19,7 +19,7 @@ open Context open Vars open Reduction open Reductionops -open Recordops +open Structures open Evarutil open Evardefine open Evarsolve @@ -230,33 +230,30 @@ let occur_rigidly flags env evd (evk,_) t = projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = + let open ValuePattern in let (proji, u), arg = Termops.global_app_of_constr sigma t1 in - let canon_s,sk2_effective = + let (sigma, solution), sk2_effective = try match EConstr.kind sigma t2 with Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then - lookup_canonical_conversion env (proji, Prod_cs), + CanonicalSolution.find env sigma (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 env + CanonicalSolution.find env sigma (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> - lookup_canonical_conversion env (proji, Proj_cs (Projection.repr p)), Stack.append_app [|c|] sk2 + CanonicalSolution.find env sigma(proji, Proj_cs (Names.Projection.repr p)), Stack.append_app [|c|] sk2 | _ -> let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in - lookup_canonical_conversion env (proji, Const_cs c2),sk2 + CanonicalSolution.find env sigma (proji, Const_cs c2),sk2 with Not_found -> - let (c, cs) = lookup_canonical_conversion env (proji,Default_cs) in - (c,cs),[] + CanonicalSolution.find env sigma (proji,Default_cs), [] in - let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let us = List.map EConstr.of_constr us in - let params = List.map EConstr.of_constr params in + let open CanonicalSolution in let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) @@ -267,28 +264,19 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 | None -> - match Stack.strip_n_app nparams sk1 with + match Stack.strip_n_app solution.nparams sk1 with | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = - let l_us = List.length us in + let l_us = List.length solution.cvalue_arguments in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - let u, ctx' = UnivGen.fresh_instance_from ctx None in - let subst = Univ.make_inverse_instance_subst u in - let c = EConstr.of_constr c in - let c' = subst_univs_level_constr subst c in - let t' = EConstr.of_constr t' in - let t' = subst_univs_level_constr subst t' in - let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in - let params = List.map (fun c -> subst_univs_level_constr subst c) params in - let us = List.map (fun c -> subst_univs_level_constr subst c) us in - let h, _ = decompose_app_vect sigma t' in - ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), - (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n, Stack.zip sigma (t2,sk2)) + let h, _ = decompose_app_vect sigma solution.body in + sigma,(h, t2),solution.constant,solution.abstractions_ty,(Stack.append_app_list solution.params Stack.empty,params1), + (Stack.append_app_list solution.cvalue_arguments Stack.empty,us2),(extra_args1,extra_args2),c1, + (solution.cvalue_abstraction, Stack.zip sigma (t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -926,7 +914,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty and f2 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i + else conv_record flags env (try check_conv_record env i appr1 appr2 with Not_found -> check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -989,7 +977,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f3 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i (check_conv_record env i appr1 appr2) + else conv_record flags env (check_conv_record env i appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty @@ -1003,7 +991,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f3 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i (check_conv_record env i appr2 appr1) + else conv_record flags env (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty appr1 @@ -1113,7 +1101,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | LetIn _, _ -> assert false end -and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = +and conv_record flags env (evd,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = (* Tries to unify the states (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) @@ -1137,7 +1125,6 @@ and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk had to be initially resolved *) - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = List.fold_left @@ -1195,13 +1182,6 @@ let evar_conv_x flags = evar_conv_x flags let evar_unify = conv_fun evar_conv_x -(* Profiling *) -let evar_conv_x = - if Flags.profile then - let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in - CProfile.profile6 evar_conv_xkey evar_conv_x - else evar_conv_x - let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () let evar_conv_x flags = Hook.get evar_conv_hook_get flags diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index be03ced7eb..965cd7de67 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -78,7 +78,7 @@ val check_problems_are_solved : env -> evar_map -> unit val check_conv_record : env -> evar_map -> state -> state -> - Univ.ContextSet.t * (constr * constr) + evar_map * (constr * constr) * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * constr * diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 34fae613bf..ad28b54900 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -51,6 +51,8 @@ let make ~hypnaming env sigma lvar = } let env env = env.static_env +let renamed_env env = env.renamed_env +let lfun env = env.lvar.ltac_genargs let vars_of_env env = Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) @@ -183,10 +185,13 @@ let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_ju let interp_ltac_id env id = ltac_interp_id env.lvar id +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + module ConstrInterpObj = struct - type ('r, 'g, 't) obj = - unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + type ('r, 'g, 't) obj = 'g obj_interp_fun let name = "constr_interp" let default _ = None end @@ -195,8 +200,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env poly sigma ty arg = +let interp_glob_genarg ?loc ~poly env sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg + interp ?loc ~poly env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 023e24e6d8..40feb8206b 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -15,11 +15,18 @@ open EConstr open Ltac_pretype open Evarutil +(** Type of environment extended with naming and ltac interpretation data *) + +type t + (** To embed constr in glob_constr *) +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + val register_constr_interp0 : - ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + ('r, 'g, 't) Genarg.genarg_type -> 'g obj_interp_fun -> unit (** {6 Pretyping name management} *) @@ -32,10 +39,6 @@ val register_constr_interp0 : variables used to build purely-named evar contexts *) -(** Type of environment extended with naming and ltac interpretation data *) - -type t - (** Build a pretyping environment from an ltac environment *) val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t @@ -43,6 +46,8 @@ val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t (** Export the underlying environment *) val env : t -> env +val renamed_env : t -> env +val lfun : t -> unbound_ltac_var_map val vars_of_env : t -> Id.Set.t @@ -85,5 +90,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> bool -> evar_map -> constr -> - Genarg.glob_generic_argument -> constr * evar_map +val interp_glob_genarg : ?loc:Loc.t -> poly:bool -> t -> evar_map -> Evardefine.type_constraint -> + Genarg.glob_generic_argument -> unsafe_judgment * evar_map diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 2c107502f4..b19dbd46be 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -135,8 +135,9 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let construct_of_constr const env sigma tag typ = - let t, l = app_type env typ in - match EConstr.kind_upto sigma t with + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, l = decompose_appvect (EConstr.Unsafe.to_constr typ) in + match Constr.kind t with | Ind (ind,u) -> construct_of_constr_notnative const env tag ind u l | _ -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e86a8a28c9..21b2137f09 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -35,6 +35,7 @@ open Environ open EConstr open Vars open Reductionops +open Structures open Type_errors open Typing open Evarutil @@ -653,12 +654,8 @@ struct sigma, { uj_val; uj_type } | Some arg -> - let sigma, ty = - match tycon with - | Some ty -> sigma, ty - | None -> new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) in - let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in - sigma, { uj_val = c; uj_type = ty } + let j, sigma = GlobEnv.interp_glob_genarg ?loc ~poly env sigma tycon arg in + sigma, j let pretype_rec self (fixkind, names, bl, lar, vdef) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -805,8 +802,8 @@ struct in let app_f = match EConstr.kind sigma fj.uj_val with - | Const (p, u) when Recordops.is_primitive_projection p -> - let p = Option.get @@ Recordops.find_primitive_projection p in + | Const (p, u) when PrimitiveProjections.mem p -> + let p = Option.get @@ PrimitiveProjections.find_opt p in let p = Projection.make p false in let npars = Projection.npars p in fun n -> @@ -1398,7 +1395,7 @@ let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) -let path_convertible env sigma i p q = +let path_convertible env sigma cl p q = let open Coercionops in let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in @@ -1423,7 +1420,7 @@ let path_convertible env sigma i p q = p' | [] -> (* identity function for the class [i]. *) - let cl,params = class_info_from_index i in + let params = class_nparams cl in let clty = match cl with | CL_SORT -> mkGSort (Glob_term.UAnonymous {rigid=false}) @@ -1434,8 +1431,7 @@ let path_convertible env sigma i p q = | CL_PROJ p -> mkGRef (GlobRef.ConstRef (Projection.Repr.constant p)) in let names = - List.init params.cl_param - (fun n -> Id.of_string ("x" ^ string_of_int n)) + List.init params (fun n -> Id.of_string ("x" ^ string_of_int n)) in List.fold_right (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index c31ecc135c..980575abac 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -12,7 +12,7 @@ Cbv Find_subterm Evardefine Evarsolve -Recordops +Structures Heads Evarconv Typing diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli deleted file mode 100644 index 83927085e9..0000000000 --- a/pretyping/recordops.mli +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constr - -(** Operations concerning records and canonical structures *) - -(** {6 Records } *) -(** A structure S is a non recursive inductive type with a single - constructor (the name of which defaults to Build_S) *) - -type proj_kind = { - pk_name: Name.t; - pk_true_proj: bool; - pk_canonical: bool; -} - -type struc_typ = { - s_CONST : constructor; - s_EXPECTEDPARAM : int; - s_PROJKIND : proj_kind list; - s_PROJ : Constant.t option list; -} - -val register_structure : struc_typ -> unit -val subst_structure : Mod_subst.substitution -> struc_typ -> struc_typ -val rebuild_structure : Environ.env -> struc_typ -> struc_typ - -(** [lookup_structure isp] returns the struc_typ associated to the - inductive path [isp] if it corresponds to a structure, otherwise - it fails with [Not_found] *) -val lookup_structure : inductive -> struc_typ - -(** [lookup_projections isp] returns the projections associated to the - inductive path [isp] if it corresponds to a structure, otherwise - it fails with [Not_found] *) -val lookup_projections : inductive -> Constant.t option list - -(** raise [Not_found] if not a projection *) -val find_projection_nparams : GlobRef.t -> int - -(** raise [Not_found] if not a projection *) -val find_projection : GlobRef.t -> struc_typ - -val is_projection : Constant.t -> bool - -(** Sets up the mapping from constants to primitive projections *) -val register_primitive_projection : Projection.Repr.t -> Constant.t -> unit - -val is_primitive_projection : Constant.t -> bool - -val find_primitive_projection : Constant.t -> Projection.Repr.t option - -(** {6 Canonical structures } *) -(** A canonical structure declares "canonical" conversion hints between - the effective components of a structure and the projections of the - structure *) - -(** 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 - -type obj_typ = { - o_ORIGIN : GlobRef.t; - o_DEF : constr; - o_CTX : Univ.AUContext.t; - o_INJ : int option; (** position of trivial argument *) - o_TABS : constr list; (** ordered *) - o_TPARAMS : constr list; (** ordered *) - o_NPARAMS : int; - o_TCOMPS : constr list } (** ordered *) - -(** Return the form of the component of a canonical structure *) -val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * constr list - -val pr_cs_pattern : cs_pattern -> Pp.t - -type cs = GlobRef.t * inductive - -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 -val is_open_canonical_projection : - Environ.env -> Evd.evar_map -> EConstr.t -> bool -val canonical_projections : unit -> - ((GlobRef.t * cs_pattern) * obj_typ) list - -val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> cs diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 4083d3bc23..cb576a379a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1038,13 +1038,6 @@ let nf_all env sigma = (********************************************************************) (* Conversion *) (********************************************************************) -(* -let fkey = CProfile.declare_profile "fhnf";; -let fhnf info v = CProfile.profile2 fkey fhnf info v;; - -let fakey = CProfile.declare_profile "fhnf_apply";; -let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;; -*) let is_transparent e k = match Conv_oracle.get_strategy (Environ.oracle e) k with diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 064990f6bf..cdb86afa1a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -249,17 +249,6 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) | _ -> assert false -(* Profiling *) -(* let get_type_of polyprop lax env sigma c = *) -(* let f,_,_,_ = retype ~polyprop sigma in *) -(* if lax then f env c else anomaly_on_error (f env) c *) - -(* let get_type_of_key = CProfile.declare_profile "get_type_of" *) -(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *) - -(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) -(* get_type_of polyprop lax env sigma c *) - let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_ = retype ~polyprop sigma in if lax then f env c else anomaly_on_error (f env) c diff --git a/pretyping/recordops.ml b/pretyping/structures.ml index aa862a912e..3ef6e98373 100644 --- a/pretyping/recordops.ml +++ b/pretyping/structures.ml @@ -37,71 +37,67 @@ open Reductionops * the constant realizing this projection (if any). *) -type proj_kind = { - pk_name: Name.t; - pk_true_proj: bool; - pk_canonical: bool; +module Structure = struct + +type projection = { + proj_name : Names.Name.t; + proj_true : bool; + proj_canonical : bool; + proj_body : Names.Constant.t option; +} + +type t = { + name : Names.inductive; + projections : projection list; + nparams : int; } -type struc_typ = { - s_CONST : constructor; - s_EXPECTEDPARAM : int; - s_PROJKIND : proj_kind list; - s_PROJ : Constant.t option list } +let make env name projections = + let nparams = Inductiveops.inductive_nparams env name in + { name; projections; nparams } let structure_table = - Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs" + Summary.ref (Indmap.empty : t Indmap.t) ~name:"record-structs" let projection_table = - Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" + Summary.ref (Cmap.empty : t Cmap.t) ~name:"record-projs" -let register_structure ({ s_CONST = (ind,_); s_PROJ = projs; } as struc) = - structure_table := Indmap.add ind struc !structure_table; +let register ({ name; projections; nparams } as s) = + structure_table := Indmap.add name s !structure_table; projection_table := - List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) - projs !projection_table - -let subst_structure subst struc = - let projs' = - (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) - (* the first component of subst_con. *) - List.Smart.map - (Option.Smart.map (subst_constant subst)) - struc.s_PROJ - in - let id' = Globnames.subst_constructor subst struc.s_CONST in - if projs' == struc.s_PROJ && id' == struc.s_CONST - then struc - else { struc with s_CONST = id'; s_PROJ = projs' } + List.fold_right (fun { proj_body } m -> + Option.fold_right (fun proj -> Cmap.add proj s) proj_body m) + projections !projection_table -let rebuild_structure env struc = - let mib = Environ.lookup_mind (fst (fst struc.s_CONST)) env in - let npars = mib.Declarations.mind_nparams in - { struc with s_EXPECTEDPARAM = npars } +let subst subst ({ name; projections; nparams } as s) = + let subst_projection subst ({ proj_body } as p) = + let proj_body = Option.Smart.map (subst_constant subst) proj_body in + if proj_body == p.proj_body then p else + { p with proj_body } in + let projections = List.Smart.map (subst_projection subst) projections in + let name = Mod_subst.subst_ind subst name in + if projections == s.projections && + name == s.name + then s + else { name; projections; nparams } -let lookup_structure indsp = Indmap.find indsp !structure_table +let rebuild env s = + let mib = Environ.lookup_mind (fst s.name) env in + let nparams = mib.Declarations.mind_nparams in + { s with nparams } -let lookup_projections indsp = (lookup_structure indsp).s_PROJ +let find indsp = Indmap.find indsp !structure_table -let find_projection_nparams = function - | GlobRef.ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM - | _ -> raise Not_found +let find_projections indsp = + (find indsp).projections |> + List.map (fun { proj_body } -> proj_body) -let find_projection = function - | GlobRef.ConstRef cst -> Cmap.find cst !projection_table - | _ -> raise Not_found +let find_from_projection cst = Cmap.find cst !projection_table -let is_projection cst = Cmap.mem cst !projection_table +let projection_nparams cst = (Cmap.find cst !projection_table).nparams -let prim_table = - Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" - -let register_primitive_projection p c = - prim_table := Cmap_env.add c p !prim_table - -let is_primitive_projection c = Cmap_env.mem c !prim_table +let is_projection cst = Cmap.mem cst !projection_table -let find_primitive_projection c = - try Some (Cmap_env.find c !prim_table) with Not_found -> None +end (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) @@ -142,49 +138,55 @@ type obj_typ = { o_NPARAMS : int; o_TCOMPS : constr list } (* ordered *) -type cs_pattern = +module ValuePattern = struct + +type t = Const_cs of GlobRef.t - | Proj_cs of Projection.Repr.t + | Proj_cs of Names.Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs -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 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 - - -let object_table = - Summary.ref (GlobRef.Map.empty : ((cs_pattern * constr) * obj_typ) list GlobRef.Map.t) - ~name:"record-canonical-structs" - -let canonical_projections () = - GlobRef.Map.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc)) - !object_table [] - -let keep_true_projections projs kinds = - let filter (p, { pk_true_proj ; pk_canonical }) = if pk_true_proj then Some (p, pk_canonical) else None in - List.map_filter filter (List.combine projs kinds) +let equal 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 cs_pattern_of_constr env t = +let rec of_constr env t = match kind t with | App (f,vargs) -> - let patt, n, args = cs_pattern_of_constr env f in + let patt, n, args = of_constr env f in 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) -> Proj_cs (Projection.repr p), None, [c] + | Proj (p, c) -> Proj_cs (Names.Projection.repr p), None, [c] | Sort s -> Sort_cs (Sorts.family s), None, [] | _ -> Const_cs (fst @@ destRef t) , None, [] +let print = function + Const_cs c -> Nametab.pr_global_env Id.Set.empty c + | Proj_cs p -> Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef (Names.Projection.Repr.constant p)) + | Prod_cs -> str "_ -> _" + | Default_cs -> str "_" + | Sort_cs s -> Sorts.pr_sort_family s + +end + +let rec assoc_pat env a = function + | ((pat, t), e) :: xs -> if ValuePattern.equal env pat a then (t, e) else assoc_pat env a xs + | [] -> raise Not_found + +let object_table = + Summary.ref (GlobRef.Map.empty : ((ValuePattern.t * constr) * obj_typ) list GlobRef.Map.t) + ~name:"record-canonical-structs" + +let keep_true_projections projs = + let filter { Structure.proj_true ; proj_canonical; proj_body } = if proj_true then Some (proj_body, proj_canonical) else None in + List.map_filter filter projs + let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" (fun (sign,env,t,ref,proji_sp) -> @@ -213,17 +215,17 @@ let compute_canonical_projections env ~warn (gref,ind) = let t = EConstr.Unsafe.to_constr t in let o_TABS = List.rev_map snd sign in let args = snd (decompose_app t) in - let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = - lookup_structure ind in + let { Structure.nparams = p; projections = lpj } = + Structure.find ind in let o_TPARAMS, projs = List.chop p args in let o_NPARAMS = List.length o_TPARAMS in - let lpj = keep_true_projections lpj kl in + let lpj = keep_true_projections lpj in let nenv = Termops.push_rels_assum sign env in List.fold_left2 (fun acc (spopt, canonical) t -> if canonical then Option.cata (fun proji_sp -> - match cs_pattern_of_constr nenv t with + match ValuePattern.of_constr nenv t with | patt, o_INJ, o_TCOMPS -> ((GlobRef.ConstRef proji_sp, (patt, t)), { o_ORIGIN = gref ; o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) @@ -235,13 +237,6 @@ let compute_canonical_projections env ~warn (gref,ind) = else acc ) [] lpj projs -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 - let warn_redundant_canonical_projection = CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker" (fun (hd_val,prj,new_can_s,old_can_s) -> @@ -249,26 +244,13 @@ let warn_redundant_canonical_projection = ++ strbrk " by " ++ prj ++ strbrk " in " ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) -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 env cs_pat l with - | exception Not_found -> - object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table - | _, cs -> - if warn - then - let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in - let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in - let prj = Nametab.pr_global_env Id.Set.empty proj in - let hd_val = pr_cs_pattern cs_pat in - warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) - ) +module Instance = struct -type cs = GlobRef.t * inductive +type t = GlobRef.t * inductive -let subst_canonical_structure subst (gref,ind as obj) = +let repr = fst + +let subst subst (gref,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) match gref with @@ -286,7 +268,7 @@ let error_not_structure ref description = (Id.print (Nametab.basename_of_global ref) ++ str"." ++ spc() ++ description)) -let check_and_decompose_canonical_structure env sigma ref = +let make env sigma ref = let vc = match ref with | GlobRef.ConstRef sp -> @@ -311,17 +293,71 @@ let check_and_decompose_canonical_structure env sigma ref = | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in let s = - try lookup_structure indsp + try Structure.find indsp with Not_found -> error_not_structure ref (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in - let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in - if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then + let ntrue_projs = List.count (fun { Structure.proj_true = x } -> x) s.Structure.projections in + if s.Structure.nparams + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (ref,indsp) -let lookup_canonical_conversion env (proj,pat) = - assoc_pat env pat (GlobRef.Map.find proj !object_table) +let register ~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 env cs_pat l with + | exception Not_found -> + object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table + | _, cs -> + if warn + then + let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in + let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in + let prj = Nametab.pr_global_env Id.Set.empty proj in + let hd_val = ValuePattern.print cs_pat in + warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) + ) + +end + +(** The canonical solution of a problem (proj,val) is a global + [constant = fun abs : abstractions_ty => body] and + [ body = RecodConstructor params canon_values ] and the canonical value + corresponding to val is [val cvalue_arguments]. + It is possible that val is one of the [abs] abstractions, eg [Default_cs], + and in that case [cvalue_abstraction = Some i] *) + +module CanonicalSolution = struct +type t = { + constant : EConstr.t; + + abstractions_ty : EConstr.t list; + body : EConstr.t; + + nparams : int; + params : EConstr.t list; + cvalue_abstraction : int option; + cvalue_arguments : EConstr.t list; +} + +let find env sigma (proj,pat) = + let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = assoc_pat env pat (GlobRef.Map.find proj !object_table) in + let us = List.map EConstr.of_constr us in + let params = List.map EConstr.of_constr params in + let u, ctx' = UnivGen.fresh_instance_from ctx None in + let subst = Univ.make_inverse_instance_subst u in + let c = EConstr.of_constr c in + let c' = EConstr.Vars.subst_univs_level_constr subst c in + let t' = EConstr.of_constr t' in + let t' = EConstr.Vars.subst_univs_level_constr subst t' in + let bs' = List.map (EConstr.of_constr %> EConstr.Vars.subst_univs_level_constr subst) bs in + let params = List.map (fun c -> EConstr.Vars.subst_univs_level_constr subst c) params in + let us = List.map (fun c -> EConstr.Vars.subst_univs_level_constr subst c) us in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + sigma, { body = t'; constant = c'; abstractions_ty = bs'; nparams; params; cvalue_arguments = us; cvalue_abstraction = n } + let rec get_nth n = function | [] -> raise Not_found @@ -336,12 +372,12 @@ let rec decompose_projection sigma c args = | Cast (c, _, _) -> decompose_projection sigma c args | App (c, arg) -> decompose_projection sigma c (arg :: args) | Const (c, u) -> - let n = find_projection_nparams (GlobRef.ConstRef c) in + let n = Structure.projection_nparams c in (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (GlobRef.ConstRef c) !object_table in get_nth n args | Proj (p, c) -> - let _ = GlobRef.Map.find (GlobRef.ConstRef (Projection.constant p)) !object_table in + let _ = GlobRef.Map.find (GlobRef.ConstRef (Names.Projection.constant p)) !object_table in c | _ -> raise Not_found @@ -355,3 +391,44 @@ let is_open_canonical_projection env sigma c = not (isConstruct sigma hd) with Failure _ -> false with Not_found -> false + +end + +module CSTable = struct + +type entry = { + projection : Names.GlobRef.t; + value : ValuePattern.t; + solution : Names.GlobRef.t; +} + +let canonical_entry_of_object projection ((value,_), { o_ORIGIN = solution }) = + { projection; value; solution } + +let entries () = + GlobRef.Map.fold (fun p ol acc -> + List.fold_right (fun o acc -> canonical_entry_of_object p o :: acc) ol acc) + !object_table [] + +let entries_for ~projection:p = + try + GlobRef.Map.find p !object_table |> + List.map (canonical_entry_of_object p) + with Not_found -> [] + +end + +module PrimitiveProjections = struct + +let prim_table = + Summary.ref (Cmap_env.empty : Names.Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" + +let register p c = + prim_table := Cmap_env.add c p !prim_table + +let mem c = Cmap_env.mem c !prim_table + +let find_opt c = + try Some (Cmap_env.find c !prim_table) with Not_found -> None + +end diff --git a/pretyping/structures.mli b/pretyping/structures.mli new file mode 100644 index 0000000000..05b21b1033 --- /dev/null +++ b/pretyping/structures.mli @@ -0,0 +1,162 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +(** A structure S is a non recursive inductive type with a single + constructor *) +module Structure : sig + +(** A projection to a structure field *) +type projection = { + proj_name : Names.Name.t; (** field name *) + proj_true : bool; (** false for primitive records *) + proj_canonical : bool; (** false = not to be used for CS inference *) + proj_body : Names.Constant.t option; (** the projection function *) +} + +type t = { + name : Names.inductive; + projections : projection list; + nparams : int; +} + +val make : Environ.env -> Names.inductive -> projection list -> t + +val register : t -> unit +val subst : Mod_subst.substitution -> t -> t + +(** refreshes nparams, e.g. after section discharging *) +val rebuild : Environ.env -> t -> t + +(** [find isp] returns the Structure.t associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val find : Names.inductive -> t + +(** raise [Not_found] if not a structure projection *) +val find_from_projection : Names.Constant.t -> t + +(** [lookup_projections isp] returns the projections associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val find_projections : Names.inductive -> Names.Constant.t option list + +(** raise [Not_found] if not a projection *) +val projection_nparams : Names.Constant.t -> int + +val is_projection : Names.Constant.t -> bool + +end + +(** A canonical instance declares "canonical" conversion hints between + the effective components of a structure and the projections of the + structure *) +module Instance : sig + +type t + +(** Process a record instance, checkig it can be registered as canonical. + The record type must be declared as a canonical Structure.t beforehand. *) +val make : Environ.env -> Evd.evar_map -> Names.GlobRef.t -> t + +(** Register an instance as canonical *) +val register : warn:bool -> Environ.env -> Evd.evar_map -> t -> unit + +val subst : Mod_subst.substitution -> t -> t +val repr : t -> Names.GlobRef.t + +end + + +(** A ValuePattern.t characterizes the form of a component of canonical + instance and is used to query the data base of canonical instances *) +module ValuePattern : sig + +type t = + | Const_cs of Names.GlobRef.t + | Proj_cs of Names.Projection.Repr.t + | Prod_cs + | Sort_cs of Sorts.family + | Default_cs + +val equal : Environ.env -> t -> t -> bool +val print : t -> Pp.t + +(** Return the form of the component of a canonical structure *) +val of_constr : Environ.env -> Constr.t -> t * int option * Constr.t list + +end + + +(** The canonical solution of a problem (proj,val) is a global + [constant = fun abs : abstractions_ty => body] and + [body = RecodConstructor params canon_values] and the canonical value + corresponding to val is [val cvalue_arguments]. + It is possible that val is one of the [abs] abstractions, eg [Default_cs], + and in that case [cvalue_abstraction = Some i] *) +module CanonicalSolution : sig + +type t = { + constant : EConstr.t; + + abstractions_ty : EConstr.t list; + body : EConstr.t; + + nparams : int; + params : EConstr.t list; + cvalue_abstraction : int option; + cvalue_arguments : EConstr.t list; +} + +(** [find (p,v)] returns a s such that p s = v. + The solution s gets a fresh universe instance and is decomposed into + bits for consumption by evarconv. Can raise [Not_found] on failure *) +val find : + Environ.env -> Evd.evar_map -> (Names.GlobRef.t * ValuePattern.t) -> + Evd.evar_map * t + +(** [is_open_canonical_projection env sigma t] is true if t is a FieldName + applied to term which is not a constructor. Used by evarconv not to + unfold too much and lose a projection too early *) +val is_open_canonical_projection : + Environ.env -> Evd.evar_map -> EConstr.t -> bool + +end + +(** Low level access to the Canonical Structure database *) +module CSTable : sig + +type entry = { + projection : Names.GlobRef.t; + value : ValuePattern.t; + solution : Names.GlobRef.t; +} + +(** [all] returns the list of tuples { p ; v ; s } + Note: p s = v *) +val entries : unit -> entry list + +(** [entries_for p] returns the list of canonical entries that have + p as their FieldName *) +val entries_for : projection:Names.GlobRef.t -> entry list + +end + +(** Some extra info for structures which are primitive records *) +module PrimitiveProjections : sig + +(** Sets up the mapping from constants to primitive projections *) +val register : Names.Projection.Repr.t -> Names.Constant.t -> unit + +val mem : Names.Constant.t -> bool + +val find_opt : Names.Constant.t -> Names.Projection.Repr.t option + +end diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4e89018656..b59d4b5655 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1015,12 +1015,6 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = in app_stack (redrec (c, empty_stack)) *) -let whd_simpl_stack = - if Flags.profile then - let key = CProfile.declare_profile "whd_simpl_stack" in - CProfile.profile3 key whd_simpl_stack - else whd_simpl_stack - (* Same as [whd_simpl] but also reduces constants that do not hide a reducible fix, but does this reduction of constants only until it immediately hides a non reducible fix or a cofix *) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 51b228a640..dd1d27e4c5 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -242,10 +242,6 @@ let get_solve_all_instances, solve_all_instances_hook = Hook.make () let solve_all_instances env evd filter unique split fail = Hook.get get_solve_all_instances env evd filter unique split fail -(** Profiling resolution of typeclasses *) -(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *) -(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *) - let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ()) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd diff --git a/pretyping/unification.ml b/pretyping/unification.ml index df0f49a033..43d562f77d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -22,13 +22,13 @@ open Namegen open Evd open Reduction open Reductionops +open Structures open Evarutil open Evardefine open Evarsolve open Pretype_errors open Retyping open Coercion -open Recordops open Locus open Locusops open Find_subterm @@ -509,13 +509,13 @@ let key_of env sigma b flags f = match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && (TransparentState.is_transparent_constant flags.modulo_delta cst - || Recordops.is_primitive_projection cst) -> + || PrimitiveProjections.mem cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && TransparentState.is_transparent_variable flags.modulo_delta id -> Some (IsKey (VarKey id)) - | Proj (p, c) when Projection.unfolded p + | Proj (p, c) when Names.Projection.unfolded p || (is_transparent env (ConstKey (Projection.constant p)) && (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> Some (IsProj (p, c)) @@ -1077,7 +1077,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - if is_open_canonical_projection curenv sigma cM then + if CanonicalSolution.is_open_canonical_projection curenv sigma cM then solve_canonical_projection curenvnb pb opt cM cN substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1091,7 +1091,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else try f1 () with e when precatchable_exception e -> if isApp_or_Proj sigma cN then - if is_open_canonical_projection curenv sigma cN then + if CanonicalSolution.is_open_canonical_projection curenv sigma cN then solve_canonical_projection curenvnb pb opt cN cM substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1099,12 +1099,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and solve_canonical_projection curenvnb pb opt cM cN (sigma,ms,es) = let f1l1 = whd_nored_state (fst curenvnb) sigma (cM,Stack.empty) in let f2l2 = whd_nored_state (fst curenvnb) sigma (cN,Stack.empty) in - let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (sigma,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -2070,11 +2069,5 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let w_unify env evd cv_pb flags ty1 ty2 = w_unify env evd cv_pb ~flags:flags ty1 ty2 -let w_unify = - if Flags.profile then - let wunifkey = CProfile.declare_profile "w_unify" in - CProfile.profile6 wunifkey w_unify - else w_unify - let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = w_unify env evd cv_pb flags ty1 ty2 diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index cf6d581066..9939764069 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -78,8 +78,9 @@ let type_constructor mind mib u (ctx, typ) params = -let construct_of_constr const env tag typ = - let (t, allargs) = decompose_appvect (whd_all env typ) in +let construct_of_constr const env sigma tag typ = + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, allargs = decompose_appvect (EConstr.Unsafe.to_constr typ) in match Constr.kind t with | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in @@ -92,8 +93,8 @@ let construct_of_constr const env tag typ = assert (Constr.equal t (Typeops.type_of_int env)); (mkInt (Uint63.of_int tag), t) -let construct_of_constr_const env tag typ = - fst (construct_of_constr true env tag typ) +let construct_of_constr_const env sigma tag typ = + fst (construct_of_constr true env sigma tag typ) let construct_of_constr_block = construct_of_constr false @@ -156,7 +157,7 @@ and nf_whd env sigma whd typ = let _, args = nf_args env sigma vargs t in mkApp(cfd,args) | Vconstr_const n -> - construct_of_constr_const env n typ + construct_of_constr_const env sigma n typ | Vconstr_block b -> let tag = btag b in let (tag,ofs) = @@ -165,7 +166,7 @@ and nf_whd env sigma whd typ = | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) | _ -> assert false else (tag, 0) in - let capp,ctyp = construct_of_constr_block env tag typ in + let capp,ctyp = construct_of_constr_block env sigma tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) | Vint64 i -> i |> Uint63.of_int64 |> mkInt @@ -414,9 +415,9 @@ let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); (* This evar-normalizes terms beforehand *) - let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in - let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in - let v = Vmsymtable.val_of_constr env c in + let c = EConstr.Unsafe.to_constr c in + let t = EConstr.Unsafe.to_constr t in + let v = Vmsymtable.val_of_constr env (Evd.existential_opt_value0 sigma) c in EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 44d3b44077..b529bba3f5 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -298,7 +298,7 @@ let meta_reducible_instance env evd b = if not is_coerce then irec g else u with Not_found -> u) | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> - let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in + let m = try destMeta evd c with DestKO -> destMeta evd (pi1 (destCast evd c)) (* idem *) in (match try let g, s = Metamap.find m metas in diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml index e847535aaf..68646c93c9 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -57,3 +57,22 @@ let get_default_goal_selector = ~value:(SelectNth 1) parse_goal_selector (fun v -> Pp.string_of_ppcmds @@ pr_goal_selector v) + +(* Select a subset of the goals *) +let tclSELECT ?nosuchgoal g tac = match g with + | SelectNth i -> Proofview.tclFOCUS ?nosuchgoal i i tac + | SelectList l -> Proofview.tclFOCUSLIST ?nosuchgoal l tac + | SelectId id -> Proofview.tclFOCUSID ?nosuchgoal id tac + | SelectAll -> tac + | SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if n == 1 then tac + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + let info = Exninfo.reify () in + Proofview.tclZERO ~info e diff --git a/proofs/goal_select.mli b/proofs/goal_select.mli index 977392baa6..c6726300f0 100644 --- a/proofs/goal_select.mli +++ b/proofs/goal_select.mli @@ -24,3 +24,5 @@ type t = val pr_goal_selector : t -> Pp.t val get_default_goal_selector : unit -> t + +val tclSELECT : ?nosuchgoal:'a Proofview.tactic -> t -> 'a Proofview.tactic -> 'a Proofview.tactic diff --git a/proofs/proof.ml b/proofs/proof.ml index 50a0e63700..e535536472 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -538,25 +538,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let info = Exninfo.reify () in Proofview.tclZERO ~info (SuggestNoSuchGoals (1,pr)) in - let tac = let open Goal_select in match gi with - | SelectAlreadyFocused -> - let open Proofview.Notations in - Proofview.numgoals >>= fun n -> - if n == 1 then tac - else - let e = CErrors.UserError - (None, - Pp.(str "Expected a single focused goal but " ++ - int n ++ str " goals are focused.")) - in - let info = Exninfo.reify () in - Proofview.tclZERO ~info e - - | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac - | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac - | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac - | SelectAll -> tac - in + let tac = Goal_select.tclSELECT ~nosuchgoal gi tac in let tac = if use_unification_heuristics () then Proofview.tclTHEN tac Refine.solve_constraints diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 5f19c1bb09..43cde83e58 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,9 +2,9 @@ Miscprint Goal Evar_refiner Refine +Goal_select Proof Logic -Goal_select Proof_bullet Tacmach Clenv diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index dd80ff21aa..a9f203014f 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -56,12 +56,8 @@ module Make(T : Task) () = struct type response = | Response of T.response | RespFeedback of Feedback.feedback - | RespGetCounterNewUnivLevel type request = Request of T.request - type more_data = - | MoreDataUnivLevel of UnivGen.univ_unique_id list - let slave_respond (Request r) = let res = T.perform r in Response res @@ -94,16 +90,6 @@ module Make(T : Task) () = struct with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_response: "^s) - let marshal_more_data oc (res : more_data) = - try marshal_to_channel oc res - with Failure s | Invalid_argument s | Sys_error s -> - marshal_err ("marshal_more_data: "^s) - - let unmarshal_more_data ic = - try (CThread.thread_friendly_input_value ic : more_data) - with Failure s | Invalid_argument s | Sys_error s -> - marshal_err ("unmarshal_more_data: "^s) - let report_status ?(id = !Flags.async_proofs_worker_id) s = let open Feedback in feedback ~id:Stateid.initial (WorkerStatus(id, s)) @@ -198,8 +184,6 @@ module Make(T : Task) () = struct | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in - let more_univs n = - CList.init n (fun _ -> UnivGen.new_univ_id ()) in let rec kill_if () = if not (Worker.is_alive proc) then () @@ -231,9 +215,6 @@ module Make(T : Task) () = struct marshal_request oc (Request req); let rec continue () = match unmarshal_response ic with - | RespGetCounterNewUnivLevel -> - marshal_more_data oc (MoreDataUnivLevel (more_univs 10)); - continue () | RespFeedback fbk -> T.forward_feedback fbk; continue () | Response resp -> match T.use_response !worker_age task resp with @@ -315,13 +296,6 @@ module Make(T : Task) () = struct let ic, oc = Spawned.get_channels () in slave_oc := Some oc; slave_ic := Some ic - let bufferize f = - let l = ref [] in - fun () -> - match !l with - | [] -> let data = f () in l := List.tl data; List.hd data - | x::tl -> l := tl; x - let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) @@ -339,11 +313,6 @@ module Make(T : Task) () = struct Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc) () in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); - (* We ask master to allocate universe identifiers *) - UnivGen.set_remote_new_univ_id (bufferize @@ Control.protect_sigalrm (fun () -> - marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; - match unmarshal_more_data (Option.get !slave_ic) with - | MoreDataUnivLevel l -> l)); let working = ref false in slave_handshake (); while true do diff --git a/stm/stm.ml b/stm/stm.ml index 5ed6adbd63..6287943cee 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -98,8 +98,7 @@ let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function | { doc_id = did; span_id = id; route; contents } -> - try Mutex.lock m; feedback ~did ~id ~route contents; Mutex.unlock m - with e -> Mutex.unlock m; raise e) () + CThread.with_lock m ~scope:(fun () -> feedback ~did ~id ~route contents)) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun ~doc:_ _ _ -> ()) () @@ -758,17 +757,16 @@ end = struct (* {{{ *) let worker = ref None let set_last_job j = - Mutex.lock m; - job := Some j; - Condition.signal c; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + job := Some j; + Condition.signal c) let get_last_job () = - Mutex.lock m; - while Option.is_empty !job do Condition.wait c m; done; - match !job with - | None -> assert false - | Some x -> job := None; Mutex.unlock m; x + CThread.with_lock m ~scope:(fun () -> + while Option.is_empty !job do Condition.wait c m; done; + match !job with + | None -> assert false + | Some x -> job := None; x) let run_command () = try while true do get_last_job () () done @@ -2449,24 +2447,21 @@ let join ~doc = VCS.print (); doc -let dump_snapshot () = Slaves.dump_snapshot (), RemoteCounter.snapshot () - -type tasks = int Slaves.tasks * RemoteCounter.remote_counters_status -let check_task name (tasks,rcbackup) i = - RemoteCounter.restore rcbackup; +type tasks = int Slaves.tasks +let check_task name tasks i = let vcs = VCS.backup () in try let rc = State.purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false -let info_tasks (tasks,_) = Slaves.info_tasks tasks -let finish_tasks name u p (t,rcbackup as tasks) = - RemoteCounter.restore rcbackup; +let info_tasks = Slaves.info_tasks + +let finish_tasks name u p tasks = let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = State.purify (Slaves.finish_task name u p t) i in + let u = State.purify (Slaves.finish_task name u p tasks) i in VCS.restore vcs; u in try @@ -2517,13 +2512,13 @@ let snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_vo = CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); (* LATER: when create_vos is true, it could be more efficient to not allocate the futures; but for now it seems useful for synchronization of the workers, below, [snapshot] gets computed even if [create_vos] is true. *) - let (tasks,counters) = dump_snapshot() in + let tasks = Slaves.dump_snapshot() in let except = List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty tasks in let todo_proofs = if create_vos then Library.ProofsTodoSomeEmpty except - else Library.ProofsTodoSome (except,tasks,counters) + else Library.ProofsTodoSome (except,tasks) in Library.save_library_to todo_proofs ~output_native_objects ldir long_f_dot_vo (Global.opaque_tables ()); doc @@ -2565,8 +2560,8 @@ let get_allow_nested_proofs = ~value:false (** [process_transaction] adds a node in the document *) -let process_transaction ~doc ?(newtip=Stateid.fresh ()) - ({ verbose; expr } as x) c = +let process_transaction ~doc ?(newtip=Stateid.fresh ()) x c = + let { verbose; expr } = x in stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try diff --git a/stm/tQueue.ml b/stm/tQueue.ml index e17c3a2f88..f5bd726dde 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -27,21 +27,23 @@ end = struct let create () = ref ([],sort_timestamp) let is_empty t = fst !t = [] let exists p t = List.exists (fun (_,x) -> p x) (fst !t) - let pop ?(picky=(fun _ -> true)) ({ contents = (l, rel) } as t) = + let pop ?(picky=(fun _ -> true)) t = + let (l, rel) = !t in let rec aux acc = function | [] -> raise Queue.Empty | (_,x) :: xs when picky x -> t := (List.rev acc @ xs, rel); x | (_,x) as hd :: xs -> aux (hd :: acc) xs in aux [] l - let push ({ contents = (xs, rel) } as t) x = + let push t x = + let (xs, rel) = !t in incr age; (* re-roting the whole list is not the most efficient way... *) t := (List.sort rel (xs @ [!age,x]), rel) - let clear ({ contents = (l, rel) } as t) = t := ([], rel) - let set_rel rel ({ contents = (xs, _) } as t) = + let clear t = t := ([], snd !t) + let set_rel rel t = let rel (_,x) (_,y) = rel x y in - t := (List.sort rel xs, rel) - let length ({ contents = (l, _) }) = List.length l + t := (List.sort rel (fst !t), rel) + let length t = List.length (fst !t) end type 'a t = { @@ -64,92 +66,85 @@ let create () = { release = false; } -let pop ?(picky=(fun _ -> true)) ?(destroy=ref false) - ({ queue = q; lock = m; cond = c; cond_waiting = cn } as tq) -= - Mutex.lock m; - if tq.release then (Mutex.unlock m; raise BeingDestroyed); - while not (PriorityQueue.exists picky q || !destroy) do - tq.nwaiting <- tq.nwaiting + 1; - Condition.broadcast cn; - Condition.wait c m; - tq.nwaiting <- tq.nwaiting - 1; - if tq.release || !destroy then (Mutex.unlock m; raise BeingDestroyed) - done; - if !destroy then (Mutex.unlock m; raise BeingDestroyed); - let x = PriorityQueue.pop ~picky q in - Condition.signal c; - Condition.signal cn; - Mutex.unlock m; - x +let pop ?(picky=(fun _ -> true)) ?(destroy=ref false) tq = + let { queue = q; lock = m; cond = c; cond_waiting = cn } = tq in + CThread.with_lock m ~scope:(fun () -> + if tq.release then raise BeingDestroyed; + while not (PriorityQueue.exists picky q || !destroy) do + tq.nwaiting <- tq.nwaiting + 1; + Condition.broadcast cn; + Condition.wait c m; + tq.nwaiting <- tq.nwaiting - 1; + if tq.release || !destroy then raise BeingDestroyed + done; + if !destroy then raise BeingDestroyed; + let x = PriorityQueue.pop ~picky q in + Condition.signal c; + Condition.signal cn; + x) -let broadcast { lock = m; cond = c } = - Mutex.lock m; - Condition.broadcast c; - Mutex.unlock m +let broadcast tq = + let { lock = m; cond = c } = tq in + CThread.with_lock m ~scope:(fun () -> + Condition.broadcast c) -let push { queue = q; lock = m; cond = c; release } x = +let push tq x = + let { queue = q; lock = m; cond = c; release } = tq in if release then CErrors.anomaly(Pp.str "TQueue.push while being destroyed! Only 1 producer/destroyer allowed."); - Mutex.lock m; - PriorityQueue.push q x; - Condition.broadcast c; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.push q x; + Condition.broadcast c) -let length { queue = q; lock = m } = - Mutex.lock m; - let n = PriorityQueue.length q in - Mutex.unlock m; - n +let length tq = + let { queue = q; lock = m } = tq in + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.length q) -let clear { queue = q; lock = m; cond = c } = - Mutex.lock m; - PriorityQueue.clear q; - Mutex.unlock m +let clear tq = + let { queue = q; lock = m; cond = c } = tq in + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.clear q) -let clear_saving { queue = q; lock = m; cond = c } f = - Mutex.lock m; +let clear_saving tq f = + let { queue = q; lock = m; cond = c } = tq in let saved = ref [] in - while not (PriorityQueue.is_empty q) do - let elem = PriorityQueue.pop q in - match f elem with - | Some x -> saved := x :: !saved - | None -> () - done; - Mutex.unlock m; + CThread.with_lock m ~scope:(fun () -> + while not (PriorityQueue.is_empty q) do + let elem = PriorityQueue.pop q in + match f elem with + | Some x -> saved := x :: !saved + | None -> () + done); List.rev !saved -let is_empty { queue = q } = PriorityQueue.is_empty q +let is_empty tq = PriorityQueue.is_empty tq.queue let destroy tq = tq.release <- true; while tq.nwaiting > 0 do - Mutex.lock tq.lock; - Condition.broadcast tq.cond; - Mutex.unlock tq.lock; + CThread.with_lock tq.lock ~scope:(fun () -> + Condition.broadcast tq.cond) done; tq.release <- false let wait_until_n_are_waiting_and_queue_empty j tq = - Mutex.lock tq.lock; - while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do - Condition.wait tq.cond_waiting tq.lock - done; - Mutex.unlock tq.lock + CThread.with_lock tq.lock ~scope:(fun () -> + while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do + Condition.wait tq.cond_waiting tq.lock + done) let wait_until_n_are_waiting_then_snapshot j tq = let l = ref [] in - Mutex.lock tq.lock; - while not (PriorityQueue.is_empty tq.queue) do - l := PriorityQueue.pop tq.queue :: !l - done; - while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; - List.iter (PriorityQueue.push tq.queue) (List.rev !l); - if !l <> [] then Condition.broadcast tq.cond; - Mutex.unlock tq.lock; + CThread.with_lock tq.lock ~scope:(fun () -> + while not (PriorityQueue.is_empty tq.queue) do + l := PriorityQueue.pop tq.queue :: !l + done; + while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; + List.iter (PriorityQueue.push tq.queue) (List.rev !l); + if !l <> [] then Condition.broadcast tq.cond); List.rev !l let set_order tq rel = - Mutex.lock tq.lock; - PriorityQueue.set_rel rel tq.queue; - Mutex.unlock tq.lock + CThread.with_lock tq.lock ~scope:(fun () -> + PriorityQueue.set_rel rel tq.queue) diff --git a/stm/workerPool.ml b/stm/workerPool.ml index 45c92c3748..fef9300377 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -72,12 +72,7 @@ let worker_handshake slave_ic slave_oc = exit 1 let locking { lock; pool = p } f = - try - Mutex.lock lock; - let x = f p in - Mutex.unlock lock; - x - with e -> Mutex.unlock lock; raise e + CThread.with_lock lock ~scope:(fun () -> f p) let rec create_worker extra pool priority id = let cancel = ref false in diff --git a/sysinit/usage.ml b/sysinit/usage.ml index d00b916f23..5886b1c5b5 100644 --- a/sysinit/usage.ml +++ b/sysinit/usage.ml @@ -73,8 +73,6 @@ let print_usage_common co command = \n -debug debug mode (implies -bt)\ \n -xml-debug debug mode and print XML messages to/from coqide\ \n -diffs (on|off|removed) highlight differences between proof steps\ -\n -noglob do not dump globalizations\ -\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ \n -allow-sprop allow using the proof irrelevant SProp sort\ \n -disallow-sprop forbid using the proof irrelevant SProp sort\ diff --git a/tactics/auto.ml b/tactics/auto.ml index 353e138599..0189e3ab04 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -500,12 +500,6 @@ let delta_auto debug mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let delta_auto = - if Flags.profile then - let key = CProfile.declare_profile "delta_auto" in - CProfile.profile5 key delta_auto - else delta_auto - let auto ?(debug=Off) n = delta_auto debug false n let new_auto ?(debug=Off) n = delta_auto debug true n diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index af0ca22868..794d2bb94f 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -32,18 +32,25 @@ let compare_term_label t1 t2 = match t1, t2 with type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything -let decomp_pat = +let decomp_pat p = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f - | PProj (p, c) -> (PRef (GlobRef.ConstRef (Projection.constant p)), c :: acc) + | PProj (p, c) -> + let hole = PMeta None in + let params = List.make (Projection.npars p) hole in + (PRef (GlobRef.ConstRef (Projection.constant p)), params @ c :: acc) | c -> (c,acc) in - decrec [] + decrec [] p let decomp sigma t = let rec decrec acc c = match EConstr.kind sigma c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f - | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) + | Proj (p, c) -> + (* Hack: fake evar to generate [Everything] in the functions below *) + let hole = mkEvar (Evar.unsafe_of_int (-1), []) in + let params = List.make (Projection.npars p) hole in + (mkConst (Projection.constant p), params @ c :: acc) | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 167f7d4026..c3c61f6e51 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -402,11 +402,11 @@ let safe_meta_value sigma ev = (* Beta Reduction tools *) -let apply_subst recfun env sigma refold cst_l t stack = +let apply_subst recfun env sigma cst_l t stack = let rec aux env cst_l t stack = match (Stack.decomp stack, EConstr.kind sigma t) with | Some (h,stacktl), Lambda (_,_,c) -> - let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in + let cst_l' = Cst_stack.add_param h cst_l in aux (h::env) cst_l' c stacktl | _ -> recfun sigma cst_l (substl env t, stack) in aux env cst_l t stack @@ -453,50 +453,42 @@ let magically_constant_of_fixbody env sigma reference bd = function | None -> bd end -let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = +let contract_cofix env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = let nbodies = Array.length bodies in let make_Fi j = let ind = nbodies-j-1 in if Int.equal bodynum ind then mkCoFix (ind,typedbodies) else let bd = mkCoFix (ind,typedbodies) in - match env with + match reference with | None -> bd - | Some e -> - match reference with - | None -> bd - | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody env sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) (** Similar to the "fix" case below *) -let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = +let reduce_and_refold_cofix recfun env sigma cst_l cofix sk = let raw_answer = - let env = if refold then Some env else None in - contract_cofix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in + contract_cofix env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in apply_subst (fun sigma x (t,sk') -> - let t' = - if refold then Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t else t in + let t' = Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t in recfun x (t',sk')) - [] sigma refold Cst_stack.empty raw_answer sk + [] sigma Cst_stack.empty raw_answer sk (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) -let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = +let contract_fix env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = let nbodies = Array.length recindices in let make_Fi j = let ind = nbodies-j-1 in if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies) else let bd = mkFix ((recindices,ind),typedbodies) in - match env with + match reference with | None -> bd - | Some e -> - match reference with - | None -> bd - | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody env sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -504,18 +496,14 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies replace the fixpoint by the best constant from [cst_l] Other rels are directly substituted by constants "magically found from the context" in contract_fix *) -let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = +let reduce_and_refold_fix recfun env sigma cst_l fix sk = let raw_answer = - let env = if refold then Some env else None in - contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in + contract_fix env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in apply_subst (fun sigma x (t,sk') -> - let t' = - if refold then - Cst_stack.best_replace sigma (mkFix fix) cst_l t - else t - in recfun x (t',sk')) - [] sigma refold Cst_stack.empty raw_answer sk + let t' = Cst_stack.best_replace sigma (mkFix fix) cst_l t in + recfun x (t',sk')) + [] sigma Cst_stack.empty raw_answer sk module CredNative = Reductionops.CredNative @@ -524,7 +512,7 @@ module CredNative = Reductionops.CredNative Here is where unfolded constant are stored in order to be eventually refolded. - If tactic_mode is true, it uses ReductionBehaviour, prefers + It uses ReductionBehaviour, prefers refold constant instead of value and tries to infer constants fix and cofix came from. @@ -558,7 +546,7 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = in Vars.substl subst (snd br) -let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = +let rec whd_state_gen ?csts flags env sigma = let open Context.Named.Declaration in let open ReductionBehaviour in let rec whrec cst_l (x, stack) = @@ -584,7 +572,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with | LocalDef (_,body,_) -> - whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) + whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) | _ -> fold ()) | Evar ev -> fold () | Meta ev -> @@ -600,10 +588,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | body -> begin let body = EConstr.of_constr body in - if not tactic_mode - then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) - (body, stack) - else (* Looks for ReductionBehaviour *) + (* Looks for ReductionBehaviour *) match ReductionBehaviour.get (GlobRef.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some behavior -> @@ -652,10 +637,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in - if not tactic_mode then - let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in - whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (GlobRef.ConstRef (Projection.constant p)) with + match ReductionBehaviour.get (GlobRef.ConstRef (Projection.constant p)) with | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in @@ -693,24 +675,24 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = end) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> - apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack + apply_subst (fun _ -> whrec) [b] sigma cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) | App (f,cl) -> whrec - (if refold then Cst_stack.add_args cl cst_l else cst_l) + (Cst_stack.add_args cl cst_l) (f, Stack.append_app cl stack) | Lambda (na,t,c) -> (match Stack.decomp stack with | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack + apply_subst (fun _ -> whrec) [] sigma cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> let env' = push_rel (LocalAssum (na, t)) env in - let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in - (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with + let whrec' = whd_state_gen flags env' sigma in + (match EConstr.kind sigma (Stack.zip ~refold:true sigma (whrec' (c, Stack.empty))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then - let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in + let (x', l') = whrec' (Array.last cl, Stack.empty) in match EConstr.kind sigma x', l' with | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in @@ -743,7 +725,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let x' = Stack.zip sigma (x, args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in - reduce_and_refold_fix whrec env sigma refold cst_l f out_sk + reduce_and_refold_fix whrec env sigma cst_l f out_sk |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> let x' = Stack.zip sigma (x, args) in begin match remains with @@ -755,7 +737,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some body -> let const = (fst const, EInstance.make (snd const)) in let body = EConstr.of_constr body in - whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) | Stack.Cst_proj p -> let stack = s' @ (Stack.append_app [|x'|] s'') in @@ -778,7 +760,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then match Stack.strip_app stack with |args, ((Stack.Case _ |Stack.Proj _)::s') -> - reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack + reduce_and_refold_cofix whrec env sigma cst_l cofix stack |_ -> fold () else fold () @@ -812,12 +794,10 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = in fun xs -> let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in - if tactic_mode then (Stack.best_state sigma s cst_l,Cst_stack.empty) else res + (Stack.best_state sigma s cst_l) let whd_cbn flags env sigma t = - let (state,_) = - (whd_state_gen ~refold:true ~tactic_mode:true flags env sigma (t, Stack.empty)) - in + let state = whd_state_gen flags env sigma (t, Stack.empty) in Stack.zip ~refold:true sigma state let norm_cbn flags env sigma t = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 20c557b282..5df9fab236 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -359,9 +359,6 @@ let e_search_auto debug (in_depth,p) lems db_list = tclIDTAC gl end -(* let e_search_auto_key = CProfile.declare_profile "e_search_auto" *) -(* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) - let eauto_with_bases ?(debug=Off) np lems db_list = Hints.wrap_hint_warning (e_search_auto debug np lems db_list) diff --git a/tactics/hints.ml b/tactics/hints.ml index 5e9c3baeb1..31b276bb3e 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -320,7 +320,7 @@ let strip_params env sigma c = | App (f, args) -> (match EConstr.kind sigma f with | Const (cst,_) -> - (match Recordops.find_primitive_projection cst with + (match Structures.PrimitiveProjections.find_opt cst with | Some p -> let p = Projection.make p false in let npars = Projection.npars p in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 5338e0eef5..783a317b3a 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -293,31 +293,34 @@ let match_with_equation env sigma t = let (hdapp,args) = destApp sigma t in match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if Coqlib.check_ind_ref "core.eq.type" ind then - Some (build_coq_eq_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if Coqlib.check_ind_ref "core.identity.type" ind then - Some (build_coq_identity_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if Coqlib.check_ind_ref "core.JMeq.type" ind then - Some (build_coq_jmeq_data()),hdapp, - HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else - let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in - let nconstr = Array.length mip.mind_consnames in - if Int.equal nconstr 1 then - let (ctx, cty) = constr_types.(0) in - let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in - if is_matching env sigma coq_refl_leibniz1_pattern cty then - None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching env sigma coq_refl_leibniz2_pattern cty then - None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching env sigma coq_refl_jm_pattern cty then - None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else raise NoEquationFound - else raise NoEquationFound - | _ -> raise NoEquationFound + (try + if Coqlib.check_ind_ref "core.eq.type" ind then + Some (build_coq_eq_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.identity.type" ind then + Some (build_coq_identity_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.JMeq.type" ind then + Some (build_coq_jmeq_data()),hdapp, + HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in + if Int.equal nconstr 1 then + let (ctx, cty) = constr_types.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + if is_matching env sigma coq_refl_leibniz1_pattern cty then + None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) + else if is_matching env sigma coq_refl_leibniz2_pattern cty then + None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if is_matching env sigma coq_refl_jm_pattern cty then + None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else raise NoEquationFound + else raise NoEquationFound + with UserError _ -> + raise NoEquationFound) + | _ -> raise NoEquationFound (* Note: An "equality type" is any type with a single argument-free constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 68afd9a128..2d69047d1e 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -683,15 +683,6 @@ module New = struct let tclPROGRESS t = Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t) - (* Select a subset of the goals *) - let tclSELECT = let open Goal_select in function - | SelectNth i -> Proofview.tclFOCUS i i - | SelectList l -> Proofview.tclFOCUSLIST l - | SelectId id -> Proofview.tclFOCUSID id - | SelectAll -> anomaly ~label:"tclSELECT" Pp.(str "SelectAll not allowed here") - | SelectAlreadyFocused -> - anomaly ~label:"tclSELECT" Pp.(str "SelectAlreadyFocused not allowed here") - (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma origsigma = @@ -905,4 +896,6 @@ module New = struct let (sigma, t) = Typing.type_of ?refresh env sigma c in Proofview.Unsafe.tclEVARS sigma <*> tac sigma t) + let tclSELECT = Goal_select.tclSELECT + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 19d08dcc36..c09d268c40 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -206,7 +206,6 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic - val tclSELECT : Goal_select.t -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic val tclMAPDELAYEDWITHHOLES : bool -> 'a delayed_open list -> ('a -> unit tactic) -> unit tactic @@ -250,4 +249,7 @@ module New : sig val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic val tclTYPEOFTHEN : ?refresh:bool -> constr -> (evar_map -> types -> unit Proofview.tactic) -> unit Proofview.tactic + + val tclSELECT : ?nosuchgoal:'a tactic -> Goal_select.t -> 'a tactic -> 'a tactic + [@@ocaml.deprecated "Use [Goal_select.tclSELECT]"] end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index cbf12ac22f..c24520b371 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1555,7 +1555,7 @@ let make_projection env sigma params cstr sign elim i n c u = | Some proj -> let args = Context.Rel.to_extended_vect mkRel 0 sign in let proj = - match Recordops.find_primitive_projection proj with + match Structures.PrimitiveProjections.find_opt proj with | Some proj -> mkProj (Projection.make proj false, mkApp (c, args)) | None -> @@ -1585,7 +1585,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let params = List.map EConstr.of_constr params in let cstr = (get_constructors env indf).(0) in let elim = - try DefinedRecord (Recordops.lookup_projections ind) + try DefinedRecord (Structures.Structure.find_projections ind) with Not_found -> let u = EInstance.kind sigma u in let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in @@ -1886,12 +1886,6 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) -(* let convert_leqkey = CProfile.declare_profile "convert_leq";; *) -(* let convert_leq = CProfile.profile3 convert_leqkey convert_leq *) - -(* let refine_no_checkkey = CProfile.declare_profile "refine_no_check";; *) -(* let refine_no_check = CProfile.profile2 refine_no_checkkey refine_no_check *) - let exact_no_check c = Refine.refine ~typecheck:false (fun h -> (h,c)) @@ -2796,7 +2790,24 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum sigma i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in + let newdecls,_ = + let c = Termops.collapse_appl sigma c in + let arity = Array.length (snd (Termops.decompose_app_vect sigma c)) in + let cache = ref Int.Map.empty in + let eq sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c + in + (* We use a nounivs equality because generalize morally takes a pattern as + argument, so we have to ignore freshly generated sorts. *) + EConstr.eq_constr_nounivs sigma c t + in + decompose_prod_n_assum sigma i (replace_term_gen sigma eq arity (mkRel 1) dummy_prod) + in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name env sigma c t ids cl' na in let r = Retyping.relevance_of_type env sigma t in diff --git a/test-suite/bugs/closed/bug_12806.v b/test-suite/bugs/closed/bug_12806.v new file mode 100644 index 0000000000..ee221d33a6 --- /dev/null +++ b/test-suite/bugs/closed/bug_12806.v @@ -0,0 +1,9 @@ +Require Import Ltac2.Ltac2. + +Declare Scope my_scope. +Delimit Scope my_scope with my_scope. + +Notation "###" := tt : my_scope. + +Ltac2 Notation "bar" c(open_constr(my_scope)) := c. +Ltac2 Eval bar ###. diff --git a/test-suite/bugs/closed/bug_13581.v b/test-suite/bugs/closed/bug_13581.v new file mode 100644 index 0000000000..910537cf11 --- /dev/null +++ b/test-suite/bugs/closed/bug_13581.v @@ -0,0 +1,60 @@ +From Coq Require Extraction. + +Record mixin_of T0 (b : unit) (T := T0) := Mixin { _ : T0 -> let U:=T0 in U }. +Definition d := Mixin nat tt (fun x => x). + +Extraction TestCompile d. + +(* Extra tests *) + +Record R T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := Build + { g : T0 -> let U:=T0 in U ; h : d = d ; x : nat ; y := x+x }. + +Definition r := {| g := (fun x : nat => x) ; h := eq_refl (eq_refl 0) ; x := 0 |}. + +Extraction TestCompile r. +(* +(** val r0 : nat r **) + +let r0 = + { g = (fun x0 -> x0); x = O } +*) + +Inductive I T (a:T) (U:=T) (b:T) (c:=(a,b)) : forall d (e:=S d) (h : S d = e), Type := +| C : I T a b 0 eq_refl +| D : J T a b true eq_refl -> I T a b 1 eq_refl +with J T (a:T) (U:=T) (b:T) (c:=(a,b)) : forall (d:bool) (h:d = true), Type := +| E : I T a b 0 eq_refl -> J T a b true eq_refl. + +Definition c := D _ _ _ (E _ _ _ (C nat 0 0)). + +Extraction TestCompile c. + +(* +(** val c : nat i **) + +let c = + D (E C) +*) + +CoInductive V T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := + { k : T; b := c+e ; m : nat; z : option (W nat 0 0 eq_refl) } +with W T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := + { l : V nat 0 0 eq_refl }. + +CoFixpoint v := + {| k := 0 ; m := 0 ; z := Some w ; |} +with w := {| l := v |}. + +Extraction TestCompile v. +(* +(** val v0 : nat v **) + +let rec v0 = + lazy (Build_V (O, O, (Some w0))) + +(** val w0 : nat w **) + +and w0 = + lazy (Build_W v0) +*) diff --git a/test-suite/bugs/closed/bug_1362.v b/test-suite/bugs/closed/bug_1362.v index 6cafb9f0cd..18b8d743b3 100644 --- a/test-suite/bugs/closed/bug_1362.v +++ b/test-suite/bugs/closed/bug_1362.v @@ -1,26 +1,17 @@ (** Omega is now aware of the bodies of context variables (of type Z or nat). *) -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z. Goal let x := 3 in x = 3. intros. -omega. +lia. Qed. Open Scope nat. Goal let x := 2 in x = 2. intros. -omega. +lia. Qed. - -(** NB: this could be disabled for compatibility reasons *) - -Unset Omega UseLocalDefs. - -Goal let x := 4 in x = 4. -intros. -Fail omega. -Abort. diff --git a/test-suite/bugs/closed/bug_13841.v b/test-suite/bugs/closed/bug_13841.v new file mode 100644 index 0000000000..60fca8b49c --- /dev/null +++ b/test-suite/bugs/closed/bug_13841.v @@ -0,0 +1,11 @@ +Goal True. +evar (p : bool). +unify ?p true. +let v := eval vm_compute in (orb p false) in +match v with true => idtac end. +assert (orb p false = true). +vm_compute. +match goal with |- true = _ => idtac end. +easy. +easy. +Qed. diff --git a/test-suite/bugs/closed/bug_13896.v b/test-suite/bugs/closed/bug_13896.v new file mode 100644 index 0000000000..10f24d8564 --- /dev/null +++ b/test-suite/bugs/closed/bug_13896.v @@ -0,0 +1,24 @@ +Inductive type : Set := + Tptr : type -> type + | Tref : type -> type + | Trv_ref : type -> type + | Tint : type -> type -> type + | Tvoid : type + | Tarray : type -> type -> type + | Tnamed : type -> type + | Tfunction : type -> type -> type -> type + | Tbool : type + | Tmember_pointer : type -> type -> type + | Tfloat : type -> type + | Tqualified : type -> type -> type + | Tnullptr : type + | Tarch : type -> type -> type +. +Definition type_eq_dec : forall (ty1 ty2 : type), { ty1 = ty2 } + { ty1 <> ty2 }. +Proof. fix IHty1 1. decide equality. Defined. + +Goal (if type_eq_dec (Tptr Tvoid) (Tptr Tvoid) then True else False). +Proof. +timeout 1 cbn. +constructor. +Qed. diff --git a/test-suite/bugs/closed/bug_13903.v b/test-suite/bugs/closed/bug_13903.v new file mode 100644 index 0000000000..7c1820b85c --- /dev/null +++ b/test-suite/bugs/closed/bug_13903.v @@ -0,0 +1,5 @@ +Section test. +Variables (T : Type) (x : T). +#[using="x"] Definition test : unit := tt. +End test. +Check test : forall T, T -> unit. diff --git a/test-suite/bugs/closed/bug_13960.v b/test-suite/bugs/closed/bug_13960.v new file mode 100644 index 0000000000..947db9586f --- /dev/null +++ b/test-suite/bugs/closed/bug_13960.v @@ -0,0 +1,10 @@ +Require Ltac2.Ltac2. + +Set Default Goal Selector "!". + +Ltac2 t () := let _ := Message.print (Message.of_string "hi") in 42. + +Goal False. +Proof. +Ltac2 Eval t (). +Abort. diff --git a/test-suite/bugs/closed/bug_14003.v b/test-suite/bugs/closed/bug_14003.v new file mode 100644 index 0000000000..9e7055045d --- /dev/null +++ b/test-suite/bugs/closed/bug_14003.v @@ -0,0 +1,19 @@ +Require Import Ltac2.Ltac2. + +Module Foo. + +Ltac2 foo := (). +Ltac2 Type bar := [ BAR ]. +Ltac2 Type quz := [ .. ]. +Ltac2 Type quz ::= [ QUZ ]. + +End Foo. + +Import Foo. + +(* Check that redeclaration checks are based on absolute names *) + +Ltac2 foo := (). +Ltac2 Type bar := [ ]. +Ltac2 Type qux := [ BAR ]. +Ltac2 Type quz ::= [ QUZ ]. diff --git a/test-suite/bugs/closed/bug_14006.v b/test-suite/bugs/closed/bug_14006.v new file mode 100644 index 0000000000..b857959ae9 --- /dev/null +++ b/test-suite/bugs/closed/bug_14006.v @@ -0,0 +1,3 @@ +From Coq Require Import Int63 PArray. +Definition t : array nat := [| 1; 3; 2 | 4 |]. +Definition vm_accu_set v := Eval vm_compute in t.[1 <- v]. diff --git a/test-suite/bugs/closed/bug_14009.v b/test-suite/bugs/closed/bug_14009.v new file mode 100644 index 0000000000..bf86f5117e --- /dev/null +++ b/test-suite/bugs/closed/bug_14009.v @@ -0,0 +1,16 @@ +Class Bin {P:Type} (A B : P) := {}. + +Set Primitive Projections. + +Record test (n : nat) := { proj : Prop }. +Axiom Bin_test : forall {t1 t2 : test O}, Bin (proj _ t1) (proj _ t2). + +Create HintDb db discriminated. +#[local] Hint Resolve Bin_test : db. +#[local] Hint Opaque proj : db. + +Goal forall t1 t2 : test O, Bin (proj O t1) (proj O t2). +Proof. +intros. +solve [typeclasses eauto with db]. +Qed. diff --git a/test-suite/bugs/closed/bug_14011.v b/test-suite/bugs/closed/bug_14011.v new file mode 100644 index 0000000000..ccbeca792d --- /dev/null +++ b/test-suite/bugs/closed/bug_14011.v @@ -0,0 +1,32 @@ +(** Test that Ltac2 Array.init doesn't compute the first argument twice, and has the correct asymptotics when nested *) +Require Import Ltac2.Ltac2. + +(** Non-performance-based test *) +Ltac2 foo () := + let x := { contents := 0 } in + let _ := Array.init 1 (fun _ => x.(contents) := Int.add 1 (x.(contents))) in + Control.assert_true (Int.equal 1 (x.(contents))). + +Ltac2 Eval foo (). + +Ltac2 Type rec singleton := [ Single (int) | Arr (singleton array) ]. +Ltac2 rec init_rec (n : int) := + match Int.equal n 0 with + | true => Single 0 + | false => Arr (Array.init 1 (fun _ => init_rec (Int.sub n 1))) + end. +Ltac2 rec timing (n : int) := + (match Int.equal n 0 with + | true => () + | false => timing (Int.sub n 1) + end; + Message.print (Message.concat (Message.of_int n) (Message.of_string ": ")); + let _ := Control.time None (fun _ => init_rec n) in + ()). +(** Should take less than 0.1 seconds if the asymptotics are correct. +Previous behavior was to take an expected 1 million times the age of +the universe. Capping the time at 100 seconds seems like a reasonable +middle ground between these times, as I expect that compilation of Coq +itself will not finish in reasonable time if the computer is running +1000x slower than modern machines. *) +Timeout 100 Ltac2 Eval timing 100. diff --git a/test-suite/bugs/closed/bug_1912.v b/test-suite/bugs/closed/bug_1912.v index 0228abbb9b..9f6c8177f6 100644 --- a/test-suite/bugs/closed/bug_1912.v +++ b/test-suite/bugs/closed/bug_1912.v @@ -1,6 +1,6 @@ -Require Import Omega. +Require Import Lia ZArith. Goal forall x, Z.succ (Z.pred x) = x. intros x. -omega. +lia. Qed. diff --git a/test-suite/bugs/closed/bug_4132.v b/test-suite/bugs/closed/bug_4132.v index 67ecc3087f..2ebbb66758 100644 --- a/test-suite/bugs/closed/bug_4132.v +++ b/test-suite/bugs/closed/bug_4132.v @@ -1,5 +1,5 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z_scope. (** bug 4132: omega was using "simpl" either on whole equations, or on @@ -14,18 +14,18 @@ Lemma foo (H : - zxy' <= zxy) (H' : zxy' <= x') : - b <= zxy. Proof. -omega. (* was: Uncaught exception Invalid_argument("index out of bounds"). *) +lia. (* was: Uncaught exception Invalid_argument("index out of bounds"). *) Qed. Lemma foo2 x y (b := 5) (H1 : x <= y) (H2 : y <= b) : x <= b. -omega. (* Pierre L: according to a comment of bug report #4132, +lia. (* Pierre L: according to a comment of bug report #4132, this might have triggered "index out of bounds" in the past, but I never managed to reproduce that in any version, even before my fix. *) Qed. Lemma foo3 x y (b := 0) (H1 : x <= y) (H2 : y <= b) : x <= b. -omega. (* Pierre L: according to a comment of bug report #4132, +lia. (* Pierre L: according to a comment of bug report #4132, this might have triggered "Failure(occurrence 2)" in the past, but I never managed to reproduce that. *) Qed. diff --git a/test-suite/bugs/closed/bug_4717.v b/test-suite/bugs/closed/bug_4717.v index bd9bac37ef..81bc70d076 100644 --- a/test-suite/bugs/closed/bug_4717.v +++ b/test-suite/bugs/closed/bug_4717.v @@ -1,6 +1,6 @@ (* Omega being smarter on recognizing nat and Z *) -Require Import Omega. +Require Import Lia ZArith. Definition nat' := nat. @@ -10,13 +10,13 @@ Theorem le_not_eq_lt : forall (n m:nat), n < m. Proof. intros. - omega. + lia. Qed. Goal forall (x n : nat'), x = x + n - n. Proof. intros. - omega. + lia. Qed. Open Scope Z_scope. @@ -29,5 +29,5 @@ Theorem Zle_not_eq_lt : forall n m, n < m. Proof. intros. - omega. + lia. Qed. diff --git a/test-suite/bugs/closed/bug_7631.v b/test-suite/bugs/closed/bug_7631.v index 93aeb83e28..14ab4de9b7 100644 --- a/test-suite/bugs/closed/bug_7631.v +++ b/test-suite/bugs/closed/bug_7631.v @@ -21,3 +21,9 @@ Definition bar (x := foo) := Eval native_compute in x. Definition barvm (x := foo) := Eval vm_compute in x. End RelContext. + +Definition bar (t:=_) (x := true : t) := Eval native_compute in x. +Definition barvm (t:=_) (x := true : t) := Eval vm_compute in x. + +Definition baz (z:nat) (t:=_ z) (x := true : t) := Eval native_compute in x. +Definition bazvm (z:nat) (t:=_ z) (x := true : t) := Eval vm_compute in x. diff --git a/test-suite/bugs/closed/bug_9000.v b/test-suite/bugs/closed/bug_9000.v new file mode 100644 index 0000000000..e239c8b1fe --- /dev/null +++ b/test-suite/bugs/closed/bug_9000.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Class type (t : Type) : Type := + { bar : t -> Prop }. + +Instance type_nat : type nat := + { bar := fun _ => True }. + +Definition foo_bar {n : nat} : bar n := I. + +#[local] Hint Resolve (@foo_bar) : typeclass_instances. +#[local] Hint Resolve I : typeclass_instances. +Check ltac:(typeclasses eauto with nocore typeclass_instances) : True. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. +Existing Class bar. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. +#[local] Hint Resolve (@foo_bar) : foo. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. diff --git a/test-suite/bugs/closed/bug_9512.v b/test-suite/bugs/closed/bug_9512.v index bad9d64f65..f42e32cf25 100644 --- a/test-suite/bugs/closed/bug_9512.v +++ b/test-suite/bugs/closed/bug_9512.v @@ -1,4 +1,4 @@ -Require Import Coq.ZArith.BinInt Coq.omega.Omega Coq.micromega.Lia. +Require Import Coq.ZArith.BinInt Coq.micromega.Lia. Set Primitive Projections. Record params := { width : Z }. @@ -10,7 +10,6 @@ Set Printing All. Lemma foo : width p = 0%Z -> width p = 0%Z. intros. - assert_succeeds (enough True; [omega|]). assert_succeeds (enough True; [lia|]). (* H : @eq Z (width p) Z0 *) @@ -26,12 +25,6 @@ Lemma foo : width p = 0%Z -> width p = 0%Z. (* @eq Z (width p) Z0 *) assert_succeeds (enough True; [lia|]). - (* Tactic failure: <tactic closure> fails. *) - (* assert_succeeds (enough True; [omega|]). *) - (* Tactic failure: <tactic closure> fails. *) - - (* omega. *) - (* Error: Omega can't solve this system *) lia. (* Tactic failure: Cannot find witness. *) diff --git a/test-suite/bugs/opened/bug_1615.v b/test-suite/bugs/opened/bug_1615.v deleted file mode 100644 index c045335410..0000000000 --- a/test-suite/bugs/opened/bug_1615.v +++ /dev/null @@ -1,11 +0,0 @@ -Require Import Omega. - -Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z. -Proof. - intros. omega. -Qed. - -Lemma foo' : forall n m : nat, n <= n + n * m. -Proof. - intros. Fail omega. -Abort. diff --git a/test-suite/bugs/opened/bug_6602.v b/test-suite/bugs/opened/bug_6602.v deleted file mode 100644 index 3690adf90a..0000000000 --- a/test-suite/bugs/opened/bug_6602.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import Omega. - -Lemma test_nat: - forall n, (5 + pred n <= 5 + n). -Proof. - intros. - zify. - omega. -Qed. - -Lemma test_N: - forall n, (5 + N.pred n <= 5 + n)%N. -Proof. - intros. - zify. - omega. -Qed. diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v index d2e6794c0b..1f4913b49d 100644 --- a/test-suite/interactive/ParalITP_smallproofs.v +++ b/test-suite/interactive/ParalITP_smallproofs.v @@ -140,35 +140,35 @@ Qed. Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. Proof. intros. - omega. + lia. Qed. Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. Proof. intros. - omega. + lia. Qed. Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). Proof. intros. - omega. + lia. Qed. Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. Proof. intros. - omega. + lia. Qed. @@ -1414,13 +1414,13 @@ Qed. Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. Proof. intros. - omega. + lia. Qed. Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. Proof. intros. - omega. + lia. Qed. @@ -1501,7 +1501,7 @@ Proof. [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); [ idtac | apply f_equal with Z; auto with zarith ]; rewrite absolu_plus; - [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; lia | auto with zarith | intro; discriminate ] | rewrite <- H1; reflexivity ]. diff --git a/test-suite/ltac2/evar.v b/test-suite/ltac2/evar.v new file mode 100644 index 0000000000..2c82673edd --- /dev/null +++ b/test-suite/ltac2/evar.v @@ -0,0 +1,17 @@ +Require Import Ltac2.Ltac2. + +Goal exists (a: nat), a = 1. +Proof. + match! goal with + | [ |- ?g ] => Control.assert_false (Constr.has_evar g) + end. + eexists. + match! goal with + | [ |- ?g ] => Control.assert_true (Constr.has_evar g) + end. + match! goal with + | [ |- ?x = ?y ] => + Control.assert_true (Constr.is_evar x); + Control.assert_false (Constr.is_evar y) + end. +Abort. diff --git a/test-suite/ltac2/ind.v b/test-suite/ltac2/ind.v new file mode 100644 index 0000000000..6f7352d224 --- /dev/null +++ b/test-suite/ltac2/ind.v @@ -0,0 +1,25 @@ +Require Import Ltac2.Ltac2. +Require Import Ltac2.Option. + +Ltac2 Eval + let nat := Option.get (Env.get [@Coq; @Init; @Datatypes; @nat]) in + let nat := match nat with + | Std.IndRef nat => nat + | _ => Control.throw Not_found + end in + let data := Ind.data nat in + (* Check that there is only one inductive in the block *) + let ntypes := Ind.nblocks data in + let () := if Int.equal ntypes 1 then () else Control.throw Not_found in + let nat' := Ind.repr (Ind.get_block data 0) in + (* Check it corresponds *) + let () := if Ind.equal nat nat' then () else Control.throw Not_found in + let () := if Int.equal (Ind.index nat) 0 then () else Control.throw Not_found in + (* Check the number of constructors *) + let nconstr := Ind.nconstructors data in + let () := if Int.equal nconstr 2 then () else Control.throw Not_found in + (* Create a fresh instance *) + let s := Ind.get_constructor data 1 in + let s := Env.instantiate (Std.ConstructRef s) in + constr:($s 0) +. diff --git a/test-suite/ltac2/rebind.v b/test-suite/ltac2/rebind.v index 7b3a460c8c..9108871e28 100644 --- a/test-suite/ltac2/rebind.v +++ b/test-suite/ltac2/rebind.v @@ -26,12 +26,10 @@ Ltac2 rec nat_eq n m := | S n => match m with | O => false | S m => nat_eq n m end end. -Ltac2 Type exn ::= [ Assertion_failed ]. - Ltac2 assert_eq n m := match nat_eq n m with | true => () - | false => Control.throw Assertion_failed end. + | false => Control.throw Assertion_failure end. Ltac2 mutable x := O. Ltac2 y := x. diff --git a/test-suite/ltac2/syntax_cast.v b/test-suite/ltac2/syntax_cast.v new file mode 100644 index 0000000000..f62d49173d --- /dev/null +++ b/test-suite/ltac2/syntax_cast.v @@ -0,0 +1,14 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo0 x y : unit := (). +Ltac2 foo1 : unit := (). +Fail Ltac2 foo2 : unit -> unit := (). +Ltac2 foo3 : unit -> unit := fun (_ : unit) => (). + +Ltac2 bar0 := fun x y : unit => (). +Fail Ltac2 bar1 := fun x : unit => 0. +Ltac2 bar2 := fun x : unit list => []. + +Ltac2 qux0 := let x : unit := () in (). +Ltac2 qux1 () := let x y z : unit := () in x 0 "". +Fail Ltac2 qux2 := let x : unit -> unit := () in (). diff --git a/test-suite/micromega/bug_11656.v b/test-suite/micromega/bug_11656.v new file mode 100644 index 0000000000..19846ad50a --- /dev/null +++ b/test-suite/micromega/bug_11656.v @@ -0,0 +1,11 @@ +Require Import Lia. +Require Import NArith. +Open Scope N_scope. + +Goal forall (a b c: N), + a <> 0 -> + c <> 0 -> + a * ((b + 1) * c) <> 0. +Proof. + intros. nia. +Qed. diff --git a/test-suite/micromega/bug_12184.v b/test-suite/micromega/bug_12184.v new file mode 100644 index 0000000000..d329a3fa7f --- /dev/null +++ b/test-suite/micromega/bug_12184.v @@ -0,0 +1,8 @@ +Require Import Lia. +Require Import ZArith. + +Goal forall p : positive, (0 < Z.pos (2^p)%positive)%Z. +Proof. + intros p. + lia. +Qed. diff --git a/test-suite/micromega/bug_14054.v b/test-suite/micromega/bug_14054.v new file mode 100644 index 0000000000..d97e13375f --- /dev/null +++ b/test-suite/micromega/bug_14054.v @@ -0,0 +1,46 @@ +(* bug 13242 *) + +Require Import Lia. +Fail Add Zify InjTyp id. + +(* bug 14054 *) + +Require Import Coq.ZArith.ZArith. Open Scope Z_scope. +Require Coq.Init.Byte . +Require Import Coq.micromega.ZifyClasses Coq.micromega.Lia. + +Notation byte := Coq.Init.Byte.byte. + +Module byte. + Definition unsigned(b: byte): Z := Z.of_N (Byte.to_N b). +End byte. + +Section WithA. + Context (A: Type). + Fixpoint tuple(n: nat): Type := + match n with + | O => unit + | S m => A * tuple m + end. +End WithA. + +Module LittleEndian. + Fixpoint combine (n : nat) : forall (bs : tuple byte n), Z := + match n with + | O => fun _ => 0 + | S n => fun bs => Z.lor (byte.unsigned (fst bs)) + (Z.shiftl (combine n (snd bs)) 8) + end. + Lemma combine_bound: forall {n: nat} (t: tuple byte n), + 0 <= LittleEndian.combine n t < 2 ^ (8 * Z.of_nat n). + Admitted. +End LittleEndian. + +Instance InjByteTuple{n: nat}: InjTyp (tuple byte n) Z := {| + inj := LittleEndian.combine n; + pred x := 0 <= x < 2 ^ (8 * Z.of_nat n); + cstr := @LittleEndian.combine_bound n; +|}. +Fail Add Zify InjTyp InjByteTuple. +Fail Add Zify UnOp InjByteTuple. +Fail Add Zify UnOp X. diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index d70bb809c6..d22e2b7c8c 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -12,6 +12,12 @@ Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. +Lemma power_pos : forall x y, 0 <= x \/ False -> x^ y >= 0. +Proof. + intros. + lia. +Qed. + Lemma not_so_easy : forall x n : Z, 2*x + 1 <= 2 *n -> x <= n-1. Proof. diff --git a/test-suite/micromega/example_nia.v b/test-suite/micromega/example_nia.v index 485c24f0c9..e79b76b810 100644 --- a/test-suite/micromega/example_nia.v +++ b/test-suite/micromega/example_nia.v @@ -7,10 +7,16 @@ (************************************************************************) Require Import ZArith. -Require Import Psatz. Open Scope Z_scope. -Require Import ZMicromega. +Require Import ZMicromega Lia. Require Import VarMap. +Unset Nia Cache. + +Goal forall (x y: Z), 0 < (1+y^2)^(x^2). +Proof. nia. Qed. + +Goal forall (x y: Z), 0 <= (y^2)^x. +Proof. nia. Qed. (* false in Q : x=1/2 and n=1 *) @@ -347,8 +353,8 @@ Lemma hol_light17 : forall x y, -> x * y * (x + y) <= x ^ 2 + y ^ 2. Proof. intros. - Fail nia. -Abort. + nia. +Qed. Lemma hol_light18 : forall x y, @@ -507,3 +513,24 @@ Proof. intros. lia. Qed. + +Lemma mult : forall x x0 x1 x2 n n0 n1 n2, + 0 <= x -> 0 <= x0 -> 0 <= x1 -> 0 <= x2 -> + 0 <= n -> 0 <= n0 -> 0 <= n1 -> 0 <= n2 -> + (n1 * x <= n2 * x1) -> + (n * x0 <= n0 * x2) -> + (n1 * n * (x * x0) > n2 * n0 * (x1 * x2)) -> False. +Proof. + intros. + nia. +Qed. + + +Lemma mult_nat : forall x x0 x1 x2 n n0 n1 n2, + (n1 * x <= n2 * x1)%nat -> + (n * x0 <= n0 * x2)%nat -> + (n1 * n * (x * x0) > n2 * n0 * (x1 * x2))%nat -> False. +Proof. + intros. + nia. +Qed. diff --git a/test-suite/misc/vio_checking.sh b/test-suite/misc/vio_checking.sh new file mode 100755 index 0000000000..ffa909e93b --- /dev/null +++ b/test-suite/misc/vio_checking.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +set -ex + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc + +rm -f vio_checking{,bad}.{vo,vio} + +coqc -vio vio_checking.v +coqc -vio vio_checking_bad.v + +coqc -schedule-vio-checking 2 vio_checking.vio + +if coqc -schedule-vio-checking 2 vio_checking_bad.vio; then + echo 'vio-checking on vio_checking_bad.vio should have failed!' + exit 1 +fi +if coqc -schedule-vio-checking 2 vio_checking.vio vio_checking_bad.vio; then + echo 'vio-checking on vio_checking vio_checking_bad.vio should have failed!' + exit 1 +fi + +coqc -vio2vo vio_checking.vio +coqchk -silent vio_checking.vo + +if coqc -vio2vo vio_checking_bad.vio; then + echo 'vio2vo on vio_checking_bad.vio should have failed!' + exit 1 +fi diff --git a/test-suite/misc/vio_checking.v b/test-suite/misc/vio_checking.v new file mode 100644 index 0000000000..8dd5e47383 --- /dev/null +++ b/test-suite/misc/vio_checking.v @@ -0,0 +1,9 @@ + +Lemma foo : Type. +Proof. exact Type. Qed. + +Lemma foo1 : Type. +Proof. exact Type. Qed. + +Lemma foo2 : Type. +Proof. exact foo1. Qed. diff --git a/test-suite/misc/vio_checking_bad.v b/test-suite/misc/vio_checking_bad.v new file mode 100644 index 0000000000..f32d06f34a --- /dev/null +++ b/test-suite/misc/vio_checking_bad.v @@ -0,0 +1,4 @@ +(* a file to check that vio-checking is not a noop *) + +Lemma foo : Type. +Proof. match goal with |- ?G => exact G end. Qed. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 60213cab0c..cc9e745f6b 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -6,7 +6,7 @@ : nat * nat * (nat * nat) (0, 2, (2, 2)) : nat * nat * (nat * nat) -pair (pair O (S (S O))) (pair (S (S O)) O) +pair (pair 0 2) (pair 2 0) : prod (prod nat nat) (prod nat nat) << 0, 2, 4 >> : nat * nat * nat * (nat * (nat * nat)) @@ -16,8 +16,7 @@ pair (pair O (S (S O))) (pair (S (S O)) O) : nat * nat * nat * (nat * (nat * nat)) (0, 2, 4, (0, (2, 4))) : nat * nat * nat * (nat * (nat * nat)) -pair (pair (pair O (S (S O))) (S (S (S (S O))))) - (pair (S (S (S (S O)))) (pair (S (S O)) O)) +pair (pair (pair 0 2) 4) (pair 4 (pair 2 0)) : prod (prod (prod nat nat) nat) (prod nat (prod nat nat)) ETA x y : nat, Nat.add : nat -> nat -> nat @@ -174,9 +173,8 @@ forall_non_null x y z t : nat , x = y /\ z = t : nat * (nat * nat) * (nat * nat * nat) * (nat * (nat * nat)) * (nat * nat * nat) pair - (pair - (pair (pair (S (S O)) (pair (S O) O)) (pair (pair O (S (S O))) (S O))) - (pair (S O) (pair (S (S O)) O))) (pair (pair O (S O)) (S (S O))) + (pair (pair (pair 2 (pair 1 0)) (pair (pair 0 2) 1)) (pair 1 (pair 2 0))) + (pair (pair 0 1) 2) : prod (prod (prod (prod nat (prod nat nat)) (prod (prod nat nat) nat)) (prod nat (prod nat nat))) (prod (prod nat nat) nat) diff --git a/test-suite/output/RecordProjParameter.out b/test-suite/output/RecordProjParameter.out new file mode 100644 index 0000000000..91ae4b6511 --- /dev/null +++ b/test-suite/output/RecordProjParameter.out @@ -0,0 +1,33 @@ +t1 : Atype -> forall a : Type, a + +t1 is not universe polymorphic +Arguments t1 _ _%type_scope +t1 is transparent +Expands to: Constant RecordProjParameter.t1 +t3 : forall a0 : Atype, t2 a0 + +t3 is not universe polymorphic +t3 is transparent +Expands to: Constant RecordProjParameter.t3 +u1 : Btype -> forall b b0 : Type, b * b0 + +u1 is not universe polymorphic +Arguments u1 _ (_ _)%type_scope +u1 is transparent +Expands to: Constant RecordProjParameter.u1 +u3 : forall b1 : Btype, u2 b1 + +u3 is not universe polymorphic +u3 is transparent +Expands to: Constant RecordProjParameter.u3 +v1 : Ctype -> forall c0 : Type, c0 + +v1 is not universe polymorphic +Arguments v1 _ _%type_scope +v1 is transparent +Expands to: Constant RecordProjParameter.v1 +v3 : forall c : Ctype, v2 c + +v3 is not universe polymorphic +v3 is transparent +Expands to: Constant RecordProjParameter.v3 diff --git a/test-suite/output/RecordProjParameter.v b/test-suite/output/RecordProjParameter.v new file mode 100644 index 0000000000..8b892c694c --- /dev/null +++ b/test-suite/output/RecordProjParameter.v @@ -0,0 +1,21 @@ +Record Atype : Type := + { t1 : forall (a : Type), a + ; t2 : Type + ; t3 : t2 }. +About t1. +About t3. + +Record Btype : Type := + { u1 : forall (b : Type) (b0 : Type), b * b0 + ; u2 : Type + ; u3 : u2 }. +About u1. +About u3. + +Record Ctype : Type := + { v1 : forall (c0 : Type), c0 + ; v2 : Type + ; v3 : v2 + }. +About v1. +About v3. diff --git a/test-suite/output/bug_13240.out b/test-suite/output/bug_13240.out new file mode 100644 index 0000000000..5fccef5cfe --- /dev/null +++ b/test-suite/output/bug_13240.out @@ -0,0 +1,3 @@ +Ltac t1 a b := a ; last b +Ltac t2 := do !idtac +Ltac t3 := idtac => True diff --git a/test-suite/output/bug_13240.v b/test-suite/output/bug_13240.v new file mode 100644 index 0000000000..a999450cd2 --- /dev/null +++ b/test-suite/output/bug_13240.v @@ -0,0 +1,10 @@ +Require Import ssreflect. + +Ltac t1 a b := a; last b. +Print t1. + +Ltac t2 := do !idtac. +Print t2. + +Ltac t3 := idtac => True. +Print t3. diff --git a/test-suite/output/ltac2_deprecated.out b/test-suite/output/ltac2_deprecated.out new file mode 100644 index 0000000000..d17b719bcd --- /dev/null +++ b/test-suite/output/ltac2_deprecated.out @@ -0,0 +1,12 @@ +File "stdin", line 13, characters 11-14: +Warning: Ltac2 definition foo is deprecated. test_definition +[deprecated-ltac2-definition,deprecated] +- : unit = () +File "stdin", line 14, characters 11-14: +Warning: Ltac2 alias bar is deprecated. test_notation +[deprecated-ltac2-alias,deprecated] +- : unit = () +File "stdin", line 15, characters 11-14: +Warning: Ltac2 definition qux is deprecated. test_external +[deprecated-ltac2-definition,deprecated] +- : 'a array -> int = <fun> diff --git a/test-suite/output/ltac2_deprecated.v b/test-suite/output/ltac2_deprecated.v new file mode 100644 index 0000000000..9598a5979c --- /dev/null +++ b/test-suite/output/ltac2_deprecated.v @@ -0,0 +1,15 @@ +Require Import Ltac2.Ltac2. + +#[deprecated(note="test_definition")] +Ltac2 foo := (). + +#[deprecated(note="test_notation")] +Ltac2 Notation bar := (). + +#[deprecated(note="test_external")] +Ltac2 @ external qux : 'a array -> int := "ltac2" "array_length". +(* Randomly picked external function *) + +Ltac2 Eval foo. +Ltac2 Eval bar. +Ltac2 Eval qux. diff --git a/test-suite/output/primitive_tokens.out b/test-suite/output/primitive_tokens.out new file mode 100644 index 0000000000..afe9b25442 --- /dev/null +++ b/test-suite/output/primitive_tokens.out @@ -0,0 +1,61 @@ +"foo" + : string +1234 + : nat +Nat.add 1 2 + : nat +match "a" with +| "a" => true +| _ => false +end + : bool +match 1 with +| 1 => true +| _ => false +end + : bool +{| field := 7 |} + : test +String (Ascii.Ascii false true true false false true true false) + (String (Ascii.Ascii true true true true false true true false) + (String (Ascii.Ascii true true true true false true true false) + EmptyString)) + : string +S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S (S (S (S (S (S ...))))))))))))))))))))))) + : nat +Nat.add (S O) (S (S O)) + : nat +match + String (Ascii.Ascii true false false false false true true false) + EmptyString +with +| String (Ascii.Ascii true false false false false true true false) + EmptyString => true +| _ => false +end + : bool +match S O with +| S O => true +| _ => false +end + : bool +{| field := S (S (S (S (S (S (S O)))))) |} + : test diff --git a/test-suite/output/primitive_tokens.v b/test-suite/output/primitive_tokens.v new file mode 100644 index 0000000000..3207e5983f --- /dev/null +++ b/test-suite/output/primitive_tokens.v @@ -0,0 +1,23 @@ +Require Import String. + +Record test := { field : nat }. + +Open Scope string_scope. + +Unset Printing Notations. + +Check "foo". +Check 1234. +Check 1 + 2. +Check match "a" with "a" => true | _ => false end. +Check match 1 with 1 => true | _ => false end. +Check {| field := 7 |}. + +Set Printing Raw Literals. + +Check "foo". +Check 1234. +Check 1 + 2. +Check match "a" with "a" => true | _ => false end. +Check match 1 with 1 => true | _ => false end. +Check {| field := 7 |}. diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out index ac5a09bad7..6bf03d30d3 100644 --- a/test-suite/output/relaxed_ambiguous_paths.out +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -1,58 +1,82 @@ -File "stdin", line 10, characters 0-28: +File "stdin", line 13, characters 0-29: Warning: -New coercion path [ac; cd] : A >-> D is ambiguous with existing -[ab; bd] : A >-> D. [ambiguous-paths,typechecker] +New coercion path [g1; f2] : A >-> B' is ambiguous with existing +[f1; g2] : A >-> B'. [ambiguous-paths,typechecker] +File "stdin", line 14, characters 0-29: +Warning: +New coercion path [h1; f3] : B >-> C' is ambiguous with existing +[f2; h2] : B >-> C'. [ambiguous-paths,typechecker] +[f1] : A >-> A' +[g1] : A >-> B +[f1; g2] : A >-> B' +[g1; h1] : A >-> C +[f1; g2; h2] : A >-> C' +[g2] : A' >-> B' +[g2; h2] : A' >-> C' +[f2] : B >-> B' +[h1] : B >-> C +[f2; h2] : B >-> C' +[h2] : B' >-> C' +[f3] : C >-> C' +File "stdin", line 33, characters 0-28: +Warning: +New coercion path [ab; bc] : A >-> C is ambiguous with existing +[ac] : A >-> C. [ambiguous-paths,typechecker] [ab] : A >-> B -[ab; bd] : A >-> D [ac] : A >-> C -[bd] : B >-> D +[ac; cd] : A >-> D +[bc] : B >-> C +[bc; cd] : B >-> D [cd] : C >-> D -File "stdin", line 26, characters 0-28: +File "stdin", line 50, characters 0-28: Warning: New coercion path [ab; bc] : A >-> C is ambiguous with existing [ac] : A >-> C. [ambiguous-paths,typechecker] -[ac] : A >-> C -[ac; cd] : A >-> D +File "stdin", line 51, characters 0-28: +Warning: +New coercion path [ba; ab] : B >-> B is not definitionally an identity function. +New coercion path [ab; ba] : A >-> A is not definitionally an identity function. +[ambiguous-paths,typechecker] [ab] : A >-> B -[cd] : C >-> D +[ac] : A >-> C +[ba] : B >-> A [bc] : B >-> C -[bc; cd] : B >-> D [B_A] : B >-> A [C_A] : C >-> A -[D_B] : D >-> B [D_A] : D >-> A +[D_B] : D >-> B [D_C] : D >-> C [A'_A] : A' >-> A -[B_A'] : B >-> A' [B_A'; A'_A] : B >-> A -[C_A'] : C >-> A' +[B_A'] : B >-> A' [C_A'; A'_A] : C >-> A -[D_B; B_A'] : D >-> A' +[C_A'] : C >-> A' [D_A] : D >-> A +[D_B; B_A'] : D >-> A' [D_B] : D >-> B [D_C] : D >-> C -File "stdin", line 121, characters 0-86: +File "stdin", line 147, characters 0-86: Warning: New coercion path [D_C; C_A'] : D >-> A' is ambiguous with existing [D_B; B_A'] : D >-> A'. [ambiguous-paths,typechecker] [A'_A] : A' >-> A -[B_A'] : B >-> A' [B_A'; A'_A] : B >-> A -[C_A'] : C >-> A' +[B_A'] : B >-> A' [C_A'; A'_A] : C >-> A -[D_B; B_A'] : D >-> A' +[C_A'] : C >-> A' [D_A] : D >-> A +[D_B; B_A'] : D >-> A' [D_B] : D >-> B [D_C] : D >-> C -File "stdin", line 130, characters 0-47: +File "stdin", line 156, characters 0-47: Warning: New coercion path [unwrap_nat; wrap_nat] : NAT >-> NAT is not definitionally an identity function. [ambiguous-paths,typechecker] -File "stdin", line 131, characters 0-64: +File "stdin", line 157, characters 0-64: Warning: New coercion path [unwrap_list; wrap_list] : LIST >-> LIST is not definitionally an identity function. [ambiguous-paths,typechecker] -File "stdin", line 132, characters 0-51: +File "stdin", line 158, characters 0-51: Warning: New coercion path [unwrap_Type; wrap_Type] : TYPE >-> TYPE is not definitionally an identity function. [ambiguous-paths,typechecker] diff --git a/test-suite/output/relaxed_ambiguous_paths.v b/test-suite/output/relaxed_ambiguous_paths.v index 41322045f2..182e155273 100644 --- a/test-suite/output/relaxed_ambiguous_paths.v +++ b/test-suite/output/relaxed_ambiguous_paths.v @@ -1,13 +1,20 @@ Module test1. Section test1. -Variable (A B C D : Type). -Variable (ab : A -> B) (bd : B -> D) (ac : A -> C) (cd : C -> D). - -Local Coercion ab : A >-> B. -Local Coercion bd : B >-> D. -Local Coercion ac : A >-> C. -Local Coercion cd : C >-> D. +Variable (A B C A' B' C' : Type). +Variable (f1 : A -> A') (f2 : B -> B') (f3 : C -> C'). +Variable (g1 : A -> B) (g2 : A' -> B') (h1 : B -> C) (h2 : B' -> C'). + +Local Coercion g1 : A >-> B. +Local Coercion g2 : A' >-> B'. +Local Coercion h1 : B >-> C. +Local Coercion h2 : B' >-> C'. +Local Coercion f1 : A >-> A'. +Local Coercion f2 : B >-> B'. +Local Coercion f3 : C >-> C'. +(* [g1; h1; f3], [f1; g2; h2] : A >-> C' should not be reported as ambiguous *) +(* paths because they are redundant with `[g1; f2], [f1; g2] : A >-> B'` and *) +(* `[h1; f3], [f2; h2] : B >-> C'`. *) Print Graph. @@ -24,8 +31,8 @@ Local Coercion ac : A >-> C. Local Coercion cd : C >-> D. Local Coercion ab : A >-> B. Local Coercion bc : B >-> C. -(* `[ab; bc; cd], [ac; cd] : A >-> D` should not be shown as ambiguous paths *) -(* here because they are redundant with `[ab; bc], [ac] : A >-> C`. *) +(* `[ab; bc; cd], [ac; cd] : A >-> D` should not be reported as ambiguous *) +(* paths because they are redundant with `[ab; bc], [ac] : A >-> C`. *) Print Graph. @@ -34,6 +41,25 @@ End test2. Module test3. Section test3. + +Variable (A B C : Type). +Variable (ab : A -> B) (ba : B -> A) (ac : A -> C) (bc : B -> C). + +Local Coercion ac : A >-> C. +Local Coercion bc : B >-> C. +Local Coercion ab : A >-> B. +Local Coercion ba : B >-> A. +(* `[ba; ac], [bc] : B >-> C` should not be reported as ambiguous paths *) +(* because they are redundant with `[ab; bc], [ac] : A >-> C` and *) +(* `[ba; ab] : B >-> B`. *) + +Print Graph. + +End test3. +End test3. + +Module test4. +Section test4. Variable (A : Type) (P Q : A -> Prop). Record B := { @@ -57,11 +83,11 @@ Local Coercion D_C (d : D) : C := Build_C (D_A d) (D_Q d). Print Graph. -End test3. -End test3. +End test4. +End test4. -Module test4. -Section test4. +Module test5. +Section test5. Variable (A : Type) (P Q : A -> Prop). @@ -89,11 +115,11 @@ Local Coercion D_C (d : D) : C true := Build_C true (D_A d) (D_Q d). Print Graph. -End test4. -End test4. +End test5. +End test5. -Module test5. -Section test5. +Module test6. +Section test6. Variable (A : Type) (P Q : A -> Prop). @@ -123,18 +149,18 @@ Local Coercion D_C (d : D) : C true := Print Graph. -End test5. -End test5. +End test6. +End test6. -Module test6. +Module test7. Record > NAT := wrap_nat { unwrap_nat :> nat }. Record > LIST (T : Type) := wrap_list { unwrap_list :> list T }. Record > TYPE := wrap_Type { unwrap_Type :> Type }. -End test6. +End test7. -Module test7. +Module test8. Set Primitive Projections. Record > NAT_prim := wrap_nat { unwrap_nat :> nat }. Record > LIST_prim (T : Type) := wrap_list { unwrap_list :> list T }. Record > TYPE_prim := wrap_Type { unwrap_Type :> Type }. -End test7. +End test8. diff --git a/test-suite/primitive/arrays/set.v b/test-suite/primitive/arrays/set.v index f265c37ea8..787d2867dd 100644 --- a/test-suite/primitive/arrays/set.v +++ b/test-suite/primitive/arrays/set.v @@ -20,3 +20,50 @@ Definition x3 := Eval compute in t.[1]. Definition foo9 := (eq_refl : x3 = 3). Definition x4 := Eval cbn in t.[1]. Definition foo10 := (eq_refl : x4 = 3). + +Ltac check_const_eq name constr := + let v := (eval cbv delta [name] in name) in + tryif constr_eq v constr + then idtac + else fail 0 "Not syntactically equal:" name ":=" v "<>" constr. + +Notation check_const_eq name constr := (ltac:(check_const_eq name constr; exact constr)) (only parsing). + +(* Stuck primitive *) +Definition lazy_stuck_set := Eval lazy in (fun A (t : array A) v => t.[1 <- v]). +Definition vm_stuck_set := Eval vm_compute in (fun A (t : array A) v => t.[1 <- v]). +Definition native_stuck_set := Eval native_compute in (fun A (t : array A) v => t.[1 <- v]). +Definition compute_stuck_set := Eval compute in (fun A (t : array A) v => t.[1 <- v]). +Definition cbn_stuck_set := Eval cbn in (fun A (t : array A) v => t.[1 <- v]). + +Check check_const_eq lazy_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq vm_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq native_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq compute_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq cbn_stuck_set (fun A (t : array A) v => t.[1 <- v]). + +(* Not stuck primitive, but with an accumulator as last argument *) +Definition lazy_accu_set := Eval lazy in (fun v => t.[1 <- v]). +Definition vm_accu_set := Eval vm_compute in (fun v => t.[1 <- v]). +Definition native_accu_set := Eval native_compute in (fun v => t.[1 <- v]). +Definition compute_accu_set := Eval compute in (fun v => t.[1 <- v]). +Definition cbn_accu_set := Eval cbn in (fun v => t.[1 <- v]). + +Check check_const_eq lazy_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq vm_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq native_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq compute_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq cbn_accu_set (fun v => [| 1; v; 2 | 4 |]). + +(* Under-application *) +Definition lazy_set := Eval lazy in @PArray.set. +Definition vm_set := Eval vm_compute in @PArray.set. +Definition native_set := Eval native_compute in @PArray.set. +Definition compute_set := Eval compute in @PArray.set. +Definition cbn_set := Eval cbn in @PArray.set. + +Check check_const_eq lazy_set (@PArray.set). +Check check_const_eq vm_set (fun A (t : array A) i v => t.[i <- v]). +Check check_const_eq native_set (fun A (t : array A) i v => t.[i <- v]). +Check check_const_eq compute_set (@PArray.set). +Check check_const_eq cbn_set (@PArray.set). diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 69ed621877..ae71ddfd1d 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -19,6 +19,7 @@ Require Export ZArith. Require Export ZArithRing. +Require Import Lia. Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. @@ -140,35 +141,35 @@ Qed. Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. Proof. intros. - omega. + lia. Qed. Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. Proof. intros. - omega. + lia. Qed. Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). Proof. intros. - omega. + lia. Qed. Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. Proof. intros. - omega. + lia. Qed. @@ -573,7 +574,7 @@ Qed. -Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. +Local Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. Lemma Zle_reg_mult_l : @@ -1158,7 +1159,7 @@ Proof. intros [| p| p]; intros; [ Falsum | constructor | constructor ]. Qed. -Hint Resolve square_pos: zarith. +Local Hint Resolve square_pos: zarith. (*###########################################################################*) (** Properties of positive numbers, mapping between Z and nat *) @@ -1414,13 +1415,13 @@ Qed. Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. Proof. intros. - omega. + lia. Qed. Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. Proof. intros. - omega. + lia. Qed. @@ -1501,7 +1502,7 @@ Proof. [ replace (Z.abs_nat x) with (Z.abs_nat (x - 1 + 1)); [ idtac | apply f_equal with Z; auto with zarith ]; rewrite absolu_plus; - [ unfold Z.abs_nat at 2, nat_of_P, Pos.iter_op in |- *; omega + [ unfold Z.abs_nat at 2, nat_of_P, Pos.iter_op in |- *; lia | auto with zarith | intro; discriminate ] | rewrite <- H1; reflexivity ]. @@ -1985,7 +1986,7 @@ Proof. intros [| p| p] Hp; trivial. Qed. -Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 +Local Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 Zsgn_27: zarith. @@ -2388,7 +2389,7 @@ Proof. intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. Qed. -Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 +Local Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. @@ -2949,7 +2950,7 @@ Proof. ring. Qed. -Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. +Local Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. (*###########################################################################*) (** Properties of Arity *) @@ -3020,7 +3021,7 @@ Proof. Flip. Qed. -Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. +Local Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. (*###########################################################################*) (** Properties of Zpower *) @@ -3038,4 +3039,4 @@ Proof. ring. Qed. -Hint Resolve Zpower_1 Zpower_2: zarith. +Local Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index d52a853aae..24634bd321 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -1,6 +1,6 @@ (* Cf BZ#546 *) -Require Import Omega. +Require Import Lia. Section S. @@ -19,7 +19,7 @@ induction n. replace (2 * S n0) with (2*n0 + 2) ; auto with arith. apply DummyApp. 2:exact Dummy2. - apply IHn0 ; abstract omega. + apply IHn0 ; abstract lia. Defined. End S. diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v index 5e0f90d59b..a530c34297 100644 --- a/test-suite/success/Omega.v +++ b/test-suite/success/Omega.v @@ -1,5 +1,4 @@ - -Require Import Omega. +Require Import Lia ZArith. (* Submitted by Xavier Urbain 18 Jan 2002 *) @@ -7,14 +6,14 @@ Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. - omega. + lia. Qed. (* Proposed by Pierre Crégut *) Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. intro. - omega. + lia. Qed. (* Proposed by Jean-Christophe Filliâtre *) @@ -22,7 +21,7 @@ Qed. Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. - omega. + lia. Qed. (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) @@ -32,7 +31,7 @@ Section A. Variable x y : Z. Hypothesis H : (x > y)%Z. Lemma lem4 : (x > y)%Z. - omega. + lia. Qed. End A. @@ -48,7 +47,7 @@ Hypothesis L : (R1 >= 0)%Z -> S2 = S1. Hypothesis M : (H <= 2 * S)%Z. Hypothesis N : (S < H)%Z. Lemma lem5 : (H > 0)%Z. - omega. + lia. Qed. End B. @@ -56,11 +55,11 @@ End B. Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. - omega. + lia. Qed. (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) -Require Import Omega. +Require Import Lia. Section C. Parameter g : forall m : nat, m <> 0 -> Prop. Parameter f : forall (m : nat) (H : m <> 0), g m H. @@ -68,21 +67,21 @@ Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. - omega. + lia. Qed. End C. (* Problem of dependencies *) -Require Import Omega. +Require Import Lia. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. -intros; omega. +intros; lia. Qed. (* Bug that what caused by the use of intro_using in Omega *) -Require Import Omega. +Require Import Lia. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. -intros; omega. +intros; lia. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) @@ -90,5 +89,5 @@ Qed. (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. -intros; zify; omega. +intros; lia. Qed. diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v index 6fd936935c..6ce7264b7a 100644 --- a/test-suite/success/Omega0.v +++ b/test-suite/success/Omega0.v @@ -1,4 +1,4 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) @@ -8,7 +8,7 @@ Lemma test_romega_0 : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. -omega. +lia. Qed. Lemma test_romega_0b : @@ -16,7 +16,7 @@ Lemma test_romega_0b : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. -omega. +lia. Qed. Lemma test_romega_1 : @@ -29,7 +29,7 @@ Lemma test_romega_1 : z >= 0. Proof. intros. -omega. +lia. Qed. Lemma test_romega_1b : @@ -42,21 +42,21 @@ Lemma test_romega_1b : z >= 0. Proof. intros z z1 z2. -omega. +lia. Qed. Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. -omega. +lia. Qed. Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. -omega. +lia. Qed. Lemma test_romega_3 : forall a b h hl hr ha hb, @@ -70,7 +70,7 @@ Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros. -omega. +lia. Qed. Lemma test_romega_3b : forall a b h hl hr ha hb, @@ -84,7 +84,7 @@ Lemma test_romega_3b : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. -omega. +lia. Qed. @@ -94,7 +94,7 @@ Lemma test_romega_4 : forall hr ha, hr = 0. Proof. intros hr ha. -omega. +lia. Qed. Lemma test_romega_5 : forall hr ha, @@ -103,45 +103,45 @@ Lemma test_romega_5 : forall hr ha, hr = 0. Proof. intros hr ha. -omega. +lia. Qed. Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. Proof. intros. -omega. +lia. Qed. Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. -omega. +lia. Qed. Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -omega. +lia. Qed. Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -omega. +lia. Qed. (* Magaud BZ#240 *) Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. intros. -omega. +lia. Qed. Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. intros x y. -omega. +lia. Qed. diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v index 4e726335c9..b2eef5bcd5 100644 --- a/test-suite/success/Omega2.v +++ b/test-suite/success/Omega2.v @@ -1,4 +1,4 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. (* Submitted by Yegor Bryukhov (BZ#922) *) @@ -23,6 +23,6 @@ forall v1 v2 v3 v4 v5 : Z, ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. -omega. +lia. Qed. diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v index 0223255067..32bc99621a 100644 --- a/test-suite/success/OmegaPre.v +++ b/test-suite/success/OmegaPre.v @@ -1,4 +1,4 @@ -Require Import ZArith Nnat Omega. +Require Import ZArith Nnat Lia. Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) @@ -16,112 +16,111 @@ Open Scope Z_scope. Goal forall a:Z, Z.max a a = a. intros. -zify; omega. +lia. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. -zify; omega. +lia. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. -zify; omega. +lia. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. -zify; omega. +lia. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. -zify. -intuition; subst; zify; omega. (* pure multiplication: zify; omega alone can't do it *) +intuition; subst; lia. Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. -zify; omega. +lia. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. -zify; omega. +lia. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. -zify; omega. +lia. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. -zify; omega. +lia. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. -zify; omega. +lia. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. -zify; omega. +lia. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. -zify; omega. +lia. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. -zify; omega. +lia. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. -zify; omega. +lia. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. -zify; omega. +lia. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m*m>=0)%N. intros. -zify; omega. +lia. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. -zify; omega. +lia. Qed. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 02adb012d9..ef8617cd9e 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -85,19 +85,19 @@ Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) error end. -Require Import Omega Setoid. +Require Import Lia Setoid. Next Obligation. intros ; simpl in *. apply H. - simpl in * ; omega. + simpl in * ; lia. Qed. Next Obligation. simpl in *; intros. revert H0 ; clear_subset_proofs. intros. - case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. + case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by lia. subst. revert H0 ; clear_subset_proofs ; tauto. - apply H. simpl. omega. + apply H. simpl. lia. Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v index 6ca32f450f..c0e86b00dd 100644 --- a/test-suite/success/ROmegaPre.v +++ b/test-suite/success/ROmegaPre.v @@ -32,8 +32,7 @@ Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. -zify. -intuition; subst; lia. (* pure multiplication: omega alone can't do it *) +intuition; subst; lia. Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. diff --git a/test-suite/success/RemoteUnivs.v b/test-suite/success/RemoteUnivs.v new file mode 100644 index 0000000000..5ab4937dda --- /dev/null +++ b/test-suite/success/RemoteUnivs.v @@ -0,0 +1,31 @@ + + +Goal Type * Type. +Proof. + split. + par: exact Type. +Qed. + +Goal Type. +Proof. + exact Type. +Qed. + +(* (* coqide test, note the delegated proofs seem to get an empty dirpath? + or I got confused because I had lemma foo in file foo + *) +Definition U := Type. + +Lemma foo : U. +Proof. + exact Type. +Qed. + + +Lemma foo1 : Type. +Proof. + exact (U:Type). +Qed. + +Print foo. +*) diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v index ff34840d83..b7d5276bc8 100644 --- a/test-suite/success/fix.v +++ b/test-suite/success/fix.v @@ -61,7 +61,7 @@ Qed. (* Check mutually inductive statements *) -Require Import ZArith_base Omega. +Require Import ZArith_base Lia. Open Scope Z_scope. Inductive even: Z -> Prop := @@ -75,13 +75,13 @@ with odd_pos_even_pos : forall n, odd n -> n >= 1. Proof. intros. destruct H. - omega. + lia. apply odd_pos_even_pos in H. - omega. + lia. intros. destruct H. apply even_pos_odd_pos in H. - omega. + lia. Qed. CoInductive a : Prop := acons : b -> a diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index 5638a7d3eb..06847f4f96 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -23,7 +23,7 @@ Qed. Print Equivalent Keys. End foo. -Require Import Arith List Omega. +Require Import Arith List. Definition G {A} (f : A -> A -> A) (x : A) := f x x. diff --git a/test-suite/success/rewrite_iterated.v b/test-suite/success/rewrite_iterated.v index 962dada35a..946011e393 100644 --- a/test-suite/success/rewrite_iterated.v +++ b/test-suite/success/rewrite_iterated.v @@ -1,8 +1,8 @@ -Require Import Arith Omega. +Require Import Arith Lia. Lemma test : forall p:nat, p<>0 -> p-1+1=p. Proof. - intros; omega. + intros; lia. Qed. (** Test of new syntax for rewrite : ! ? and so on... *) diff --git a/test-suite/success/search.v b/test-suite/success/search.v index 92de43e052..627e109d5f 100644 --- a/test-suite/success/search.v +++ b/test-suite/success/search.v @@ -32,4 +32,4 @@ Require Import ZArith. Search Z.mul Z.add "distr". Search "+"%Z "*"%Z "distr" -positive -Prop. -Search (?x * _ + ?x * _)%Z outside OmegaLemmas. +Search (?x * _ + ?x * _)%Z outside Lia. diff --git a/test-suite/vio/univ_constraints_statements_body.v b/test-suite/vio/univ_constraints_statements_body.v new file mode 100644 index 0000000000..6302adefc2 --- /dev/null +++ b/test-suite/vio/univ_constraints_statements_body.v @@ -0,0 +1,7 @@ +Definition T := Type. +Definition T1 : T := Type. + +Lemma x : True. +Proof. +exact (let a : T := Type in I). +Qed. diff --git a/theories/Arith/Cantor.v b/theories/Arith/Cantor.v new file mode 100644 index 0000000000..b63d970db7 --- /dev/null +++ b/theories/Arith/Cantor.v @@ -0,0 +1,88 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Implementation of the Cantor pairing and its inverse function *) + +Require Import PeanoNat Lia. + +(** Bijections between [nat * nat] and [nat] *) + +(** Cantor pairing [to_nat] *) + +Definition to_nat '(x, y) : nat := + y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)). + +(** Cantor pairing inverse [of_nat] *) + +Definition of_nat (n : nat) : nat * nat := + nat_rec _ (0, 0) (fun _ '(x, y) => + match x with | S x => (x, S y) | _ => (S y, 0) end) n. + +(** [of_nat] is the left inverse for [to_nat] *) + +Lemma cancel_of_to p : of_nat (to_nat p) = p. +Proof. + enough (H : forall n p, to_nat p = n -> of_nat n = p) by now apply H. + intro n. induction n as [|n IHn]. + - now intros [[|?] [|?]]. + - intros [x [|y]]. + + destruct x as [|x]; [discriminate|]. + intros [=H]. cbn. fold (of_nat n). + rewrite (IHn (0, x)); [reflexivity|]. + rewrite <- H. cbn. now rewrite PeanoNat.Nat.add_0_r. + + intros [=H]. cbn. fold (of_nat n). + rewrite (IHn (S x, y)); [reflexivity|]. + rewrite <- H. cbn. now rewrite Nat.add_succ_r. +Qed. + +(** [to_nat] is injective *) + +Corollary to_nat_inj p q : to_nat p = to_nat q -> p = q. +Proof. + intros H %(f_equal of_nat). now rewrite ?cancel_of_to in H. +Qed. + +(** [to_nat] is the left inverse for [of_nat] *) + +Lemma cancel_to_of n : to_nat (of_nat n) = n. +Proof. + induction n as [|n IHn]; [reflexivity|]. + cbn. fold (of_nat n). destruct (of_nat n) as [[|x] y]. + - rewrite <- IHn. cbn. now rewrite PeanoNat.Nat.add_0_r. + - rewrite <- IHn. cbn. now rewrite (Nat.add_succ_r y x). +Qed. + +(** [of_nat] is injective *) + +Corollary of_nat_inj n m : of_nat n = of_nat m -> n = m. +Proof. + intros H %(f_equal to_nat). now rewrite ?cancel_to_of in H. +Qed. + +(** Polynomial specifications of [to_nat] *) + +Lemma to_nat_spec x y : + to_nat (x, y) * 2 = y * 2 + (y + x) * S (y + x). +Proof. + cbn. induction (y + x) as [|n IHn]; cbn; lia. +Qed. + +Lemma to_nat_spec2 x y : + to_nat (x, y) = y + (y + x) * S (y + x) / 2. +Proof. + now rewrite <- Nat.div_add_l, <- to_nat_spec, Nat.div_mul. +Qed. + +(** [to_nat] is non-decreasing in (the sum of) pair components *) + +Lemma to_nat_non_decreasing x y : y + x <= to_nat (x, y). +Proof. + pose proof (to_nat_spec x y). nia. +Qed. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 6978fa1ddf..a1a4da6f37 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -87,7 +87,7 @@ Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with [ x : () |- _ ] => destruct x end. reflexivity. Qed. @@ -142,7 +142,10 @@ Program Instance list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := | _, _ => in_right end }. - Next Obligation. destruct y ; unfold not in *; eauto. Defined. + Next Obligation. + match goal with y : list _ |- _ => destruct y end ; + unfold not in *; eauto. + Defined. Solve Obligations with unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 6a98af39aa..3e71a60fa6 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -87,7 +87,7 @@ Tactic Notation "clsubst" "*" := clsubst_nofail. Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. - intros; intro. + intros A ? x y z H H0 H1. assert(z == y) by (symmetry ; auto). assert(x == y) by (transitivity z ; eauto). contradiction. @@ -95,7 +95,7 @@ Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. - intros; intro. + intros A ? x y z **; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 2947c4831f..f4220e3aa1 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -96,7 +96,7 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with x : () |- _ => destruct x end. reflexivity. Qed. diff --git a/theories/Compat/Coq813.v b/theories/Compat/Coq813.v index fe7431dcd3..5cfb9d84c7 100644 --- a/theories/Compat/Coq813.v +++ b/theories/Compat/Coq813.v @@ -11,3 +11,13 @@ (** Compatibility file for making Coq act similar to Coq v8.13 *) Require Export Coq.Compat.Coq814. + +Require Coq.micromega.Lia. +Module Export Coq. + Module Export omega. + Module Export Omega. + #[deprecated(since="8.12", note="The omega tactic was removed in v8.14. You're now relying on the lia tactic.")] + Ltac omega := Lia.lia. + End Omega. + End omega. +End Coq. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index d6277b3bb5..2a5eb2db39 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -8,8 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Setoid. -Require Import PeanoNat Le Gt Minus Bool Lt. +Require Import PeanoNat Bool. Set Implicit Arguments. (* Set Universe Polymorphism. *) @@ -264,15 +263,13 @@ Section Facts. forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]; - simpl; auto; intros l H. - absurd (length (x2 :: l2 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite <- H; auto with arith. - absurd (length (x1 :: l1 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite H; auto with arith. - injection H as [= H H0]; f_equal; eauto. + intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]. + - now intros. + - intros l Hl. apply (f_equal (@length A)) in Hl. + now rewrite ?app_length, Nat.add_cancel_r in Hl. + - intros l Hl. apply (f_equal (@length A)) in Hl. + now rewrite ?app_length, Nat.add_cancel_r in Hl. + - intros l [=H1 H2 %IHl1]. now subst. Qed. Lemma app_inv_tail_iff: @@ -472,7 +469,7 @@ Section Elts. - destruct l; simpl; [ inversion 2 | auto ]. - destruct l; simpl. * inversion 2. - * intros d ie; right; apply hn; auto with arith. + * intros d ie; right; apply hn. now apply Nat.succ_le_mono. Qed. Lemma In_nth l x d : In x l -> @@ -481,9 +478,9 @@ Section Elts. induction l as [|a l IH]. - easy. - intros [H|H]. - * subst; exists 0; simpl; auto with arith. + * subst; exists 0; simpl; auto using Nat.lt_0_succ. * destruct (IH H) as (n & Hn & Hn'). - exists (S n); simpl; auto with arith. + apply Nat.succ_lt_mono in Hn. now exists (S n). Qed. Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. @@ -491,7 +488,7 @@ Section Elts. intro l; induction l as [|? ? IHl]; intro n; destruct n; simpl; intros d H; auto. - inversion H. - - apply IHl; auto with arith. + - apply IHl. now apply Nat.succ_le_mono. Qed. Lemma nth_indep : @@ -499,7 +496,8 @@ Section Elts. Proof. intro l; induction l. - inversion 1. - - intros [|n] d d'; simpl; auto with arith. + - intros [|n] d d'; [intros; reflexivity|]. + intros H. apply IHl. now apply Nat.succ_lt_mono. Qed. Lemma app_nth1 : @@ -507,7 +505,8 @@ Section Elts. Proof. intro l; induction l. - inversion 1. - - intros l' d [|n]; simpl; auto with arith. + - intros l' d [|n]; simpl; [intros; reflexivity|]. + intros H. apply IHl. now apply Nat.succ_lt_mono. Qed. Lemma app_nth2 : @@ -515,15 +514,15 @@ Section Elts. Proof. intro l; induction l as [|? ? IHl]; intros l' d [|n]; auto. - inversion 1. - - intros; simpl; rewrite IHl; auto with arith. + - intros; simpl; rewrite IHl; [reflexivity|now apply Nat.succ_le_mono]. Qed. Lemma app_nth2_plus : forall l l' d n, nth (length l + n) (l ++ l') d = nth n l' d. Proof. intros. - rewrite app_nth2, minus_plus; trivial. - auto with arith. + rewrite app_nth2, Nat.add_comm, Nat.add_sub; trivial. + now apply Nat.le_add_r. Qed. Lemma nth_middle : forall l l' a d, @@ -540,7 +539,7 @@ Section Elts. revert l. induction n as [|n IH]; intros [|a l] H; try easy. - exists nil; exists l; now simpl. - - destruct (IH l) as (l1 & l2 & Hl & Hl1); auto with arith. + - destruct (IH l) as (l1 & l2 & Hl & Hl1); [now apply Nat.succ_lt_mono|]. exists (a::l1); exists l2; simpl; split; now f_equal. Qed. @@ -557,7 +556,7 @@ Section Elts. rewrite Hnth; f_equal. + apply IHl with d d'; [ now inversion Hlen | ]. intros n Hlen'; apply (Hnth (S n)). - now simpl; apply lt_n_S. + now apply (Nat.succ_lt_mono n (length l)). + simpl; apply Nat.lt_0_succ. Qed. @@ -575,18 +574,18 @@ Section Elts. induction l as [|a l IH]. - easy. - intros [H|H]. - * subst; exists 0; simpl; auto with arith. + * subst; now exists 0. * destruct (IH H) as (n,Hn). - exists (S n); simpl; auto with arith. + now exists (S n). Qed. Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. Proof. revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; auto. - - split; auto with arith. - - split; now auto with arith. - - rewrite IHl; split; auto with arith. + - now split; intros; [apply Nat.le_0_l|]. + - now split; [|intros ? %Nat.nle_succ_0]. + - now rewrite IHl, Nat.succ_le_mono. Qed. Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. @@ -594,8 +593,8 @@ Section Elts. revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; [now destruct 1 | inversion 1]. - split; [now destruct 1 | inversion 1]. - - split; now auto with arith. - - rewrite IHl; split; auto with arith. + - now split; intros; [apply Nat.lt_0_succ|]. + - now rewrite IHl, Nat.succ_lt_mono. Qed. Lemma nth_error_split l n a : nth_error l n = Some a -> @@ -613,7 +612,7 @@ Section Elts. Proof. revert l. induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. - simpl in *. apply IHn. auto with arith. + simpl in *. apply IHn. now apply Nat.succ_lt_mono. Qed. Lemma nth_error_app2 l l' n : length l <= n -> @@ -621,7 +620,7 @@ Section Elts. Proof. revert l. induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. - simpl in *. apply IHn. auto with arith. + simpl in *. apply IHn. now apply Nat.succ_le_mono. Qed. (** Results directly relating [nth] and [nth_error] *) @@ -841,8 +840,9 @@ Section Elts. Theorem count_occ_In l x : In x l <-> count_occ l x > 0. Proof. induction l as [|y l IHl]; simpl. - - split; [destruct 1 | apply gt_irrefl]. + - split; [destruct 1 | apply Nat.nlt_0_r]. - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition. + now apply Nat.lt_0_succ. Qed. Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0. @@ -877,6 +877,36 @@ Section Elts. intros H. simpl. now destruct (eq_dec x y). Qed. + Lemma count_occ_app l1 l2 x : + count_occ (l1 ++ l2) x = count_occ l1 x + count_occ l2 x. + Proof. + induction l1 as [ | h l1 IHl1]; cbn; auto. + now destruct (eq_dec h x); [ rewrite IHl1 | ]. + Qed. + + Lemma count_occ_elt_eq l1 l2 x y : x = y -> + count_occ (l1 ++ x :: l2) y = S (count_occ (l1 ++ l2) y). + Proof. + intros ->. + rewrite ? count_occ_app; cbn. + destruct (eq_dec y y) as [Heq | Hneq]; + [ apply Nat.add_succ_r | now contradiction Hneq ]. + Qed. + + Lemma count_occ_elt_neq l1 l2 x y : x <> y -> + count_occ (l1 ++ x :: l2) y = count_occ (l1 ++ l2) y. + Proof. + intros Hxy. + rewrite ? count_occ_app; cbn. + now destruct (eq_dec x y) as [Heq | Hneq]; [ contradiction Hxy | ]. + Qed. + + Lemma count_occ_bound x l : count_occ l x <= length l. + Proof. + induction l as [|h l]; cbn; auto. + destruct (eq_dec h x); [ apply (proj1 (Nat.succ_le_mono _ _)) | ]; intuition. + Qed. + End Elts. (*******************************) @@ -960,26 +990,22 @@ Section ListOps. elim (length l); simpl; auto. Qed. - Lemma rev_nth : forall l d n, n < length l -> + Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. intro l; induction l as [|a l IHl]. - intros d n H; inversion H. - intros ? n H. - simpl in H. - simpl (rev (a :: l)). - simpl (length (a :: l) - S n). - inversion H. - rewrite <- minus_n_n; simpl. - rewrite <- rev_length. - rewrite app_nth2; auto. - rewrite <- minus_n_n; auto. - rewrite app_nth1; auto. - rewrite (minus_plus_simpl_l_reverse (length l) n 1). - replace (1 + length l) with (S (length l)); auto with arith. - rewrite <- minus_Sn_m; auto with arith. - apply IHl ; auto with arith. - rewrite rev_length; auto. + - intros d n H; inversion H. + - intros ? n H. simpl in H. + inversion H. + + rewrite Nat.sub_diag; simpl. + rewrite <- rev_length. + rewrite app_nth2; auto. + now rewrite Nat.sub_diag. + + simpl. rewrite app_nth1; [|now rewrite rev_length]. + rewrite IHl; [|eassumption]. + destruct (length l); [exfalso; now apply (Nat.nlt_0_r n)|]. + rewrite (Nat.sub_succ_l n); [reflexivity|]. + now apply Nat.succ_le_mono. Qed. @@ -1138,10 +1164,18 @@ Section Map. intro l; induction l; simpl map; intros d n; destruct n; firstorder. Qed. + Lemma nth_error_map : forall n l, + nth_error (map l) n = option_map f (nth_error l n). + Proof. + intro n. induction n as [|n IHn]; intro l. + - now destruct l. + - destruct l as [|? l]; [reflexivity|exact (IHn l)]. + Qed. + Lemma map_nth_error : forall n l d, nth_error l n = Some d -> nth_error (map l) n = Some (f d). Proof. - intro n; induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. + intros n l d H. now rewrite nth_error_map, H. Qed. Lemma map_app : forall l l', @@ -1322,7 +1356,7 @@ Proof. + inversion Hlen. + now rewrite nth_overflow; destruct n. - destruct n; simpl; [ reflexivity | apply IHln ]. - destruct Hlen; [ left; apply lt_S_n | right ]; assumption. + destruct Hlen; [ left; apply Nat.succ_lt_mono | right ]; assumption. Qed. @@ -1358,8 +1392,7 @@ Proof. intros A l. enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0). induction l as [|? ? IHl]; simpl; auto. - intros; rewrite IHl. - simpl; auto with arith. + now intros; rewrite IHl, Nat.add_succ_r. Qed. (************************************) @@ -1464,7 +1497,7 @@ End Fold_Right_Recursor. simpl; intros n ? ? H0. destruct (orb_false_elim _ _ H0); clear H0; auto. destruct n ; auto. - rewrite IHl; auto with arith. + rewrite IHl; auto. now apply Nat.succ_lt_mono. Qed. Lemma existsb_app : forall l1 l2, @@ -1900,37 +1933,35 @@ Section length_order. Lemma lel_refl : lel l l. Proof. - unfold lel; auto with arith. + now apply Nat.le_refl. Qed. Lemma lel_trans : lel l m -> lel m n -> lel l n. Proof. unfold lel; intros. now_show (length l <= length n). - apply le_trans with (length m); auto with arith. + now apply Nat.le_trans with (length m). Qed. Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m). Proof. - unfold lel; simpl; auto with arith. + now intros ? %Nat.succ_le_mono. Qed. Lemma lel_cons : lel l m -> lel l (b :: m). Proof. - unfold lel; simpl; auto with arith. + intros. now apply Nat.le_le_succ_r. Qed. Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m. Proof. - unfold lel; simpl; auto with arith. + intros. now apply Nat.succ_le_mono. Qed. Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'. Proof. - intro l'; elim l'; auto with arith. - intros a' y H H0. - now_show (nil = a' :: y). - absurd (S (length y) <= 0); auto with arith. + intro l'; elim l'; [now intros|]. + now intros a' y H H0 %Nat.nle_succ_0. Qed. End length_order. @@ -2105,7 +2136,7 @@ Section Cutting. rewrite (length_zero_iff_nil l) in H1. subst. now simpl. - intro l; destruct l as [|x xs]; simpl. * now reflexivity. - * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H. + * simpl. intro H. f_equal. apply iHk. now apply Nat.succ_le_mono. Qed. Lemma firstn_O l: firstn 0 l = []. @@ -2114,17 +2145,17 @@ Section Cutting. Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n. Proof. induction n as [|k iHk]; simpl; [auto | intro l; destruct l as [|x xs]; simpl]. - - auto with arith. - - apply Peano.le_n_S, iHk. + - now apply Nat.le_0_l. + - now rewrite <- Nat.succ_le_mono. Qed. Lemma firstn_length_le: forall l:list A, forall n:nat, n <= length l -> length (firstn n l) = n. Proof. intro l; induction l as [|x xs Hrec]. - - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl. + - simpl. intros n H. apply Nat.le_0_r in H. now subst. - intro n; destruct n as [|n]. * now simpl. - * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H). + * simpl. intro H. f_equal. apply Hrec. now apply Nat.succ_le_mono. Qed. Lemma firstn_app n: @@ -2133,7 +2164,7 @@ Section Cutting. Proof. induction n as [|k iHk]; intros l1 l2. - now simpl. - destruct l1 as [|x xs]. - * unfold firstn at 2, length. now rewrite 2!app_nil_l, <- minus_n_O. + * reflexivity. * rewrite <- app_comm_cons. simpl. f_equal. apply iHk. Qed. @@ -2142,13 +2173,13 @@ Section Cutting. firstn ((length l1) + n) (l1 ++ l2) = l1 ++ firstn n l2. Proof. induction n as [| k iHk];intros l1 l2. - unfold firstn at 2. rewrite <- plus_n_O, app_nil_r. - rewrite firstn_app. rewrite <- minus_diag_reverse. + rewrite firstn_app. rewrite Nat.sub_diag. unfold firstn at 2. rewrite app_nil_r. apply firstn_all. - destruct l2 as [|x xs]. - * simpl. rewrite app_nil_r. apply firstn_all2. auto with arith. + * simpl. rewrite app_nil_r. apply firstn_all2. now apply Nat.le_add_r. * rewrite firstn_app. assert (H0 : (length l1 + S k - length l1) = S k). - auto with arith. - rewrite H0, firstn_all2; [reflexivity | auto with arith]. + now rewrite Nat.add_comm, Nat.add_sub. + rewrite H0, firstn_all2; [reflexivity | now apply Nat.le_add_r]. Qed. Lemma firstn_firstn: @@ -2249,11 +2280,7 @@ Section Cutting. destruct (Nat.le_ge_cases (length (rev l)) x) as [L | L]. - rewrite skipn_all2; [apply Nat.sub_0_le in L | trivial]. now rewrite L, Nat.sub_0_r, skipn_all. - - replace (length (rev l) - (length (rev l) - x)) - with (length (rev l) + x - length (rev l)). - rewrite minus_plus. reflexivity. - rewrite <- (Nat.sub_add _ _ L) at 2. - now rewrite <-!(Nat.add_comm x), <-minus_plus_simpl_l_reverse. + - f_equal. now apply Nat.eq_sym, Nat.add_sub_eq_l, Nat.sub_add. Qed. Lemma removelast_firstn : forall n l, n < length l -> @@ -2268,7 +2295,7 @@ Section Cutting. change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l). change (firstn (S n) (a::l)) with (a::firstn n l). rewrite removelast_app. - rewrite IHn; auto with arith. + rewrite IHn; [reflexivity|now apply Nat.succ_le_mono]. clear IHn; destruct l; simpl in *; try discriminate. inversion_clear H as [|? H1]. @@ -2293,7 +2320,7 @@ Section Cutting. simpl in H. change (removelast (a :: l)) with (removelast ((a::nil)++l)). rewrite removelast_app. - simpl; f_equal; auto with arith. + simpl; f_equal. apply IHn. now apply Nat.succ_lt_mono. intro H0; rewrite H0 in H; inversion_clear H as [|? H1]; inversion_clear H1. Qed. @@ -2385,7 +2412,7 @@ Section Add. Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). Proof. - induction 1; simpl; auto with arith. + induction 1; simpl; now auto. Qed. Lemma Add_inv a l : In a l -> exists l', Add a l' l. @@ -2564,13 +2591,13 @@ Section ReDun. - destruct i, j; simpl in *; auto. * elim Hal. eapply nth_error_In; eauto. * elim Hal. eapply nth_error_In; eauto. - * f_equal. apply IH; auto with arith. } + * f_equal. now apply IH;[apply Nat.succ_lt_mono|]. } { induction l as [|a l IHl]; intros H; constructor. * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn). assert (n < length l) by (now rewrite <- nth_error_Some, Hn). - specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith. + specialize (H 0 (S n)). simpl in H. now discriminate H; [apply Nat.lt_0_succ|]. * apply IHl. - intros i j Hi E. apply eq_add_S, H; simpl; auto with arith. } + intros i j Hi %Nat.succ_lt_mono E. now apply eq_add_S, H. } Qed. Lemma NoDup_nth l d : @@ -2582,14 +2609,17 @@ Section ReDun. { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi Hj E. - inversion Hi. - destruct i, j; simpl in *; auto. - * elim Hal. subst a. apply nth_In; auto with arith. - * elim Hal. subst a. apply nth_In; auto with arith. - * f_equal. apply IH; auto with arith. } + * elim Hal. subst a. now apply nth_In, Nat.succ_lt_mono. + * elim Hal. subst a. now apply nth_In, Nat.succ_lt_mono. + * f_equal. apply IH; [| |assumption]; now apply Nat.succ_lt_mono. } { induction l as [|a l IHl]; intros H; constructor. * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn'). - specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith. + specialize (H 0 (S n)). simpl in H. + apply Nat.succ_lt_mono in Hn. + discriminate H; eauto using Nat.lt_0_succ. * apply IHl. - intros i j Hi Hj E. apply eq_add_S, H; simpl; auto with arith. } + intros i j Hi %Nat.succ_lt_mono Hj %Nat.succ_lt_mono E. + now apply eq_add_S, H. } Qed. (** Having [NoDup] hypotheses bring more precise facts about [incl]. *) @@ -2598,7 +2628,7 @@ Section ReDun. NoDup l -> incl l l' -> length l <= length l'. Proof. intros N. revert l'. induction N as [|a l Hal N IH]; simpl. - - auto with arith. + - intros. now apply Nat.le_0_l. - intros l' H. destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } rewrite (Add_length AD). apply le_n_S. apply IH. @@ -2615,7 +2645,7 @@ Section ReDun. rewrite (Add_in AD) in Hx. simpl in Hx. destruct Hx as [Hx|Hx]; [left; trivial|right]. revert x Hx. apply (IH l''); trivial. - * apply le_S_n. now rewrite <- (Add_length AD). + * apply Nat.succ_le_mono. now rewrite <- (Add_length AD). * now apply incl_Add_inv with a l'. Qed. @@ -2690,9 +2720,8 @@ Section NatSeq. intro len; induction len as [|len IHlen]; intros start n d H. inversion H. simpl seq. - destruct n; simpl. - auto with arith. - rewrite IHlen;simpl; auto with arith. + destruct n; simpl. now rewrite Nat.add_0_r. + now rewrite IHlen; [rewrite Nat.add_succ_r|apply Nat.succ_lt_mono]. Qed. Lemma seq_shift : forall len start, @@ -2700,25 +2729,29 @@ Section NatSeq. Proof. intro len; induction len as [|len IHlen]; simpl; auto. intros. - rewrite IHlen. - auto with arith. + now rewrite IHlen. Qed. Lemma in_seq len start n : In n (seq start len) <-> start <= n < start+len. Proof. - revert start. induction len as [|len IHlen]; simpl; intros. - - rewrite <- plus_n_O. split;[easy|]. - intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). - - rewrite IHlen, <- plus_n_Sm; simpl; split. - + intros [H|H]; subst; intuition auto with arith. - + intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition. + revert start. induction len as [|len IHlen]; simpl; intros start. + - rewrite <- plus_n_O. split;[easy|]. + intros (H,H'). apply (Nat.lt_irrefl start). + eapply Nat.le_lt_trans; eassumption. + - rewrite IHlen, <- plus_n_Sm; simpl; split. + + intros [H|H]; subst; intuition. + * apply -> Nat.succ_le_mono. apply Nat.le_add_r. + * now apply Nat.lt_le_incl. + + intros (H,H'). inversion H. + * now left. + * right. subst. now split; [apply -> Nat.succ_le_mono|]. Qed. Lemma seq_NoDup len start : NoDup (seq start len). Proof. revert start; induction len; simpl; constructor; trivial. - rewrite in_seq. intros (H,_). apply (Lt.lt_irrefl _ H). + rewrite in_seq. intros (H,_). now apply (Nat.lt_irrefl start). Qed. Lemma seq_app : forall len1 len2 start, @@ -3021,6 +3054,53 @@ Hint Constructors Exists : core. #[global] Hint Constructors Forall : core. +Lemma Exists_map A B (f : A -> B) P l : + Exists P (map f l) <-> Exists (fun x => P (f x)) l. +Proof. + induction l as [|a l IHl]. + - cbn. now rewrite Exists_nil. + - cbn. now rewrite ?Exists_cons, IHl. +Qed. + +Lemma Exists_concat A P (ls : list (list A)) : + Exists P (concat ls) <-> Exists (Exists P) ls. +Proof. + induction ls as [|l ls IHls]. + - cbn. now rewrite Exists_nil. + - cbn. now rewrite Exists_app, Exists_cons, IHls. +Qed. + +Lemma Exists_flat_map A B P ls (f : A -> list B) : + Exists P (flat_map f ls) <-> Exists (fun d => Exists P (f d)) ls. +Proof. + now rewrite flat_map_concat_map, Exists_concat, Exists_map. +Qed. + +Lemma Forall_map A B (f : A -> B) P l : + Forall P (map f l) <-> Forall (fun x => P (f x)) l. +Proof. + induction l as [|a l IHl]. + - constructor; intros; now constructor. + - constructor; intro H; + (constructor; [exact (Forall_inv H) | apply IHl; exact (Forall_inv_tail H)]). +Qed. + +Lemma Forall_concat A P (ls : list (list A)) : + Forall P (concat ls) <-> Forall (Forall P) ls. +Proof. + induction ls as [|l ls IHls]. + - constructor; intros; now constructor. + - cbn. rewrite Forall_app. constructor; intro H. + + constructor; [exact (proj1 H) | apply IHls; exact (proj2 H)]. + + constructor; [exact (Forall_inv H) | apply IHls; exact (Forall_inv_tail H)]. +Qed. + +Lemma Forall_flat_map A B P ls (f : A -> list B) : + Forall P (flat_map f ls) <-> Forall (fun d => Forall P (f d)) ls. +Proof. + now rewrite flat_map_concat_map, Forall_concat, Forall_map. +Qed. + Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. Proof. @@ -3242,6 +3322,70 @@ Section Repeat. now rewrite (IHl HF') at 1. Qed. + Hypothesis decA : forall x y : A, {x = y}+{x <> y}. + + Lemma count_occ_repeat_eq x y n : x = y -> count_occ decA (repeat y n) x = n. + Proof. + intros ->. + induction n; cbn; auto. + destruct (decA y y); auto. + exfalso; intuition. + Qed. + + Lemma count_occ_repeat_neq x y n : x <> y -> count_occ decA (repeat y n) x = 0. + Proof. + intros Hneq. + induction n; cbn; auto. + destruct (decA y x); auto. + exfalso; intuition. + Qed. + + Lemma count_occ_unique x l : count_occ decA l x = length l -> l = repeat x (length l). + Proof. + induction l as [|h l]; cbn; intros Hocc; auto. + destruct (decA h x). + - f_equal; intuition. + - assert (Hb := count_occ_bound decA x l). + rewrite Hocc in Hb. + exfalso; apply (Nat.nle_succ_diag_l _ Hb). + Qed. + + Lemma count_occ_repeat_excl x l : + (forall y, y <> x -> count_occ decA l y = 0) -> l = repeat x (length l). + Proof. + intros Hocc. + apply Forall_eq_repeat, Forall_forall; intros z Hin. + destruct (decA z x) as [Heq|Hneq]; auto. + apply Hocc, count_occ_not_In in Hneq; intuition. + Qed. + + Lemma count_occ_sgt l x : l = x :: nil <-> + count_occ decA l x = 1 /\ forall y, y <> x -> count_occ decA l y = 0. + Proof. + split. + - intros ->; cbn; split; intros; destruct decA; subst; intuition. + - intros [Heq Hneq]. + apply count_occ_repeat_excl in Hneq. + rewrite Hneq, count_occ_repeat_eq in Heq; trivial. + now rewrite Heq in Hneq. + Qed. + + Lemma nth_repeat a m n : + nth n (repeat a m) a = a. + Proof. + revert n. induction m as [|m IHm]. + - now intros [|n]. + - intros [|n]; [reflexivity|exact (IHm n)]. + Qed. + + Lemma nth_error_repeat a m n : + n < m -> nth_error (repeat a m) n = Some a. + Proof. + intro Hnm. rewrite (nth_error_nth' _ a). + - now rewrite nth_repeat. + - now rewrite repeat_length. + Qed. + End Repeat. Lemma repeat_to_concat A n (a:A) : @@ -3279,11 +3423,12 @@ Qed. Lemma list_max_le : forall l n, list_max l <= n <-> Forall (fun k => k <= n) l. Proof. -intro l; induction l as [|a l IHl]; simpl; intros n; split; intros H; intuition. -- apply Nat.max_lub_iff in H. - now constructor; [ | apply IHl ]. -- inversion_clear H as [ | ? ? Hle HF ]. - apply IHl in HF; apply Nat.max_lub; assumption. + intro l; induction l as [|a l IHl]; simpl; intros n; split. + - now intros. + - intros. now apply Nat.le_0_l. + - intros [? ?] %Nat.max_lub_iff. now constructor; [|apply IHl]. + - intros H. apply Nat.max_lub_iff. + constructor; [exact (Forall_inv H)|apply IHl; exact (Forall_inv_tail H)]. Qed. Lemma list_max_lt : forall l n, l <> nil -> diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 826815410a..69b158a87e 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -71,7 +71,7 @@ Hint Constructors NoDupA : core. Lemma NoDupA_altdef : forall l, NoDupA l <-> ForallOrdPairs (complement eqA) l. Proof. - split; induction 1; constructor; auto. + split; induction 1 as [|a l H rest]; constructor; auto. rewrite Forall_forall. intros b Hb. intro Eq; elim H. rewrite InA_alt. exists b; auto. rewrite InA_alt; intros (a' & Haa' & Ha'). @@ -85,7 +85,7 @@ Definition inclA l l' := forall x, InA x l -> InA x l'. Definition equivlistA l l' := forall x, InA x l <-> InA x l'. Lemma incl_nil l : inclA nil l. -Proof. intro. intros. inversion H. Qed. +Proof. intros a H. inversion H. Qed. #[local] Hint Resolve incl_nil : list. @@ -128,7 +128,7 @@ Qed. Global Instance eqlistA_equiv : Equivalence eqlistA. Proof. constructor; red. - induction x; auto. + intros x; induction x; auto. induction 1; auto. intros x y z H; revert z; induction H; auto. inversion 1; subst; auto. invlist eqlistA; eauto with *. @@ -138,9 +138,9 @@ Qed. Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. Proof. - intros x x' H. induction H. + intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. intuition. - red; intros. + red; intros x0. rewrite 2 InA_cons. rewrite (IHeqlistA x0), H; intuition. Qed. @@ -165,7 +165,7 @@ Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. Proof. - simple induction l; simpl; intuition. + intros l; induction l; simpl; intuition. subst; auto. Qed. #[local] @@ -174,8 +174,9 @@ Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> exists l1 y l2, eqA x y /\ l = l1++y::l2. Proof. -induction l; intros; inv. +intros l; induction l as [|a l IHl]; intros x H; inv. exists (@nil A); exists a; exists l; auto. +match goal with H' : InA x l |- _ => rename H' into H0 end. destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). exists (a::l1); exists y; exists l2; auto. split; simpl; f_equal; auto. @@ -184,9 +185,10 @@ Qed. Lemma InA_app : forall l1 l2 x, InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. inv; auto. - elim (IHl1 l2 x H0); auto. + match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. + elim (IHl1 _ _ H0); auto. Qed. Lemma InA_app_iff : forall l1 l2 x, @@ -194,7 +196,7 @@ Lemma InA_app_iff : forall l1 l2 x, Proof. split. apply InA_app. - destruct 1; generalize H; do 2 rewrite InA_alt. + destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. destruct 1 as (y,(H1,H2)); exists y; split; auto. apply in_or_app; auto. destruct 1 as (y,(H1,H2)); exists y; split; auto. @@ -240,11 +242,12 @@ Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> (forall x, InA x l -> InA x l' -> False) -> NoDupA (l++l'). Proof. -induction l; simpl; auto; intros. +intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. inv. constructor. rewrite InA_alt; intros (y,(H4,H5)). destruct (in_app_or _ _ _ H5). +match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. elim H2. rewrite InA_alt. exists y; auto. @@ -253,13 +256,13 @@ auto. rewrite InA_alt. exists y; auto. apply IHl; auto. -intros. +intros x ? ?. apply (H1 x); auto. Qed. Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). Proof. -induction l. +intros l; induction l. simpl; auto. simpl; intros. inv. @@ -270,17 +273,17 @@ intros x. rewrite InA_alt. intros (x1,(H2,H3)). intro; inv. -destruct H0. -rewrite <- H4, H2. +match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. +match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. apply In_InA. rewrite In_rev; auto. Qed. Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l; simpl in *; intros; inv; auto. constructor; eauto. - contradict H0. + match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. rewrite InA_app_iff in *. rewrite InA_cons. intuition. @@ -288,17 +291,17 @@ Qed. Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. constructor; eauto. - assert (H2:=IHl _ _ H1). + match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. inv. rewrite InA_cons. red; destruct 1. - apply H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. rewrite InA_app_iff in *; rewrite InA_cons; auto. - apply H; auto. + auto. constructor. - contradict H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. rewrite InA_app_iff in *; rewrite InA_cons; intuition. eapply NoDupA_split; eauto. Qed. @@ -356,19 +359,21 @@ Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> NoDupA (x::l) -> NoDupA (l1++y::l2) -> equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). Proof. - intros; intro a. + intros H H0 H1 H2; intro a. generalize (H2 a). rewrite !InA_app_iff, !InA_cons. inv. assert (SW:=NoDupA_swap H1). inv. - rewrite InA_app_iff in H0. + rewrite InA_app_iff in *. split; intros. - assert (~eqA a x) by (contradict H3; rewrite <- H3; auto). + match goal with H3 : ~ InA x l |- _ => + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) + end. assert (~eqA a y) by (rewrite <- H; auto). tauto. - assert (OR : eqA a x \/ InA a l) by intuition. clear H6. + assert (OR : eqA a x \/ InA a l) by intuition. destruct OR as [EQN|INA]; auto. - elim H0. + match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. rewrite <-H,<-EQN; auto. Qed. @@ -448,7 +453,7 @@ Qed. Lemma ForallOrdPairs_inclA : forall l l', NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. Proof. -induction l' as [|x l' IH]. +intros l l'. induction l' as [|x l' IH]. constructor. intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. rewrite Forall_forall; intros y Hy. @@ -476,7 +481,7 @@ Lemma fold_right_commutes_restr : forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))). apply Comp; auto. @@ -484,7 +489,9 @@ apply IHs1. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. -rewrite Forall_forall in H0; apply H0. +match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => + rewrite Forall_forall in H0; apply H0 +end. apply in_or_app; simpl; auto. Qed. @@ -492,14 +499,14 @@ Lemma fold_right_equivlistA_restr : forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros; reflexivity. - unfold equivlistA; intros. + unfold equivlistA; intros H H0 H1 H2. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' N N' F E; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' N N' F E; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f i (s1++s2))). @@ -520,7 +527,7 @@ Lemma fold_right_add_restr : forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. Qed. End Fold_With_Restriction. @@ -532,7 +539,7 @@ Variable Tra :transpose f. Lemma fold_right_commutes : forall s1 s2 x, eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))); auto. apply Comp; auto. @@ -542,7 +549,7 @@ Lemma fold_right_equivlistA : forall s s', NoDupA s -> NoDupA s' -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. -intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -551,7 +558,7 @@ Lemma fold_right_add : forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. End Fold. @@ -571,7 +578,7 @@ Lemma fold_right_eqlistA2 : eqB (fold_right f i s) (fold_right f j s'). Proof. intros s. - induction s;intros. + induction s as [|a s IHs];intros s' i j heqij heqss'. - inversion heqss'. subst. simpl. @@ -604,7 +611,7 @@ Lemma fold_right_commutes_restr2 : forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. - apply Comp. + destruct eqA_equiv. apply Equivalence_Reflexive. + eapply fold_right_eqlistA2. @@ -617,7 +624,9 @@ induction s1; simpl; auto; intros. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. - rewrite Forall_forall in H0; apply H0. + match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => + rewrite Forall_forall in H0; apply H0 + end. apply in_or_app; simpl; auto. reflexivity. Qed. @@ -628,14 +637,14 @@ Lemma fold_right_equivlistA_restr2 : equivlistA s s' -> eqB i j -> eqB (fold_right f i s) (fold_right f j s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros. assumption. - unfold equivlistA; intros. + unfold equivlistA; intros ? ? H H0 H1 H2 **. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' i j N N' F E eqij; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' i j N N' F E eqij; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f j (s1++s2))). @@ -663,7 +672,7 @@ Lemma fold_right_add_restr2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. + intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. Qed. End Fold2_With_Restriction. @@ -674,7 +683,7 @@ Lemma fold_right_commutes2 : forall s1 s2 i x x', eqA x x' -> eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). Proof. - induction s1;simpl;intros. + intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. - apply Comp;auto. reflexivity. - transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. @@ -688,7 +697,7 @@ Lemma fold_right_equivlistA2 : equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). Proof. red in Tra. -intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -697,9 +706,9 @@ Lemma fold_right_add2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros. + intros s' s i j x **. replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. - eapply fold_right_equivlistA2;auto. + eapply fold_right_equivlistA2;auto. Qed. End Fold2. @@ -710,7 +719,7 @@ Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. Proof. -induction l. +intros x l; induction l as [|a l IHl]. right; auto. intro; inv. destruct (eqA_dec x a). @@ -729,28 +738,30 @@ Fixpoint removeA (x : A) (l : list A) : list A := Lemma removeA_filter : forall x l, removeA x l = filter (fun y => if eqA_dec x y then false else true) l. Proof. -induction l; simpl; auto. +intros x l; induction l as [|a l IHl]; simpl; auto. destruct (eqA_dec x a); auto. rewrite IHl; auto. Qed. Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. Proof. -induction l; simpl; auto. -split. +intros l; induction l as [|a l IHl]; simpl; auto. +intros x y; split. intro; inv. destruct 1; inv. -intros. +intros x y. destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. rewrite IHl; split; destruct 1; split; auto. inv; auto. -destruct H0; transitivity a; auto. +match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. split. intro; inv. split; auto. contradict Hnot. transitivity y; auto. -rewrite (IHl x y) in H0; destruct H0; auto. +match goal with H0 : InA y (removeA x l) |- _ => + rewrite (IHl x y) in H0; destruct H0; auto +end. destruct 1; inv; auto. right; rewrite IHl; auto. Qed. @@ -758,7 +769,7 @@ Qed. Lemma removeA_NoDupA : forall s x, NoDupA s -> NoDupA (removeA x s). Proof. -simple induction s; simpl; intros. +intros s; induction s as [|a s IHs]; simpl; intros x ?. auto. inv. destruct (eqA_dec x a); simpl; auto. @@ -770,16 +781,16 @@ Qed. Lemma removeA_equivlistA : forall l l' x, ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). Proof. -unfold equivlistA; intros. +unfold equivlistA; intros l l' x H H0 x0. rewrite removeA_InA. -split; intros. +split; intros H1. rewrite <- H0; split; auto. contradict H. apply InA_eqA with x0; auto. rewrite <- (H0 x0) in H1. destruct H1. inv; auto. -elim H2; auto. +match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. Qed. End Remove. @@ -806,7 +817,7 @@ Hint Constructors lelistA sort : core. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. Proof. - destruct l; constructor. inv; eauto. + intros l; destruct l; constructor. inv; eauto. Qed. Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. @@ -815,8 +826,8 @@ Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) inversion_clear Hll'. intuition. split; intro; inv; constructor. - rewrite <- Hxx', <- H; auto. - rewrite Hxx', H; auto. + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. Qed. (** For compatibility, can be deduced from [InfA_compat] *) @@ -830,9 +841,9 @@ Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. Proof. - simple induction l. - intros. inv. - intros. inv. + intros l; induction l as [|a l IHl]. + intros x a **. inv. + intros x a0 **. inv. setoid_replace x with a; auto. eauto. Qed. @@ -840,13 +851,13 @@ Qed. Lemma In_InfA : forall l x, (forall y, In y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. Lemma InA_InfA : forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. (* In fact, this may be used as an alternative definition for InfA: *) @@ -861,7 +872,7 @@ Qed. Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). Proof. - induction l1; simpl; auto. + intros l1; induction l1; simpl; auto. intros; inv; auto. Qed. @@ -870,7 +881,7 @@ Lemma SortA_app : (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> SortA (l1 ++ l2). Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1; intros l2; simpl in *; intuition. inv. constructor; auto. apply InfA_app; auto. @@ -879,8 +890,8 @@ Qed. Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. Proof. - simple induction l; auto. - intros x l' H H0. + intros l; induction l as [|x l' H]; auto. + intros H0. inv. constructor; auto. intro. @@ -922,7 +933,7 @@ Qed. Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). Proof. -repeat red. intros. +repeat red. intros x y ?. rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). apply eqlistA_rev_app; auto. Qed. @@ -936,15 +947,15 @@ Qed. Lemma SortA_equivlistA_eqlistA : forall l l', SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. Proof. -induction l; destruct l'; simpl; intros; auto. -destruct (H1 a); assert (InA a nil) by auto; inv. +intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. +destruct (H1 a0); assert (InA a0 nil) by auto; inv. destruct (H1 a); assert (InA a nil) by auto; inv. inv. assert (forall y, InA y l -> ltA a y). -intros; eapply SortA_InfA_InA with (l:=l); eauto. +intros; eapply (SortA_InfA_InA (l:=l)); eauto. assert (forall y, InA y l' -> ltA a0 y). -intros; eapply SortA_InfA_InA with (l:=l'); eauto. -clear H3 H4. +intros; eapply (SortA_InfA_InA (l:=l')); eauto. +do 2 match goal with H : InfA _ _ |- _ => clear H end. assert (eqA a a0). destruct (H1 a). destruct (H1 a0). @@ -953,13 +964,19 @@ assert (eqA a a0). elim (StrictOrder_Irreflexive a); eauto. constructor; auto. apply IHl; auto. -split; intros. +intros x; split; intros. destruct (H1 x). assert (InA x (a0::l')) by auto. inv; auto. -rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto. +match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => + rewrite H9,<-H3 in H4 +end. +elim (StrictOrder_Irreflexive a); eauto. destruct (H1 x). assert (InA x (a::l)) by auto. inv; auto. -rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto. +match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => + rewrite H9,H3 in H4 +end. +elim (StrictOrder_Irreflexive a0); eauto. Qed. End EqlistA. @@ -970,12 +987,12 @@ Section Filter. Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). Proof. -induction l; simpl; auto. +intros f l; induction l as [|a l IHl]; simpl; auto. intros; inv; auto. destruct (f a); auto. constructor; auto. apply In_InfA; auto. -intros. +intros y H. rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. @@ -984,12 +1001,14 @@ Arguments eq {A} x _. Lemma filter_InA : forall f, Proper (eqA==>eq) f -> forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. Proof. +(* Unset Mangle Names. *) clear sotrans ltA ltA_strorder ltA_compat. -intros; do 2 rewrite InA_alt; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. +intros f H l x; do 2 rewrite InA_alt; intuition; + match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. rewrite (H _ _ H0); auto. -destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. +destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. rewrite <- (H _ _ H0); auto. Qed. @@ -997,19 +1016,20 @@ Lemma filter_split : forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. Proof. -induction l; simpl; intros; auto. +intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. inv. +match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. rewrite IHl at 1; auto. case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false). - intros. +assert (forall e, In e l -> f e = false) as H3. + intros e H3. assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). case_eq (f e); simpl; intros; auto. elim (StrictOrder_Irreflexive e). transitivity a; auto. replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l; simpl; auto. -case_eq (f a); auto; intros. +generalize H3; clear; induction l as [|a l IHl]; simpl; auto. +case_eq (f a); auto; intros H H3. rewrite H3 in H; auto; try discriminate. Qed. @@ -1043,23 +1063,24 @@ Lemma findA_NoDupA : Proof. set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). -induction l; intros; simpl. -split; intros; try discriminate. +intros l; induction l as [|a l IHl]; intros a0 b H; simpl. +split; intros H0; try discriminate. invlist InA. destruct a as (a',b'); rename a0 into a. invlist NoDupA. split; intros. invlist InA. -compute in H2; destruct H2. subst b'. +match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. +subst b'. destruct (eqA_dec a a'); intuition. destruct (eqA_dec a a') as [HeqA|]; simpl. -contradict H0. -revert HeqA H2; clear - eqA_equiv. +match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. +match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. induction l. intros; invlist InA. intros; invlist InA; auto. -destruct a0. -compute in H; destruct H. +match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. +match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. subst b. left; auto. compute. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3dac62c476..23bc396fd7 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -676,7 +676,7 @@ Qed. We show instead that functional relation reification and the functional form of the axiom of choice are equivalent on decidable - relation with [nat] as codomain + relations with [nat] as codomain. *) Require Import Wf_nat. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 4735d6c9ca..a151cca3af 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -43,7 +43,7 @@ Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g #[universes(template)] Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. -Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. +Definition delta {A} (a:A) := {| pi1 := a; pi2 := a; eq := eq_refl a |}. Arguments pi1 {A} _. Arguments pi2 {A} _. diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index 131668154e..7560ea96b5 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -27,7 +27,7 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. - intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=eq_refl p). + intros U p Q x h; rewrite (M.proof_irrelevance _ h (eq_refl p)). reflexivity. Qed. End Eq_rect_eq. @@ -45,8 +45,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> exist P x p = exist P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. @@ -55,8 +55,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> existT P x p = existT P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 37d20bffad..c1928fef8d 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -30,6 +30,7 @@ *) Require Import FunInd Orders OrdersFacts MSetInterface PeanoNat. +Require Arith. (* contains deprecated dependencies *) Local Open Scope list_scope. Local Open Scope lazy_bool_scope. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 2a26b6b12a..4bf971668d 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -218,7 +218,6 @@ Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. apply Zdiv_lt_upper_bound;auto with zarith. apply Z.lt_le_trans with y;auto with zarith. rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. - assert (0 < 2^p);auto with zarith. replace (2^p) with 0. destruct x;change (0<y);auto with zarith. destruct p;trivial;discriminate. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index a3ebe67325..d3fac82d09 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -1428,7 +1428,7 @@ Proof. assert (Hp3: (0 < Φ (WW ih il))). {simpl zn2z_to_Z;apply Z.lt_le_trans with (φ ih * wB)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } + } cbv zeta. case_eq (ih <? j)%int63;intros Heq. rewrite -> ltb_spec in Heq. @@ -1465,7 +1465,6 @@ Proof. apply Hrec; rewrite H; clear u H. assert (Hf1: 0 <= Φ (WW ih il) / φ j) by (apply Z_div_pos; auto with zarith). case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hf2. - 2: contradict Heq0; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. split. replace (φ j + Φ (WW ih il) / φ j)%Z with (1 * 2 + ((φ j - 2) + Φ (WW ih il) / φ j)) by lia. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 9788ad50dc..9540bc1075 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -68,10 +68,11 @@ Ltac pi := repeat f_equal ; apply proof_irrelevance. Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. Proof. + intros A P n m. destruct n as (x,p). destruct m as (x',p'). simpl. - split ; intros ; subst. + split ; intros H ; subst. - inversion H. reflexivity. @@ -92,7 +93,7 @@ Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) (y : {y:A | y = x}), match_eq A B x fn = fn y. Proof. - intros. + intros A B x fn y. unfold match_eq. f_equal. destruct y. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 45fb48ad5d..2bf54baef3 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -535,6 +535,32 @@ Proof. now apply Permutation_cons_inv with x. Qed. +Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. + +Lemma Permutation_count_occ l1 l2 : + Permutation l1 l2 <-> forall x, count_occ eq_dec l1 x = count_occ eq_dec l2 x. +Proof. + split. + - induction 1 as [ | y l1 l2 HP IHP | y z l | l1 l2 l3 HP1 IHP1 HP2 IHP2 ]; + cbn; intros a; auto. + + now rewrite IHP. + + destruct (eq_dec y a); destruct (eq_dec z a); auto. + + now rewrite IHP1, IHP2. + - revert l2; induction l1 as [|y l1 IHl1]; cbn; intros l2 Hocc. + + replace l2 with (@nil A); auto. + symmetry; apply (count_occ_inv_nil eq_dec); intuition. + + assert (exists l2' l2'', l2 = l2' ++ y :: l2'') as [l2' [l2'' ->]]. + { specialize (Hocc y). + destruct (eq_dec y y); intuition. + apply in_split, (count_occ_In eq_dec). + rewrite <- Hocc; apply Nat.lt_0_succ. } + apply Permutation_cons_app, IHl1. + intros z; specialize (Hocc z); destruct (eq_dec y z) as [Heq | Hneq]. + * rewrite (count_occ_elt_eq _ _ _ Heq) in Hocc. + now injection Hocc. + * now rewrite (count_occ_elt_neq _ _ _ Hneq) in Hocc. + Qed. + End Permutation_properties. Section Permutation_map. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 206eb606d2..422316d879 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -71,6 +71,7 @@ Section defs. (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) -> forall l:list A, Sorted l -> P l. Proof. + intros P ? ? l. induction l. firstorder using Sorted_inv. firstorder using Sorted_inv. Qed. @@ -78,7 +79,8 @@ Section defs. Proof. split; [induction 1 as [|a l [|]]| induction 1]; auto using Sorted, LocallySorted, HdRel. - inversion H1; subst; auto using LocallySorted. + match goal with H1 : HdRel a (_ :: _) |- _ => inversion H1 end. + subst; auto using LocallySorted. Qed. (** Strongly sorted: elements of the list are pairwise ordered *) @@ -90,7 +92,7 @@ Section defs. Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) -> StronglySorted l /\ Forall (R a) l. Proof. - intros; inversion H; auto. + intros a l H; inversion H; auto. Defined. Lemma StronglySorted_rect : @@ -99,7 +101,7 @@ Section defs. (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> forall l, StronglySorted l -> P l. Proof. - induction l; firstorder using StronglySorted_inv. + intros P ? ? l; induction l; firstorder using StronglySorted_inv. Defined. Lemma StronglySorted_rec : @@ -120,7 +122,8 @@ Section defs. Lemma Sorted_extends : Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l. Proof. - intros. change match a :: l with [] => True | a :: l => Forall (R a) l end. + intros H a l H0. + change match a :: l with [] => True | a :: l => Forall (R a) l end. induction H0 as [|? ? ? ? H1]; [trivial|]. destruct H1; constructor; trivial. eapply Forall_impl; [|eassumption]. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index c923b503a7..a49e21fa92 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -93,7 +93,7 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto using eqk_equiv. + intros p q m **; apply InA_eqA with p; auto using eqk_equiv. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -106,18 +106,18 @@ Module KeyDecidableType(D:DecidableType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y; auto. + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'; auto. + destruct IH as [e H0]. exists e; auto. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -127,21 +127,21 @@ Module KeyDecidableType(D:DecidableType). Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index dc7a48cd6b..7bc9f97e2b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -65,7 +65,7 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof with auto with ordered_type. - intros; elim (compare x y); intro H; [ right | left | right ]... + intros x y; elim (compare x y); intro H; [ right | left | right ]... assert (~ eq y x)... Defined. @@ -83,7 +83,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto with ordered_type. + intros x; intro; absurd (eq x x); auto with ordered_type. Qed. Instance lt_strorder : StrictOrder lt. @@ -91,14 +91,14 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H); apply eq_trans with z... elim (lt_not_eq (lt_trans Hlt H))... Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H0); apply eq_trans with x... elim (lt_not_eq (lt_trans H0 Hlt))... Qed. @@ -111,7 +111,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Qed. Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. - Proof. intros; destruct (compare x y); auto. Qed. + Proof. intros x y; destruct (compare x y); auto. Qed. Module TO. Definition t := t. @@ -157,7 +157,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, eq x y -> exists H : eq x y, compare x y = EQ H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -165,7 +165,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt x y -> exists H : lt x y, compare x y = LT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -173,7 +173,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt y x -> exists H : lt y x, compare x y = GT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -203,7 +203,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. - intros; elim (compare x y); [ left | right | right ]; auto with ordered_type. + intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. Defined. Definition eqb x y : bool := if eq_dec x y then true else false. @@ -211,7 +211,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eqb_alt : forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. Proof. - unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. + unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. Qed. (* Specialization of results about lists modulo. *) @@ -327,7 +327,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. - exact (lt_not_eq H H1). + match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. Qed. #[local] @@ -398,18 +398,18 @@ Module KeyOrderedType(O:OrderedType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof with auto with ordered_type. - firstorder. - exists x... - induction H. - destruct y. - exists e... - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y... + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'... + destruct IH as [e H0]. exists e... Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -437,7 +437,7 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_Inf_NotIn : forall l k e, Sort l -> Inf (k,e) l -> ~In k l. Proof. - intros; red; intros. + intros l k e H H0; red; intros H1. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). eapply Sort_Inf_In; eauto with ordered_type. @@ -457,34 +457,34 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto with ordered_type. + intros l; inversion_clear 2; auto with ordered_type. left; apply Sort_In_cons_1 with l; auto. Qed. Lemma Sort_In_cons_3 : forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. Proof. - inversion_clear 1; red; intros. + inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto with ordered_type. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto with ordered_type. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 10545332bb..227ac00e79 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -14,9 +14,9 @@ Institution: PPS, INRIA 12/2010 *) -Require Fin. +Require Fin List. Require Import VectorDef PeanoNat Eqdep_dec. -Import VectorNotations. +Import VectorNotations EqNotations. Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} (eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 := @@ -233,15 +233,6 @@ assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). + simpl. intros; now rewrite<- (IHv). Qed. -(** ** Properties of [to_list] *) - -Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. -Proof. -induction l. -- reflexivity. -- unfold to_list; simpl. now f_equal. -Qed. - (** ** Properties of [take] *) Lemma take_O : forall {A} {n} le (v:t A n), take 0 le v = []. @@ -387,3 +378,147 @@ intros P n v1 v2; split; induction n as [|n IHn]. (proj1 (Nat.succ_lt_mono _ _) Hi2). now rewrite <- (nth_order_tl _ _ _ _ Hi1), <- (nth_order_tl _ _ _ _ Hi2) in HP. Qed. + +(** ** Properties of [to_list] *) + +Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. +Proof. +induction l. +- reflexivity. +- unfold to_list; simpl. now f_equal. +Qed. + +Lemma length_to_list A n (v : t A n): length (to_list v) = n. +Proof. induction v; cbn; auto. Qed. + +Lemma of_list_to_list_opp A n (v: t A n): + rew length_to_list _ _ _ in of_list (to_list v) = v. +Proof. +induction v as [ | h n v IHv ]. +- now apply case0 with (P := fun v => v = nil A). +- replace (length_to_list _ _ (cons _ h _ v)) with (f_equal S (length_to_list _ _ v)) + by apply (UIP_dec Nat.eq_dec). + cbn; rewrite map_subst_map. + f_equal. + now etransitivity; [ | apply IHv]. +Qed. + +Lemma to_list_nil A : to_list (nil A) = List.nil. +Proof. reflexivity. Qed. + +Lemma to_list_cons A h n (v : t A n): + to_list (cons A h n v) = List.cons h (to_list v). +Proof. reflexivity. Qed. + +Lemma to_list_hd A n (v : t A (S n)) d: + hd v = List.hd d (to_list v). +Proof. now rewrite (eta v). Qed. + +Lemma to_list_last A n (v : t A (S n)) d: + last v = List.last (to_list v) d. +Proof. +apply rectS with (v:=v); trivial. +intros a k u IH. +rewrite to_list_cons. +simpl List.last. +now rewrite <- IH, (eta u). +Qed. + +Lemma to_list_const A (a : A) n: + to_list (const a n) = List.repeat a n. +Proof. +induction n as [ | n IHn ]; trivial. +now cbn; rewrite <- IHn. +Qed. + +Lemma to_list_nth_order A n (v : t A n) p (H : p < n) d: + nth_order v H = List.nth p (to_list v) d. +Proof. +revert n v H; induction p as [ | p IHp ]; intros n v H; + (destruct n; [ inversion H | rewrite (eta v) ]); trivial. +now rewrite <- nth_order_tl with (H:=Lt.lt_S_n _ _ H), IHp. +Qed. + +Lemma to_list_tl A n (v : t A (S n)): + to_list (tl v) = List.tl (to_list v). +Proof. now rewrite (eta v). Qed. + +Lemma to_list_append A n m (v1 : t A n) (v2 : t A m): + to_list (append v1 v2) = List.app (to_list v1) (to_list v2). +Proof. +induction v1; simpl; trivial. +now rewrite to_list_cons; f_equal. +Qed. + +Lemma to_list_rev_append_tail A n m (v1 : t A n) (v2 : t A m): + to_list (rev_append_tail v1 v2) = List.rev_append (to_list v1) (to_list v2). +Proof. now revert m v2; induction v1 as [ | ? ? ? IHv1 ]; intros; [ | simpl; rewrite IHv1 ]. Qed. + +Lemma to_list_rev_append A n m (v1 : t A n) (v2 : t A m): + to_list (rev_append v1 v2) = List.rev_append (to_list v1) (to_list v2). +Proof. unfold rev_append; rewrite (Plus.plus_tail_plus n m); apply to_list_rev_append_tail. Qed. + +Lemma to_list_rev A n (v : t A n): + to_list (rev v) = List.rev (to_list v). +Proof. +unfold rev; rewrite (plus_n_O n); unfold eq_rect_r; simpl. +now rewrite to_list_rev_append, List.rev_alt. +Qed. + +Lemma to_list_map A B (f : A -> B) n (v : t A n) : + to_list (map f v) = List.map f (to_list v). +Proof. +induction v; cbn; trivial. +now cbn; f_equal. +Qed. + +Lemma to_list_fold_left A B f (b : B) n (v : t A n): + fold_left f b v = List.fold_left f (to_list v) b. +Proof. now revert b; induction v; cbn. Qed. + +Lemma to_list_fold_right A B f (b : B) n (v : t A n): + fold_right f v b = List.fold_right f b (to_list v). +Proof. now revert b; induction v; cbn; intros; f_equal. Qed. + +Lemma to_list_Forall A P n (v : t A n): + Forall P v <-> List.Forall P (to_list v). +Proof. +split; intros HF. +- induction HF; now constructor. +- remember (to_list v) as l. + revert n v Heql; induction HF; intros n v Heql; + destruct v; inversion Heql; subst; constructor; auto. +Qed. + +Lemma to_list_Exists A P n (v : t A n): + Exists P v <-> List.Exists P (to_list v). +Proof. +split; intros HF. +- induction HF; now constructor. +- remember (to_list v) as l. + revert n v Heql; induction HF; intros n v Heql; + destruct v; inversion Heql; subst; now constructor; auto. +Qed. + +Lemma to_list_In A a n (v : t A n): + In a v <-> List.In a (to_list v). +Proof. +split. +- intros HIn; induction HIn; now constructor. +- induction v; intros HIn; inversion HIn; subst; constructor; auto. +Qed. + +Lemma to_list_Forall2 A B P n (v1 : t A n) (v2 : t B n) : + Forall2 P v1 v2 <-> List.Forall2 P (to_list v1) (to_list v2). +Proof. +split; intros HF. +- induction HF; now constructor. +- remember (to_list v1) as l1. + remember (to_list v2) as l2. + revert n v1 v2 Heql1 Heql2; induction HF; intros n v1 v2 Heql1 Heql2. + + destruct v1; [ | inversion Heql1 ]. + apply case0 with (P0 := fun x => Forall2 P (nil A) x); constructor. + + destruct v1; inversion Heql1; subst. + rewrite (eta v2) in Heql2; inversion Heql2; subst. + rewrite (eta v2); constructor; auto. +Qed. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 47137414dc..ff1a2b5a53 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1775,8 +1775,6 @@ weak_Zmult_plus_distr_r (now Z.mul_add_distr_pos) Definition Zne (x y:Z) := x <> y. (* TODO : to remove someday ? *) -Register Zne as plugins.omega.Zne. - Ltac elim_compare com1 com2 := case (Dcompare (com1 ?= com2)%Z); [ idtac | let x := fresh "H" in diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index ed47539e1e..5490044ac7 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -16,9 +16,11 @@ Require Export ZArith_base. Require Export Zpow_def. -(** Extra modules using [Omega] or [Ring]. *) +(** Extra modules using [Ring]. *) -Require Export Omega. +Require Export OmegaLemmas. +Require Export PreOmega. +Require Export ZArith_hints. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 7f72d42d1f..b7cd849323 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -959,13 +959,6 @@ Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m). Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m). Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m). -Register neq as plugins.omega.neq. -Register inj_eq as plugins.omega.inj_eq. -Register inj_neq as plugins.omega.inj_neq. -Register inj_le as plugins.omega.inj_le. -Register inj_lt as plugins.omega.inj_lt. -Register inj_ge as plugins.omega.inj_ge. -Register inj_gt as plugins.omega.inj_gt. (** For the others, a Notation is fine *) @@ -1033,5 +1026,3 @@ Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0. Proof. intros. rewrite not_le_minus_0; auto with arith. Qed. - -Register inj_minus2 as plugins.omega.inj_minus2. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 4c533ac458..bef9cede12 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -64,11 +64,6 @@ Proof. apply Z.lt_gt_cases. Qed. -Register dec_Zne as plugins.omega.dec_Zne. -Register dec_Zgt as plugins.omega.dec_Zgt. -Register dec_Zge as plugins.omega.dec_Zge. -Register not_Zeq as plugins.omega.not_Zeq. - (** * Relating strict and large orders *) Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing). @@ -120,12 +115,6 @@ Proof. destruct (Z.eq_decidable n m); [assumption|now elim H]. Qed. -Register Znot_le_gt as plugins.omega.Znot_le_gt. -Register Znot_lt_ge as plugins.omega.Znot_lt_ge. -Register Znot_ge_lt as plugins.omega.Znot_ge_lt. -Register Znot_gt_le as plugins.omega.Znot_gt_le. -Register not_Zne as plugins.omega.not_Zne. - (** * Equivalence and order properties *) (** Reflexivity *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 10ea6cc03e..369a0c46ae 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -93,11 +93,3 @@ Proof. apply Z.le_lt_trans with (m*n+p); trivial. now apply Z.add_lt_mono_l. Qed. - -Register Zegal_left as plugins.omega.Zegal_left. -Register Zne_left as plugins.omega.Zne_left. -Register Zlt_left as plugins.omega.Zlt_left. -Register Zgt_left as plugins.omega.Zgt_left. -Register Zle_left as plugins.omega.Zle_left. -Register Zge_left as plugins.omega.Zge_left. -Register Zmult_le_approx as plugins.omega.Zmult_le_approx. diff --git a/theories/dune b/theories/dune index 1cd3d8c119..57b97f080c 100644 --- a/theories/dune +++ b/theories/dune @@ -22,7 +22,6 @@ coq-core.plugins.ring coq-core.plugins.nsatz - coq-core.plugins.omega coq-core.plugins.zify coq-core.plugins.micromega @@ -34,3 +33,6 @@ coq-core.plugins.derive)) (include_subdirs qualified) + +(documentation + (package coq-stdlib)) diff --git a/theories/extraction/ExtrOcamlBigIntConv.v b/theories/extraction/ExtrOcamlBigIntConv.v index 29bd732c78..b4aed4c3f7 100644 --- a/theories/extraction/ExtrOcamlBigIntConv.v +++ b/theories/extraction/ExtrOcamlBigIntConv.v @@ -8,12 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction to Ocaml: conversion from/to [big_int] *) +(** Extraction to OCaml: conversion from/to [Z.t] *) -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) Require Coq.extraction.Extraction. diff --git a/theories/extraction/ExtrOcamlNatBigInt.v b/theories/extraction/ExtrOcamlNatBigInt.v index 8a7ba92a94..c854f8fd5d 100644 --- a/theories/extraction/ExtrOcamlNatBigInt.v +++ b/theories/extraction/ExtrOcamlNatBigInt.v @@ -8,17 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction of [nat] into Ocaml's [big_int] *) +(** Extraction of [nat] into Zarith's [Z.t] *) Require Coq.extraction.Extraction. Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) (** Disclaimer: trying to obtain efficient certified programs by extracting [nat] into [big_int] isn't necessarily a good idea. diff --git a/theories/extraction/ExtrOcamlZBigInt.v b/theories/extraction/ExtrOcamlZBigInt.v index 40a47b36fa..df9153a46d 100644 --- a/theories/extraction/ExtrOcamlZBigInt.v +++ b/theories/extraction/ExtrOcamlZBigInt.v @@ -8,17 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *) +(** Extraction of [positive], [N], and [Z], into Zarith's [Z.t] *) Require Coq.extraction.Extraction. Require Import ZArith NArith. Require Import ExtrOcamlBasic. -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) (** Disclaimer: trying to obtain efficient certified programs by extracting [Z] into [big_int] isn't necessarily a good idea. diff --git a/theories/index.mld b/theories/index.mld new file mode 100644 index 0000000000..360864342b --- /dev/null +++ b/theories/index.mld @@ -0,0 +1,3 @@ +{0 coq-stdlib } + +The coq-stdlib package only contains Coq theory files for the standard library and no OCaml libraries. diff --git a/theories/micromega/OrderedRing.v b/theories/micromega/OrderedRing.v index 5fa3740ab1..bfbd6fd8d3 100644 --- a/theories/micromega/OrderedRing.v +++ b/theories/micromega/OrderedRing.v @@ -423,7 +423,7 @@ Qed. (* The following theorems are used to build a morphism from Z to R and prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) -(* Surprisingly, multilication is needed to prove the following theorem *) +(* Surprisingly, multiplication is needed to prove the following theorem *) Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. Proof. @@ -457,4 +457,3 @@ apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. Qed.*) End STRICT_ORDERED_RING. - diff --git a/theories/micromega/Zify.v b/theories/micromega/Zify.v index 01cc9ad810..3a50001b1f 100644 --- a/theories/micromega/Zify.v +++ b/theories/micromega/Zify.v @@ -33,5 +33,6 @@ Ltac zify := intros; zify_elim_let ; zify_op ; (zify_iter_specs) ; - zify_saturate ; - zify_to_euclidean_division_equations ; zify_post_hook. + zify_to_euclidean_division_equations ; + zify_post_hook; + zify_saturate. diff --git a/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v index f6ade67c5f..019d11d951 100644 --- a/theories/micromega/ZifyClasses.v +++ b/theories/micromega/ZifyClasses.v @@ -250,8 +250,18 @@ Register rew_iff as ZifyClasses.rew_iff. Register source_prop as ZifyClasses.source_prop. Register injprop_ok as ZifyClasses.injprop_ok. Register iff as ZifyClasses.iff. + +Register InjTyp as ZifyClasses.InjTyp. +Register BinOp as ZifyClasses.BinOp. +Register UnOp as ZifyClasses.UnOp. +Register CstOp as ZifyClasses.CstOp. +Register BinRel as ZifyClasses.BinRel. +Register PropOp as ZifyClasses.PropOp. +Register PropUOp as ZifyClasses.PropUOp. Register BinOpSpec as ZifyClasses.BinOpSpec. Register UnOpSpec as ZifyClasses.UnOpSpec. +Register Saturate as ZifyClasses.Saturate. + (** Propositional logic *) Register and as ZifyClasses.and. @@ -264,3 +274,4 @@ Register impl_morph as ZifyClasses.impl_morph. Register not as ZifyClasses.not. Register not_morph as ZifyClasses.not_morph. Register True as ZifyClasses.True. +Register I as ZifyClasses.I. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index 9881e73f76..8dee70be45 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -307,15 +307,15 @@ Instance Op_N_mul : BinOp N.mul := Add Zify BinOp Op_N_mul. Instance Op_N_sub : BinOp N.sub := - {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}. + {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max |}. Add Zify BinOp Op_N_sub. Instance Op_N_div : BinOp N.div := - {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}. + {| TBOp := Z.div ; TBOpInj := N2Z.inj_div |}. Add Zify BinOp Op_N_div. Instance Op_N_mod : BinOp N.modulo := - {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}. + {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem |}. Add Zify BinOp Op_N_mod. Instance Op_N_pred : UnOp N.pred := @@ -332,19 +332,19 @@ Add Zify UnOp Op_N_succ. (* zify_Z_rel *) Instance Op_Z_ge : BinRel Z.ge := - {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y)|}. + {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y) |}. Add Zify BinRel Op_Z_ge. Instance Op_Z_lt : BinRel Z.lt := - {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y)|}. + {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y) |}. Add Zify BinRel Op_Z_lt. Instance Op_Z_gt : BinRel Z.gt := - {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y)|}. + {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y) |}. Add Zify BinRel Op_Z_gt. Instance Op_Z_le : BinRel Z.le := - {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y)|}. + {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y) |}. Add Zify BinRel Op_Z_le. Instance Op_eqZ : BinRel (@eq Z) := @@ -460,7 +460,7 @@ Add Zify UnOp Op_Z_to_nat. (** Specification of derived operators over Z *) Instance ZmaxSpec : BinOpSpec Z.max := - {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. + {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec |}. Add Zify BinOpSpec ZmaxSpec. Instance ZminSpec : BinOpSpec Z.min := @@ -470,49 +470,30 @@ Add Zify BinOpSpec ZminSpec. Instance ZsgnSpec : UnOpSpec Z.sgn := {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ; - USpec := Z.sgn_spec|}. + USpec := Z.sgn_spec |}. Add Zify UnOpSpec ZsgnSpec. Instance ZabsSpec : UnOpSpec Z.abs := {| UPred := fun n r: Z => 0 <= n /\ r = n \/ n < 0 /\ r = - n ; - USpec := Z.abs_spec|}. + USpec := Z.abs_spec |}. Add Zify UnOpSpec ZabsSpec. (** Saturate positivity constraints *) -Instance SatProd : Saturate Z.mul := - {| - PArg1 := fun x => 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun r => 0 <= r; - SatOk := Z.mul_nonneg_nonneg - |}. -Add Zify Saturate SatProd. - -Instance SatProdPos : Saturate Z.mul := +Instance SatPowPos : Saturate Z.pow := {| PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; + PArg2 := fun y => 0 <= y; PRes := fun r => 0 < r; - SatOk := Z.mul_pos_pos + SatOk := Z.pow_pos_nonneg |}. -Add Zify Saturate SatProdPos. - -Lemma pow_pos_strict : - forall a b, - 0 < a -> 0 < b -> 0 < a ^ b. -Proof. - intros. - apply Z.pow_pos_nonneg; auto. - apply Z.lt_le_incl;auto. -Qed. - +Add Zify Saturate SatPowPos. -Instance SatPowPos : Saturate Z.pow := +Instance SatPowNonneg : Saturate Z.pow := {| - PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; - PRes := fun r => 0 < r; - SatOk := pow_pos_strict + PArg1 := fun x => 0 <= x; + PArg2 := fun y => True; + PRes := fun r => 0 <= r; + SatOk := fun a b Ha _ => @Z.pow_nonneg a b Ha |}. -Add Zify Saturate SatPowPos. +Add Zify Saturate SatPowNonneg. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v deleted file mode 100644 index 5c52284621..0000000000 --- a/theories/omega/Omega.v +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(* We import what is necessary for Omega *) -Require Export ZArith_base. -Require Export OmegaLemmas. -Require Export PreOmega. -Require Export ZArith_hints. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/OmegaLemmas.v b/theories/omega/OmegaLemmas.v index 08e9ac345d..8ccd8d76f6 100644 --- a/theories/omega/OmegaLemmas.v +++ b/theories/omega/OmegaLemmas.v @@ -261,47 +261,3 @@ Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. - -Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. -Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. -Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. -Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. -Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. -Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. - -Register OMEGA1 as plugins.omega.OMEGA1. -Register OMEGA2 as plugins.omega.OMEGA2. -Register OMEGA3 as plugins.omega.OMEGA3. -Register OMEGA4 as plugins.omega.OMEGA4. -Register OMEGA5 as plugins.omega.OMEGA5. -Register OMEGA6 as plugins.omega.OMEGA6. -Register OMEGA7 as plugins.omega.OMEGA7. -Register OMEGA8 as plugins.omega.OMEGA8. -Register OMEGA9 as plugins.omega.OMEGA9. -Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. -Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. -Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. -Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. -Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. -Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. -Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. -Register OMEGA17 as plugins.omega.OMEGA17. -Register OMEGA18 as plugins.omega.OMEGA18. -Register OMEGA19 as plugins.omega.OMEGA19. -Register OMEGA20 as plugins.omega.OMEGA20. - -Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. -Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. -Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. -Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. -Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. -Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. -Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. - -Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. -Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. -Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. -Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. - -Register new_var as plugins.omega.new_var. -Register intro_Z as plugins.omega.intro_Z. diff --git a/theories/omega/OmegaPlugin.v b/theories/omega/OmegaPlugin.v deleted file mode 100644 index e0cf24f6aa..0000000000 --- a/theories/omega/OmegaPlugin.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/OmegaTactic.v b/theories/omega/OmegaTactic.v deleted file mode 100644 index e0cf24f6aa..0000000000 --- a/theories/omega/OmegaTactic.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/PreOmega.v b/theories/omega/PreOmega.v index 70f25e7243..bf873785d0 100644 --- a/theories/omega/PreOmega.v +++ b/theories/omega/PreOmega.v @@ -12,9 +12,10 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Local Open Scope Z_scope. -(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) +(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: + the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) -(** These tactic use the complete specification of [Z.div] and +(** These tactics use the complete specification of [Z.div] and [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these functions from the goal without losing information. The [Z.euclidean_division_equations_cleanup] tactic removes needless @@ -127,449 +128,6 @@ Module Z. Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. End Z. -Set Warnings "-deprecated-tactic". - -(** * zify: the Z-ification tactic *) - -(* This tactic searches for nat and N and positive elements in the goal and - translates everything into Z. It is meant as a pre-processor for - (r)omega; for instance a positivity hypothesis is added whenever - - a multiplication is encountered - - an atom is encountered (that is a variable or an unknown construct) - - Recognized relations (can be handled as deeply as allowed by setoid rewrite): - - { eq, le, lt, ge, gt } on { Z, positive, N, nat } - - Recognized operations: - - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < = - - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat - - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat - - on N: N0 Npos + * - N.pred N.succ N.min N.max N.of_nat Z.abs_N -*) - - - - -(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - pose proof (thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop t thm a := - (* If a is a scalar, we can simply reduce the unop. *) - (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) - let isz := isZcst a in - match isz with - | true => - let u := eval compute in (t a) in - change (t a) with u in * - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_op_1 := - match goal with - | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b - | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b - | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b - | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b - | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a - | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a - | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a - | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a - end. - -Ltac zify_op := repeat zify_op_1. - - -(** II) Conversion from nat to Z *) - - -Definition Z_of_nat' := Z.of_nat. - -Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z.of_nat t) in *; - change Z.of_nat with Z_of_nat' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat_rel := - match goal with - (* I: equalities *) - | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) - | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H - | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) - (* II: less than *) - | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H - | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H - | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) - (* IV: greater than *) - | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H - | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H - | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) - end. - -Ltac zify_nat_op := - match goal with - (* misc type conversions: positive/N/Z to nat *) - | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H - | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) - | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H - | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) - | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H - | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) - - (* plus -> Z.add *) - | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H - | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) - - (* min -> Z.min *) - | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H - | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) - - (* max -> Z.max *) - | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H - | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) - - (* minus -> Z.max (Z.sub ... ...) 0 *) - | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H - | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H - | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) - - (* mult -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - | |- context [ Z.of_nat (mult ?a ?b) ] => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - - (* O -> Z0 *) - | H : context [ Z.of_nat O ] |- _ => change (Z.of_nat O) with Z0 in H - | |- context [ Z.of_nat O ] => change (Z.of_nat O) with Z0 - - (* S -> number or Z.succ *) - | H : context [ Z.of_nat (S ?a) ] |- _ => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t in H - | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in this one hypothesis *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H - end - | |- context [ Z.of_nat (S ?a) ] => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t - | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in the goal *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) - end - - (* atoms of type nat : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a - | _ : context [ Z.of_nat ?a ] |- _ => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - | |- context [ Z.of_nat ?a ] => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - -(* III) conversion from positive to Z *) - -Definition Zpos' := Zpos. -Definition Zneg' := Zneg. - -Ltac hide_Zpos t := - let z := fresh "z" in set (z:=Zpos t) in *; - change Zpos with Zpos' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_rel := - match goal with - (* I: equalities *) - | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq positive ?a ?b) => apply Pos2Z.inj - | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H - | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H - | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H - | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) - (* IV: greater than *) - | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H - | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H - | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_op := - match goal with - (* Z.pow_pos -> Z.pow *) - | H : context [ Z.pow_pos ?a ?b ] |- _ => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) in H - | |- context [ Z.pow_pos ?a ?b ] => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) - (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) in H - | _ => change (Zneg a) with (- Zpos a) in H - end - | |- context [ Zneg ?a ] => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) - | _ => change (Zneg a) with (- Zpos a) - end - - (* misc type conversions: nat to positive *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Z.power_pos *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Pos.add -> Z.add *) - | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H - | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) - - (* Pos.min -> Z.min *) - | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H - | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) - - (* Pos.max -> Z.max *) - | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H - | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) - - (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) - | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub_max a b) in H - | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub_max a b) - - (* Pos.succ -> Z.succ *) - | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H - | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) - - (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) - | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H - | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) - - (* Pos.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Zpos (?a * ?b) ] |- _ => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - | |- context [ Zpos (?a * ?b) ] => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - - (* xO *) - | H : context [ Zpos (xO ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H - | _ => rewrite (Pos2Z.inj_xO a) in H - end - | |- context [ Zpos (xO ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) - | _ => rewrite (Pos2Z.inj_xO a) - end - (* xI *) - | H : context [ Zpos (xI ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H - | _ => rewrite (Pos2Z.inj_xI a) in H - end - | |- context [ Zpos (xI ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) - | _ => rewrite (Pos2Z.inj_xI a) - end - - (* xI : nothing to do, just prevent adding a useless positivity condition *) - | H : context [ Zpos xH ] |- _ => hide_Zpos xH - | |- context [ Zpos xH ] => hide_Zpos xH - - (* atoms of type positive : we add a positivity condition (if not already there) *) - | _ : 0 < Zpos ?a |- _ => hide_Zpos a - | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a - | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive := - repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. - - - - - -(* IV) conversion from N to Z *) - -Definition Z_of_N' := Z.of_N. - -Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z.of_N t) in *; - change Z.of_N with Z_of_N' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_rel := - match goal with - (* I: equalities *) - | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) - | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H - | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H - | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H - | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) - (* IV: greater than *) - | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H - | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H - | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_op := - match goal with - (* misc type conversions: nat to positive *) - | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H - | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) - | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H - | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) - | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H - | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) - | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H - | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 - - (* N.add -> Z.add *) - | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H - | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) - - (* N.min -> Z.min *) - | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H - | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) - - (* N.max -> Z.max *) - | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H - | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) - - (* N.sub -> Z.max 0 (Z.sub ... ...) *) - | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H - | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_N (N.pred ?a) ] |- _ => rewrite (N.pred_sub a) in H - | |- context [ Z.of_N (N.pred ?a) ] => rewrite (N.pred_sub a) - - (* N.succ -> Z.succ *) - | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H - | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) - - (* N.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - | |- context [ Z.of_N (N.mul ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - - (* N.div -> Z.div and a positivity hypothesis *) - | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - - (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) - | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - - (* atoms of type N : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a - | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. - -(** The complete Z-ification tactic *) - Require Import ZifyClasses ZifyInst. Require Zify. diff --git a/tools/coqdep.ml b/tools/coqdep.ml index f1dbac889b..199fc4225d 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -34,7 +34,8 @@ let usage () = eprintf " -boot : For coq developers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; - eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE."; + eprintf " -noinit : currently no effect\n"; + eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE.\n"; eprintf " -I dir : add (non recursively) dir to ocaml path\n"; eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recursively) and open (non recursively) dir to coq load path under logical name logname\n"; @@ -64,6 +65,7 @@ let rec parse = function | "-sort" :: ll -> option_sort := true; parse ll | "-vos" :: ll -> write_vos := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll + | "-noinit" :: ll -> (* do nothing *) parse ll | "-f" :: f :: ll -> treat_coqproject f; parse ll | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () @@ -80,6 +82,8 @@ let rec parse = function | "-dyndep" :: "both" :: ll -> option_dynlink := Both; parse ll | "-dyndep" :: "var" :: ll -> option_dynlink := Variable; parse ll | ("-h"|"--help"|"-help") :: _ -> usage () + | opt :: ll when String.length opt > 0 && opt.[0] = '-' -> + coqdep_warning "unknown option %s" opt; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index dca9291da3..a6634586f3 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -157,6 +157,18 @@ let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 +let error_cannot_stat s unix_error = + (* Print an arbitrary line number, such that the message matches + common error message pattern. *) + Printf.eprintf "File \"%s\", line 1: %s\n" s (error_message unix_error); + exit 1 + +let error_cannot_open s msg = + (* Print an arbitrary line number, such that the message matches + common error message pattern. *) + Printf.eprintf "File \"%s\", line 1: %s\n" s msg; + exit 1 + let warning_module_notfound f s = coqdep_warning "in file %s, library %s is required and has not been found in the loadpath!" f (String.concat "." s) @@ -368,7 +380,7 @@ let rec find_dependencies basename = | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j) - with Sys_error _ -> [] (* TODO: report an error? *) + with Sys_error msg -> error_cannot_open (basename ^ ".v") msg let write_vos = ref false @@ -472,7 +484,12 @@ let rec treat_file old_dirname old_name = | (Some d1,d2) -> Some (d1//d2) in let complete_name = file_name name dirname in - match try (stat complete_name).st_kind with _ -> S_BLK with + let stat_res = + try stat complete_name + with Unix_error(error, _, _) -> error_cannot_stat complete_name error + in + match stat_res.st_kind + with | S_DIR -> (if name.[0] <> '.' then let newdirname = diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index cc888a959f..432d88b2ff 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -5,6 +5,13 @@ (coqdoc.css as tools/coqdoc/coqdoc.css) (coqdoc.sty as tools/coqdoc/coqdoc.sty))) +; File needs to be here too. +(install + (section share) + (package coq-core) + (files + (coqdoc.sty as texmf/tex/latex/misc/coqdoc.sty))) + (executable (name main) (public_name coqdoc) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 9cb3baf92c..e0a1d40395 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -74,7 +74,7 @@ let is_tactic = "info"; "field"; "specialize"; "evar"; "solve"; "instantiate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; - "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; + "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "set"; "assert"; "do"; "repeat"; "cut"; "assumption"; "exact"; "split"; "subst"; "try"; "discriminate"; "simpl"; "unfold"; "red"; "compute"; "at"; "in"; "by"; diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 041097d2d3..df6f04792e 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -194,7 +194,7 @@ let compile opts stm_options injections copts ~echo ~f_in ~f_out = if mode = BuildVio then dump_empty_vos() | Vio2Vo -> - + Flags.async_proofs_worker_id := "Vio2Vo"; let sum, lib, univs, tasks, proofs = Library.load_library_todo long_f_dot_in in let univs, proofs = Stm.finish_tasks long_f_dot_out univs proofs tasks in @@ -223,6 +223,7 @@ let compile_file opts stm_opts copts injections = (* VIO Dispatching *) (******************************************************************************) let check_vio_tasks copts = + Flags.async_proofs_worker_id := "VioChecking"; let rc = List.fold_left (fun acc (n,f) -> let f_in = ensure ".vio" f f in diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index b7af66b2ee..b78bcce6db 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -26,6 +26,8 @@ let coqc_specific_usage = Usage.{ coqc specific options:\ \n -o f.vo use f.vo as the output file name\ \n -verbose compile and output the input file\ +\n -noglob do not dump globalizations\ +\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ \n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ diff --git a/user-contrib/Ltac2/Array.v b/user-contrib/Ltac2/Array.v index 5adba829c5..b5e7f37c9f 100644 --- a/user-contrib/Ltac2/Array.v +++ b/user-contrib/Ltac2/Array.v @@ -70,7 +70,7 @@ Ltac2 init (l : int) (f : int->'a) := | true => empty () | false => let arr:=make l (f 0) in - init_aux arr 0 (length arr) f; + init_aux arr 1 (Int.sub l 1) f; arr end. diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 72cac900cd..fa056910b8 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -96,3 +96,54 @@ Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "lt Ltac2 @ external pretype : preterm -> constr := "ltac2" "constr_pretype". (** Pretype the provided preterm. Assumes the goal to be focussed. *) + + +Ltac2 is_evar(c: constr) := + match Unsafe.kind c with + | Unsafe.Evar _ _ => true + | _ => false + end. + +Ltac2 @ external has_evar : constr -> bool := "ltac2" "constr_has_evar". + +Ltac2 is_var(c: constr) := + match Unsafe.kind c with + | Unsafe.Var _ => true + | _ => false + end. + +Ltac2 is_fix(c: constr) := + match Unsafe.kind c with + | Unsafe.Fix _ _ _ _ => true + | _ => false + end. + +Ltac2 is_cofix(c: constr) := + match Unsafe.kind c with + | Unsafe.CoFix _ _ _ => true + | _ => false + end. + +Ltac2 is_ind(c: constr) := + match Unsafe.kind c with + | Unsafe.Ind _ _ => true + | _ => false + end. + +Ltac2 is_constructor(c: constr) := + match Unsafe.kind c with + | Unsafe.Constructor _ _ => true + | _ => false + end. + +Ltac2 is_proj(c: constr) := + match Unsafe.kind c with + | Unsafe.Proj _ _ => true + | _ => false + end. + +Ltac2 is_const(c: constr) := + match Unsafe.kind c with + | Unsafe.Constant _ _ => true + | _ => false + end. diff --git a/user-contrib/Ltac2/Control.v b/user-contrib/Ltac2/Control.v index 8b9d53a433..31c8871ff8 100644 --- a/user-contrib/Ltac2/Control.v +++ b/user-contrib/Ltac2/Control.v @@ -98,6 +98,12 @@ Ltac2 assert_bounds (msg : string) (test : bool) := | false => throw_out_of_bounds msg end. +Ltac2 assert_true b := + if b then () else throw Assertion_failure. + +Ltac2 assert_false b := + if b then throw Assertion_failure else (). + (** Short form backtracks *) Ltac2 backtrack_tactic_failure (msg : string) := diff --git a/user-contrib/Ltac2/Env.v b/user-contrib/Ltac2/Env.v index d7c5e693f6..9ab95e6d03 100644 --- a/user-contrib/Ltac2/Env.v +++ b/user-contrib/Ltac2/Env.v @@ -16,7 +16,7 @@ Ltac2 @ external get : ident list -> Std.reference option := "ltac2" "env_get". Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". (** Returns the list of all global references whose absolute name contains - the argument list as a prefix. *) + the argument list as a suffix. *) Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". (** Returns the absolute name of the given reference. Panics if the reference diff --git a/user-contrib/Ltac2/Ind.v b/user-contrib/Ltac2/Ind.v new file mode 100644 index 0000000000..f397a0e2c8 --- /dev/null +++ b/user-contrib/Ltac2/Ind.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +From Ltac2 Require Import Init. + +Ltac2 Type t := inductive. + +Ltac2 @ external equal : t -> t -> bool := "ltac2" "ind_equal". +(** Equality test. *) + +Ltac2 Type data. +(** Type of data representing inductive blocks. *) + +Ltac2 @ external data : t -> data := "ltac2" "ind_data". +(** Get the mutual blocks corresponding to an inductive type in the current + environment. Panics if there is no such inductive. *) + +Ltac2 @ external repr : data -> t := "ltac2" "ind_repr". +(** Returns the inductive corresponding to the block. Inverse of [data]. *) + +Ltac2 @ external index : t -> int := "ltac2" "ind_index". +(** Returns the index of the inductive type inside its mutual block. Guaranteed + to range between [0] and [nblocks data - 1] where [data] was retrieved + using the above function. *) + +Ltac2 @ external nblocks : data -> int := "ltac2" "ind_nblocks". +(** Returns the number of inductive types appearing in a mutual block. *) + +Ltac2 @ external nconstructors : data -> int := "ltac2" "ind_nconstructors". +(** Returns the number of constructors appearing in the current block. *) + +Ltac2 @ external get_block : data -> int -> data := "ltac2" "ind_get_block". +(** Returns the block corresponding to the nth inductive type. Index must range + between [0] and [nblocks data - 1], otherwise the function panics. *) + +Ltac2 @ external get_constructor : data -> int -> constructor := "ltac2" "ind_get_constructor". +(** Returns the nth constructor of the inductive type. Index must range between + [0] and [nconstructors data - 1], otherwise the function panics. *) diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index 097a0ca25f..19c89d7266 100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v @@ -80,3 +80,6 @@ Ltac2 Type exn ::= [ Invalid_argument (message option) ]. Ltac2 Type exn ::= [ Tactic_failure (message option) ]. (** Generic error for tactic failure. *) + +Ltac2 Type exn ::= [ Assertion_failure ]. +(** Used to indicate that an Ltac2 function ran into a situation that should never occcur. *) diff --git a/user-contrib/Ltac2/Ltac1.v b/user-contrib/Ltac2/Ltac1.v index fd1555c2fb..0f7167939b 100644 --- a/user-contrib/Ltac2/Ltac1.v +++ b/user-contrib/Ltac2/Ltac1.v @@ -40,5 +40,8 @@ Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_ap Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". +Ltac2 @ external of_ident : ident -> t := "ltac2" "ltac1_of_ident". +Ltac2 @ external to_ident : t -> ident option := "ltac2" "ltac1_to_ident". + Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/user-contrib/Ltac2/Ltac2.v b/user-contrib/Ltac2/Ltac2.v index ccfc7e4a70..e55c6c13d3 100644 --- a/user-contrib/Ltac2/Ltac2.v +++ b/user-contrib/Ltac2/Ltac2.v @@ -22,6 +22,7 @@ Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. Require Ltac2.Env. +Require Ltac2.Ind. Require Ltac2.Printf. Require Ltac2.Ltac1. Require Export Ltac2.Notations. diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 548e12d611..4ef5c1a918 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -99,6 +99,15 @@ let pattern_of_qualid qid = else CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") +let opt_fun ?loc args ty e = + let e = match ty with + | None -> e + | Some ty -> CAst.make ?loc:e.CAst.loc (CTacCnv (e, ty)) + in + match args with + | [] -> e + | _ :: _ -> CAst.make ?loc (CTacFun (args, e)) + } GRAMMAR EXTEND Gram @@ -138,8 +147,8 @@ GRAMMAR EXTEND Gram [ "6" RIGHTA [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac2_expr LEVEL "6" -> - { CAst.make ~loc @@ CTacFun (it, body) } + [ "fun"; it = LIST1 input_fun; ty = type_cast; "=>"; body = ltac2_expr LEVEL "6" -> + { opt_fun ~loc it ty body } | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; e = ltac2_expr LEVEL "6" -> @@ -236,22 +245,24 @@ GRAMMAR EXTEND Gram | tac = ltac2_expr -> { [], tac } ] ] ; + type_cast: + [ [ -> { None } + | ":"; ty = ltac2_type -> { Some ty } + ] ] + ; let_clause: - [ [ binder = let_binder; ":="; te = ltac2_expr -> + [ [ binder = let_binder; ty = type_cast; ":="; te = ltac2_expr -> { let (pat, fn) = binder in - let te = match fn with - | None -> te - | Some args -> CAst.make ~loc @@ CTacFun (args, te) - in + let te = opt_fun ~loc fn ty te in (pat, te) } ] ] ; let_binder: [ [ pats = LIST1 input_fun -> { match pats with - | [{CAst.v=CPatVar _} as pat] -> (pat, None) - | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) - | [pat] -> (pat, None) + | [{CAst.v=CPatVar _} as pat] -> (pat, []) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, args) + | [pat] -> (pat, []) | _ -> CErrors.user_err ~loc (str "Invalid pattern") } ] ] ; @@ -287,9 +298,8 @@ GRAMMAR EXTEND Gram [ [ b = tac2pat LEVEL "0" -> { b } ] ] ; tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = ltac2_expr -> - { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in - (name, e) } + [ [ name = binder; it = LIST0 input_fun; ty = type_cast; ":="; e = ltac2_expr -> + { (name, opt_fun ~loc it ty e) } ] ] ; tac2def_val: @@ -905,8 +915,8 @@ let classify_ltac2 = function } VERNAC COMMAND EXTEND VernacDeclareTactic2Definition -| #[ local = locality ] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - Tac2entries.register_struct ?local e +| #[ deprecation = deprecation; local = locality ] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + Tac2entries.register_struct ?deprecation ?local e } | ![proof_opt_query] [ "Ltac2" "Eval" ltac2_expr(e) ] => { Vernacextend.classify_as_sideeff } -> { fun ~pstate -> Tac2entries.perform_eval ~pstate e diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 948a359124..4758ecf5bd 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -755,6 +755,12 @@ let () = define1 "constr_binder_type" (repr_ext val_binder) begin fun (bnd, ty) return (of_constr ty) end +let () = define1 "constr_has_evar" constr begin fun c -> + Proofview.tclEVARMAP >>= fun sigma -> + let b = Evarutil.has_undefined_evars sigma c in + Proofview.tclUNIT (Value.of_bool b) +end + (** Patterns *) let empty_context = EConstr.mkMeta Constr_matching.special_meta @@ -1075,6 +1081,54 @@ let () = define1 "env_instantiate" reference begin fun r -> return (Value.of_constr c) end +(** Ind *) + +let () = define2 "ind_equal" (repr_ext val_inductive) (repr_ext val_inductive) begin fun ind1 ind2 -> + return (Value.of_bool (Ind.UserOrd.equal ind1 ind2)) +end + +let () = define1 "ind_data" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + if Environ.mem_mind (fst ind) env then + let mib = Environ.lookup_mind (fst ind) env in + return (Value.of_ext val_ind_data (ind, mib)) + else + throw err_notfound +end + +let () = define1 "ind_repr" (repr_ext val_ind_data) begin fun (ind, _) -> + return (Value.of_ext val_inductive ind) +end + +let () = define1 "ind_index" (repr_ext val_inductive) begin fun (ind, n) -> + return (Value.of_int n) +end + +let () = define1 "ind_nblocks" (repr_ext val_ind_data) begin fun (ind, mib) -> + return (Value.of_int (Array.length mib.Declarations.mind_packets)) +end + +let () = define1 "ind_nconstructors" (repr_ext val_ind_data) begin fun ((_, n), mib) -> + let open Declarations in + return (Value.of_int (Array.length mib.mind_packets.(n).mind_consnames)) +end + +let () = define2 "ind_get_block" (repr_ext val_ind_data) int begin fun (ind, mib) n -> + if 0 <= n && n < Array.length mib.Declarations.mind_packets then + return (Value.of_ext val_ind_data ((fst ind, n), mib)) + else throw err_notfound +end + +let () = define2 "ind_get_constructor" (repr_ext val_ind_data) int begin fun ((mind, n), mib) i -> + let open Declarations in + let ncons = Array.length mib.mind_packets.(n).mind_consnames in + if 0 <= i && i < ncons then + (* WARNING: In the ML API constructors are indexed from 1 for historical + reasons, but Ltac2 uses 0-indexing instead. *) + return (Value.of_ext val_constructor ((mind, n), i + 1)) + else throw err_notfound +end + (** Ltac1 in Ltac2 *) let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 @@ -1132,6 +1186,16 @@ let () = define1 "ltac1_to_constr" ltac1 begin fun v -> return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) end +let () = define1 "ltac1_of_ident" ident begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Taccoerce.Value.of_ident c)) +end + +let () = define1 "ltac1_to_ident" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_ident (Taccoerce.Value.to_ident v)) +end + let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> let open Geninterp.Val in return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) @@ -1388,24 +1452,35 @@ let () = (** Ltac2 in terms *) let () = - let interp ist poly env sigma concl (ids, tac) = + let interp ?loc ~poly env sigma tycon (ids, tac) = (* Syntax prevents bound notation variables in constr quotations *) let () = assert (Id.Set.is_empty ids) in - let ist = Tac2interp.get_env ist in + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in - (EConstr.of_constr c, sigma) + let sigma, concl = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let c, sigma = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma concl tac in + let j = { Environ.uj_val = EConstr.of_constr c; Environ.uj_type = concl } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp let () = - let interp ist poly env sigma concl id = - let ist = Tac2interp.get_env ist in + let interp ?loc ~poly env sigma tycon id = + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let c = Id.Map.find id ist.env_ist in let c = Value.to_constr c in - let sigma = Typing.check env sigma c concl in - (c, sigma) + let t = Retyping.get_type_of (GlobEnv.renamed_env env) sigma c in + match tycon with + | None -> + { Environ.uj_val = c; Environ.uj_type = t }, sigma + | Some ty -> + let sigma = Evarconv.unify_leq_delay (GlobEnv.renamed_env env) sigma t ty in + let j = { Environ.uj_val = c; Environ.uj_type = ty } in + j, sigma in GlobEnv.register_constr_interp0 wit_ltac2_quotation interp @@ -1679,6 +1754,16 @@ let () = add_scope "constr" (fun arg -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) ) +let () = add_scope "open_constr" (fun arg -> + let delimiters = List.map (function + | SexprRec (_, { v = Some s }, []) -> s + | _ -> scope_fail "open_constr" arg) + arg + in + let act e = Tac2quote.of_open_constr ~delimiters e in + Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) + ) + let add_expr_scope name entry f = add_scope name begin function | [] -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm entry, f) @@ -1707,7 +1792,6 @@ let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_ let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching let () = add_expr_scope "format" Pcoq.Prim.lstring Tac2quote.of_format -let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern (** seq scope, a bit hairy *) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index d0655890a7..7af530ab0f 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -50,6 +50,12 @@ let q_pose = Pcoq.Entry.create "q_pose" let q_assert = Pcoq.Entry.create "q_assert" end +let () = + let entries = [ + Pcoq.AnyEntry Pltac.ltac2_expr; + ] in + Pcoq.register_grammars_by_name "ltac2" entries + (** Tactic definition *) type tacdef = { @@ -57,6 +63,7 @@ type tacdef = { tacdef_mutable : bool; tacdef_expr : glb_tacexpr; tacdef_type : type_scheme; + tacdef_deprecation : Deprecation.t option; } let perform_tacdef visibility ((sp, kn), def) = @@ -65,6 +72,7 @@ let perform_tacdef visibility ((sp, kn), def) = Tac2env.gdata_expr = def.tacdef_expr; gdata_type = def.tacdef_type; gdata_mutable = def.tacdef_mutable; + gdata_deprecation = def.tacdef_deprecation; } in Tac2env.define_global kn data @@ -77,6 +85,7 @@ let cache_tacdef ((sp, kn), def) = Tac2env.gdata_expr = def.tacdef_expr; gdata_type = def.tacdef_type; gdata_mutable = def.tacdef_mutable; + gdata_deprecation = def.tacdef_deprecation; } in Tac2env.define_global kn data @@ -322,7 +331,7 @@ let check_lowercase {loc;v=id} = if Tac2env.is_constructor (Libnames.qualid_of_ident id) then user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") -let register_ltac ?(local = false) ?(mut = false) isrec tactics = +let register_ltac ?deprecation ?(local = false) ?(mut = false) isrec tactics = let map ({loc;v=na}, e) = let id = match na with | Anonymous -> @@ -359,6 +368,7 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = tacdef_mutable = mut; tacdef_expr = e; tacdef_type = t; + tacdef_deprecation = deprecation; } in ignore (Lib.add_leaf id (inTacDef def)) in @@ -377,9 +387,9 @@ let register_typedef ?(local = false) isrec types = in let () = let check_existing_type ({v=id},_) = - let qid = Libnames.make_qualid (Lib.current_dirpath false) id in - try let _ = Tac2env.locate_type qid in - user_err (str "Multiple definition of the type name " ++ pr_qualid qid) + let (_, kn) = Lib.make_foname id in + try let _ = Tac2env.interp_type kn in + user_err (str "Multiple definition of the type name " ++ Id.print id) with Not_found -> () in List.iter check_existing_type types @@ -413,9 +423,10 @@ let register_typedef ?(local = false) isrec types = in let () = let check_existing_ctor (id, _) = - let qid = Libnames.make_qualid (Lib.current_dirpath false) id in - if Tac2env.mem_constructor qid - then user_err (str "Constructor already defined in this module " ++ pr_qualid qid) + let (_, kn) = Lib.make_foname id in + try let _ = Tac2env.interp_constructor kn in + user_err (str "Constructor already defined in this module " ++ Id.print id) + with Not_found -> () in List.iter check_existing_ctor cs in @@ -453,7 +464,7 @@ let register_typedef ?(local = false) isrec types = let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in List.iter iter types -let register_primitive ?(local = false) {loc;v=id} t ml = +let register_primitive ?deprecation ?(local = false) {loc;v=id} t ml = let t = intern_open_type t in let rec count_arrow = function | GTypArrow (_, t) -> 1 + count_arrow t @@ -477,6 +488,7 @@ let register_primitive ?(local = false) {loc;v=id} t ml = tacdef_mutable = false; tacdef_expr = e; tacdef_type = t; + tacdef_deprecation = deprecation; } in ignore (Lib.add_leaf id (inTacDef def)) @@ -507,9 +519,10 @@ let register_open ?(local = false) qid (params, def) = user_err (str "Multiple definitions of the constructor " ++ Id.print id) in let check_existing_ctor (id, _) = - let qid = Libnames.make_qualid (Lib.current_dirpath false) id in - if Tac2env.mem_constructor qid - then user_err (str "Constructor already defined in this module " ++ pr_qualid qid) + let (_, kn) = Lib.make_foname id in + try let _ = Tac2env.interp_constructor kn in + user_err (str "Constructor already defined in this module " ++ Id.print id) + with Not_found -> () in let () = List.iter check_existing_ctor def in () @@ -599,6 +612,18 @@ let parse_token = function let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") +let rec print_scope = function +| SexprStr s -> str s.CAst.v +| SexprInt i -> int i.CAst.v +| SexprRec (_, {v=na}, []) -> Option.cata Id.print (str "_") na +| SexprRec (_, {v=na}, e) -> + Option.cata Id.print (str "_") na ++ str "(" ++ pr_sequence print_scope e ++ str ")" + +let print_token = function +| SexprStr {v=s} -> quote (str s) +| SexprRec (_, {v=na}, [tok]) -> print_scope tok +| _ -> assert false + end let parse_scope = ParseToken.parse_scope @@ -608,6 +633,7 @@ type synext = { synext_exp : raw_tacexpr; synext_lev : int option; synext_loc : bool; + synext_depr : Deprecation.t option; } type krule = @@ -628,10 +654,20 @@ let rec get_rule (tok : scope_rule token list) : krule = match tok with let act k _ = act k in KRule (rule, act) +let deprecated_ltac2_notation = + Deprecation.create_warning + ~object_name:"Ltac2 notation" + ~warning_name:"deprecated-ltac2-notation" + (fun (toks : sexpr list) -> pr_sequence ParseToken.print_token toks) + let perform_notation syn st = let tok = List.rev_map ParseToken.parse_token syn.synext_tok in let KRule (rule, act) = get_rule tok in let mk loc args = + let () = match syn.synext_depr with + | None -> () + | Some depr -> deprecated_ltac2_notation ~loc (syn.synext_tok, depr) + in let map (na, e) = ((CAst.make ?loc:e.loc @@ CPatVar na), e) in @@ -671,23 +707,24 @@ let inTac2Notation : synext -> obj = type abbreviation = { abbr_body : raw_tacexpr; + abbr_depr : Deprecation.t option; } let perform_abbreviation visibility ((sp, kn), abbr) = let () = Tac2env.push_ltac visibility sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body + Tac2env.define_alias ?deprecation:abbr.abbr_depr kn abbr.abbr_body let load_abbreviation i obj = perform_abbreviation (Until i) obj let open_abbreviation i obj = perform_abbreviation (Exactly i) obj let cache_abbreviation ((sp, kn), abbr) = let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body + Tac2env.define_alias ?deprecation:abbr.abbr_depr kn abbr.abbr_body let subst_abbreviation (subst, abbr) = let body' = subst_rawexpr subst abbr.abbr_body in if body' == abbr.abbr_body then abbr - else { abbr_body = body' } + else { abbr_body = body'; abbr_depr = abbr.abbr_depr } let classify_abbreviation o = Substitute o @@ -699,12 +736,12 @@ let inTac2Abbreviation : abbreviation -> obj = subst_function = subst_abbreviation; classify_function = classify_abbreviation} -let register_notation ?(local = false) tkn lev body = match tkn, lev with +let register_notation ?deprecation ?(local = false) tkn lev body = match tkn, lev with | [SexprRec (_, {loc;v=Some id}, [])], None -> (* Tactic abbreviation *) let () = check_lowercase CAst.(make ?loc id) in let body = Tac2intern.globalize Id.Set.empty body in - let abbr = { abbr_body = body } in + let abbr = { abbr_body = body; abbr_depr = deprecation } in ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) | _ -> (* Check that the tokens make sense *) @@ -723,6 +760,7 @@ let register_notation ?(local = false) tkn lev body = match tkn, lev with synext_exp = body; synext_lev = lev; synext_loc = local; + synext_depr = deprecation; } in Lib.add_anonymous_leaf (inTac2Notation ext) @@ -811,13 +849,11 @@ let perform_eval ~pstate e = Goal_select.get_default_goal_selector (), Declare.Proof.get pstate in - let v = match selector with - | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v - | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v - | Goal_select.SelectId id -> Proofview.tclFOCUSID id v - | Goal_select.SelectAll -> v - | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) + let nosuchgoal = + let info = Exninfo.reify () in + Proofview.tclZERO ~info (Proof.SuggestNoSuchGoals (1,proof)) in + let v = Goal_select.tclSELECT ~nosuchgoal selector v in let (proof, _, ans) = Proof.run_tactic (Global.env ()) v proof in let { Proof.sigma } = Proof.data proof in let name = int_name () in @@ -827,12 +863,21 @@ let perform_eval ~pstate e = (** Toplevel entries *) -let register_struct ?local str = match str with -| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e -| StrTyp (isrec, t) -> register_type ?local isrec t -| StrPrm (id, t, ml) -> register_primitive ?local id t ml -| StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, old, e) -> register_redefinition ?local qid old e +let unsupported_deprecation = function +| None -> () +| Some _ -> + Attributes.unsupported_attributes ["deprecated", Attributes.VernacFlagEmpty] + +let register_struct ?deprecation ?local str = match str with +| StrVal (mut, isrec, e) -> register_ltac ?deprecation ?local ~mut isrec e +| StrTyp (isrec, t) -> + let () = unsupported_deprecation deprecation in (* TODO *) + register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?deprecation ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?deprecation ?local tok lev e +| StrMut (qid, old, e) -> + let () = unsupported_deprecation deprecation in (* TODO: what does that mean? *) + register_redefinition ?local qid old e (** Toplevel exception *) diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index 782968c6e1..a1e13b60fe 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -14,22 +14,19 @@ open Tac2expr (** {5 Toplevel definitions} *) -val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> +val register_ltac : ?deprecation:Deprecation.t -> ?local:bool -> ?mut:bool -> rec_flag -> (Names.lname * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> (qualid * redef_flag * raw_quant_typedef) list -> unit -val register_primitive : ?local:bool -> +val register_primitive : ?deprecation:Deprecation.t -> ?local:bool -> Names.lident -> raw_typexpr -> ml_tactic_name -> unit -val register_struct - : ?local:bool - -> strexpr - -> unit +val register_struct : ?deprecation:Deprecation.t -> ?local:bool -> strexpr -> unit -val register_notation : ?local:bool -> sexpr list -> int option -> - raw_tacexpr -> unit +val register_notation : ?deprecation:Deprecation.t -> ?local:bool -> sexpr list -> + int option -> raw_tacexpr -> unit val perform_eval : pstate:Declare.Proof.t option -> raw_tacexpr -> unit diff --git a/user-contrib/Ltac2/tac2env.ml b/user-contrib/Ltac2/tac2env.ml index 5479ba0d54..969b6c8e28 100644 --- a/user-contrib/Ltac2/tac2env.ml +++ b/user-contrib/Ltac2/tac2env.ml @@ -18,6 +18,7 @@ type global_data = { gdata_expr : glb_tacexpr; gdata_type : type_scheme; gdata_mutable : bool; + gdata_deprecation : Deprecation.t option; } type constructor_data = { @@ -35,12 +36,17 @@ type projection_data = { pdata_indx : int; } +type alias_data = { + alias_body : raw_tacexpr; + alias_depr : Deprecation.t option; +} + type ltac_state = { ltac_tactics : global_data KNmap.t; ltac_constructors : constructor_data KNmap.t; ltac_projections : projection_data KNmap.t; ltac_types : glb_quant_typedef KNmap.t; - ltac_aliases : raw_tacexpr KNmap.t; + ltac_aliases : alias_data KNmap.t; } let empty_state = { @@ -79,9 +85,10 @@ let define_type kn e = let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types -let define_alias kn tac = +let define_alias ?deprecation kn tac = let state = !ltac_state in - ltac_state := { state with ltac_aliases = KNmap.add kn tac state.ltac_aliases } + let data = { alias_body = tac; alias_depr = deprecation } in + ltac_state := { state with ltac_aliases = KNmap.add kn data state.ltac_aliases } let interp_alias kn = KNmap.find kn ltac_state.contents.ltac_aliases @@ -196,11 +203,6 @@ let shortest_qualid_of_constructor kn = let sp = KNmap.find kn tab.tab_cstr_rev in KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr -let mem_constructor qid = - let tab = !nametab in - try ignore (KnTab.locate qid tab.tab_cstr) ; true - with Not_found -> false - let push_type vis sp kn = let tab = !nametab in let tab_type = KnTab.push vis sp kn tab.tab_type in diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli index 95dcdd7e1b..02b34b594e 100644 --- a/user-contrib/Ltac2/tac2env.mli +++ b/user-contrib/Ltac2/tac2env.mli @@ -23,6 +23,7 @@ type global_data = { gdata_expr : glb_tacexpr; gdata_type : type_scheme; gdata_mutable : bool; + gdata_deprecation : Deprecation.t option; } val define_global : ltac_constant -> global_data -> unit @@ -72,8 +73,13 @@ val interp_projection : ltac_projection -> projection_data (** {5 Toplevel definition of aliases} *) -val define_alias : ltac_constant -> raw_tacexpr -> unit -val interp_alias : ltac_constant -> raw_tacexpr +type alias_data = { + alias_body : raw_tacexpr; + alias_depr : Deprecation.t option; +} + +val define_alias : ?deprecation:Deprecation.t -> ltac_constant -> raw_tacexpr -> unit +val interp_alias : ltac_constant -> alias_data (** {5 Name management} *) @@ -83,7 +89,6 @@ val locate_extended_all_ltac : qualid -> tacref list val shortest_qualid_of_ltac : tacref -> qualid val push_constructor : visibility -> full_path -> ltac_constructor -> unit -val mem_constructor : qualid -> bool val locate_constructor : qualid -> ltac_constructor val locate_extended_all_constructor : qualid -> ltac_constructor list val shortest_qualid_of_constructor : ltac_constructor -> qualid diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index a09438c6bf..5f9fbc4e41 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -104,6 +104,7 @@ let val_binder = Val.create "binder" let val_univ = Val.create "universe" let val_free : Names.Id.Set.t Val.tag = Val.create "free" let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" +let val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag = Val.create "ind_data" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index c9aa50389e..e87ad7139c 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -184,6 +184,7 @@ val val_binder : (Name.t Context.binder_annot * types) Val.tag val val_univ : Univ.Level.t Val.tag val val_free : Id.Set.t Val.tag val val_ltac1 : Geninterp.Val.t Val.tag +val val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index ddf70a5a65..206f4df19d 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -467,7 +467,9 @@ let polymorphic ((n, t) : type_scheme) : mix_type_scheme = let warn_not_unit = CWarnings.create ~name:"not-unit" ~category:"ltac" - (fun () -> strbrk "The following expression should have type unit.") + (fun (env, t) -> + strbrk "The following expression should have type unit but has type " ++ + pr_glbtype env t ++ str ".") let warn_redundant_clause = CWarnings.create ~name:"redundant-clause" ~category:"ltac" @@ -480,7 +482,7 @@ let check_elt_unit loc env t = | GTypRef (Tuple 0, []) -> true | GTypRef _ -> false in - if not maybe_unit then warn_not_unit ?loc () + if not maybe_unit then warn_not_unit ?loc (env, t) let check_elt_empty loc env t = match kind env t with | GTypVar _ -> @@ -504,7 +506,7 @@ let check_unit ?loc t = | GTypRef (Tuple 0, []) -> true | GTypRef _ -> false in - if not maybe_unit then warn_not_unit ?loc () + if not maybe_unit then warn_not_unit ?loc (env, t) let check_redundant_clause = function | [] -> () @@ -655,6 +657,35 @@ let is_alias env qid = match get_variable env qid with | ArgArg (TacAlias _) -> true | ArgVar _ | (ArgArg (TacConstant _)) -> false +let is_user_name qid = match qid with +| AbsKn _ -> false +| RelId _ -> true + +let deprecated_ltac2_alias = + Deprecation.create_warning + ~object_name:"Ltac2 alias" + ~warning_name:"deprecated-ltac2-alias" + (fun kn -> pr_qualid (Tac2env.shortest_qualid_of_ltac (TacAlias kn))) + +let deprecated_ltac2_def = + Deprecation.create_warning + ~object_name:"Ltac2 definition" + ~warning_name:"deprecated-ltac2-definition" + (fun kn -> pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn))) + +let check_deprecated_ltac2 ?loc qid def = + if is_user_name qid then match def with + | TacAlias kn -> + begin match (Tac2env.interp_alias kn).alias_depr with + | None -> () + | Some depr -> deprecated_ltac2_alias ?loc (kn, depr) + end + | TacConstant kn -> + begin match (Tac2env.interp_global kn).gdata_deprecation with + | None -> () + | Some depr -> deprecated_ltac2_def ?loc (kn, depr) + end + let rec intern_rec env {loc;v=e} = match e with | CTacAtm atm -> intern_atm env atm | CTacRef qid -> @@ -663,11 +694,12 @@ let rec intern_rec env {loc;v=e} = match e with let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> - let { Tac2env.gdata_type = sch } = + let { Tac2env.gdata_type = sch; gdata_deprecation = depr } = try Tac2env.interp_global kn with Not_found -> CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) in + let () = check_deprecated_ltac2 ?loc qid (TacConstant kn) in (GTacRef kn, fresh_type_scheme env sch) | ArgArg (TacAlias kn) -> let e = @@ -675,7 +707,8 @@ let rec intern_rec env {loc;v=e} = match e with with Not_found -> CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) in - intern_rec env e + let () = check_deprecated_ltac2 ?loc qid (TacAlias kn) in + intern_rec env e.alias_body end | CTacCst qid -> let kn = get_constructor env qid in @@ -695,12 +728,13 @@ let rec intern_rec env {loc;v=e} = match e with | CTacApp ({loc;v=CTacCst qid}, args) -> let kn = get_constructor env qid in intern_constructor env loc kn args -| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> +| CTacApp ({v=CTacRef qid; loc=aloc}, args) when is_alias env qid -> let kn = match get_variable env qid with | ArgArg (TacAlias kn) -> kn | ArgVar _ | (ArgArg (TacConstant _)) -> assert false in let e = Tac2env.interp_alias kn in + let () = check_deprecated_ltac2 ?loc:aloc qid (TacAlias kn) in let map arg = (* Thunk alias arguments *) let loc = arg.loc in @@ -709,7 +743,7 @@ let rec intern_rec env {loc;v=e} = match e with CAst.make ?loc @@ CTacFun ([var], arg) in let args = List.map map args in - intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) + intern_rec env (CAst.make ?loc @@ CTacApp (e.alias_body, args)) | CTacApp (f, args) -> let loc = f.loc in let (f, ft) = intern_rec env f in @@ -1243,7 +1277,9 @@ let rec globalize ids ({loc;v=er} as e) = match er with let mem id = Id.Set.mem id ids in begin match get_variable0 mem ref with | ArgVar _ -> e - | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) + | ArgArg kn -> + let () = check_deprecated_ltac2 ?loc ref kn in + CAst.make ?loc @@ CTacRef (AbsKn kn) end | CTacCst qid -> let knc = get_constructor () qid in diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index d1a72fcfd1..2d65f9ec3e 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -102,18 +102,22 @@ let of_anti f = function let of_ident {loc;v=id} = inj_wit ?loc wit_ident id +let quote_constr ?delimiters c = + let loc = Constrexpr_ops.constr_loc c in + Option.cata + (List.fold_left (fun c d -> + CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) + c) + c delimiters + let of_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in - let c = Option.cata - (List.fold_left (fun c d -> - CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) - c) - c delimiters - in + let c = quote_constr ?delimiters c in inj_wit ?loc wit_constr c -let of_open_constr c = +let of_open_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in + let c = quote_constr ?delimiters c in inj_wit ?loc wit_open_constr c let of_bool ?loc b = diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index fcd1339cd7..6e2f548319 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -36,7 +36,7 @@ val of_ident : Id.t CAst.t -> raw_tacexpr val of_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr -val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr +val of_open_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr diff --git a/vernac/canonical.ml b/vernac/canonical.ml index eaa6c84791..2c04032ca0 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -7,30 +7,30 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Libobject -open Recordops +open Structures let open_canonical_structure i (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in - if Int.equal i 1 then register_canonical_structure env sigma ~warn:false o + if Int.equal i 1 then Instance.register env sigma ~warn:false o let cache_canonical_structure (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in - register_canonical_structure ~warn:true env sigma o + Instance.register ~warn:true env sigma o -let discharge_canonical_structure (_,((gref, _ as x), local)) = +let discharge_canonical_structure (_,(x, local)) = + let gref = Instance.repr x in if local || (Globnames.isVarRef gref && Lib.is_in_section gref) then None else Some (x, local) -let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = +let inCanonStruc : Instance.t * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = simple_open open_canonical_structure; cache_function = cache_canonical_structure; - subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); + subst_function = (fun (subst,(c,local)) -> Instance.subst subst c, local); classify_function = (fun x -> Substitute x); discharge_function = discharge_canonical_structure } @@ -39,4 +39,4 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) let declare_canonical_structure ?(local=false) ref = let env = Global.env () in let sigma = Evd.from_env env in - add_canonical_structure (check_and_decompose_canonical_structure env sigma ref, local) + add_canonical_structure (Instance.make env sigma ref, local) diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 15d8ebc4b5..26d696ff8e 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -90,7 +90,7 @@ let uniform_cond sigma ctx lt = let class_of_global = function | GlobRef.ConstRef sp -> - (match Recordops.find_primitive_projection sp with + (match Structures.PrimitiveProjections.find_opt sp with | Some p -> CL_PROJ p | None -> CL_CONST sp) | GlobRef.IndRef sp -> CL_IND sp | GlobRef.VarRef id -> CL_SECVAR id @@ -141,8 +141,8 @@ let get_target env t ind = CL_FUN else match pi1 (find_class_type env Evd.empty (EConstr.of_constr t)) with - | CL_CONST p when Recordops.is_primitive_projection p -> - CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) + | CL_CONST p when Structures.PrimitiveProjections.mem p -> + CL_PROJ (Option.get @@ Structures.PrimitiveProjections.find_opt p) | x -> x let strength_of_cl = function @@ -237,24 +237,24 @@ let open_coercion i o = cache_coercion o let discharge_coercion (_, c) = - if c.coercion_local then None + if c.coe_local then None else let n = try - let ins = Lib.section_instance c.coercion_type in + let ins = Lib.section_instance c.coe_value in Array.length (snd ins) with Not_found -> 0 in let nc = { c with - coercion_params = n + c.coercion_params; - coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; + coe_param = n + c.coe_param; + coe_is_projection = Option.map Lib.discharge_proj_repr c.coe_is_projection; } in Some nc let classify_coercion obj = - if obj.coercion_local then Dispose else Substitute obj + if obj.coe_local then Dispose else Substitute obj -let inCoercion : coercion -> obj = +let inCoercion : coe_info_typ -> obj = declare_object {(default_object "COERCION") with open_function = simple_open open_coercion; cache_function = cache_coercion; @@ -265,17 +265,17 @@ let inCoercion : coercion -> obj = let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = let isproj = match coef with - | GlobRef.ConstRef c -> Recordops.find_primitive_projection c + | GlobRef.ConstRef c -> Structures.PrimitiveProjections.find_opt c | _ -> None in let c = { - coercion_type = coef; - coercion_local = local; - coercion_is_id = isid; - coercion_is_proj = isproj; - coercion_source = cls; - coercion_target = clt; - coercion_params = ps; + coe_value = coef; + coe_local = local; + coe_is_identity = isid; + coe_is_projection = isproj; + coe_source = cls; + coe_target = clt; + coe_param = ps; } in Lib.add_anonymous_leaf (inCoercion c) diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index 1b811f3db7..39520a68ec 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -41,8 +41,8 @@ let kind_searcher = Decls.(function Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Coercionops.coe_value gr && (k' <> SubClass && k' <> IdentityCoercion || c.Coercionops.coe_is_identity)) coercions) | IsDefinition CanonicalStructure -> - let canonproj = Recordops.canonical_projections () in - Inr (fun gr -> List.exists (fun c -> GlobRef.equal (snd c).Recordops.o_ORIGIN gr) canonproj) + let canonproj = Structures.CSTable.entries () in + Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Structures.CSTable.solution gr) canonproj) | IsDefinition Scheme -> let schemes = DeclareScheme.all_schemes () in Inr (fun gr -> Indset.exists (fun c -> GlobRef.equal (GlobRef.IndRef c) gr) schemes) diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 7050ddc042..2ab6e3bb15 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -76,7 +76,7 @@ let objInductive : inductive_obj Libobject.Dyn.tag = let inInductive v = Libobject.Dyn.Easy.inj v objInductive -let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c +let cache_prim (_,(p,c)) = Structures.PrimitiveProjections.register p c let load_prim _ p = cache_prim p diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 15e6d4ef37..95e05556b9 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -216,7 +216,7 @@ let consistency_checks exists dir dirinfo = else if Nametab.exists_dir dir then user_err ~hdr:"consistency_checks" - (DirPath.print dir ++ str " already exists") + (DirPath.print dir ++ str " already exists.") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i diff --git a/vernac/himsg.ml b/vernac/himsg.ml index bff0359782..21a25ab78c 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -924,7 +924,9 @@ let explain_not_match_error = function | InductiveFieldExpected _ -> strbrk "an inductive definition is expected" | DefinitionFieldExpected -> - strbrk "a definition is expected" + strbrk "a definition is expected. Hint: you can rename the \ + inductive or constructor and add a definition mapping the \ + old name to the new name" | ModuleFieldExpected -> strbrk "a module is expected" | ModuleTypeFieldExpected -> diff --git a/vernac/library.ml b/vernac/library.ml index cc9e3c3c44..eedf8aa670 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -448,10 +448,10 @@ let save_library_base f sum lib univs tasks proofs = Sys.remove f; Exninfo.iraise reraise -type ('document,'counters) todo_proofs = +type 'document todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) - | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list (* for .vio *) let save_library_to todo_proofs ~output_native_objects dir f otab = assert( @@ -464,7 +464,7 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let except = match todo_proofs with | ProofsTodoNone -> Future.UUIDSet.empty | ProofsTodoSomeEmpty except -> except - | ProofsTodoSome (except,l,_) -> except + | ProofsTodoSome (except,l) -> except in let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in let opaque_table, f2t_map = Opaqueproof.dump ~except otab in @@ -473,13 +473,13 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = | ProofsTodoNone -> None, None | ProofsTodoSomeEmpty _except -> None, Some (Univ.ContextSet.empty,false) - | ProofsTodoSome (_except, tasks, rcbackup) -> + | ProofsTodoSome (_except, tasks) -> let tasks = List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b with Not_found -> assert b; { r with uuid = -1 }, b) tasks in - Some (tasks,rcbackup), + Some tasks, Some (Univ.ContextSet.empty,false) in let sd = { diff --git a/vernac/library.mli b/vernac/library.mli index d0e9f84691..4c6c654c58 100644 --- a/vernac/library.mli +++ b/vernac/library.mli @@ -41,13 +41,13 @@ type seg_proofs = Opaqueproof.opaque_proofterm array argument. [output_native_objects]: when producing vo objects, also compile the native-code version. *) -type ('document,'counters) todo_proofs = +type 'document todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) - | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list (* for .vio *) val save_library_to : - ('document,'counters) todo_proofs -> + 'document todo_proofs -> output_native_objects:bool -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 2fe402ff08..f9f65a8c30 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1664,7 +1664,7 @@ let add_notation_interpretation env decl_ntn = decl_ntn_scope = sc; } = decl_ntn in match interp_non_syntax_modifiers modifiers with - | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here") + | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here.") | Some (only_parsing,only_printing,entry) -> let df' = add_notation_interpretation_core ~local:false df env entry c sc only_parsing false None in Dumpglob.dump_notation (loc,df') sc true @@ -1845,6 +1845,6 @@ let inCustomEntry : locality_flag * string -> obj = let declare_custom_entry local s = if Egramcoq.exists_custom_entry s then - user_err Pp.(str "Custom entry " ++ str s ++ str " already exists") + user_err Pp.(str "Custom entry " ++ str s ++ str " already exists.") else Lib.add_anonymous_leaf (inCustomEntry (local,s)) diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 79a0cdf8d1..a3cd7a8edc 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -24,7 +24,6 @@ open Impargs open Libobject open Libnames open Globnames -open Recordops open Printer open Printmod open Context.Rel.Declaration @@ -976,15 +975,11 @@ open Coercionops let print_coercion_value v = Printer.pr_global v.coe_value -let print_class i = - let cl,_ = class_info_from_index i in - pr_class cl - let print_path ((i,j),p) = hov 2 ( str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ str"] : ") ++ - print_class i ++ str" >-> " ++ print_class j + pr_class i ++ str" >-> " ++ pr_class j let _ = Coercionops.install_path_printer print_path @@ -997,43 +992,36 @@ let print_classes () = let print_coercions () = pr_sequence print_coercion_value (coercions()) -let index_of_class cl = - try - fst (class_info cl) - with Not_found -> - user_err ~hdr:"index_of_class" - (pr_class cl ++ spc() ++ str "not a defined class.") - let print_path_between cls clt = - let i = index_of_class cls in - let j = index_of_class clt in let p = try - lookup_path_between_class (i,j) + lookup_path_between_class (cls, clt) with Not_found -> user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in - print_path ((i,j),p) + print_path ((cls, clt), p) let print_canonical_projections env sigma grefs = - let match_proj_gref ((x,y),c) gr = - GlobRef.equal x gr || - begin match y with - | Const_cs y -> GlobRef.equal y gr + let open Structures in + let match_proj_gref { CSTable.projection; value; solution } gr = + GlobRef.equal projection gr || + begin match value with + | ValuePattern.Const_cs y -> GlobRef.equal y gr | _ -> false end || - GlobRef.equal c.o_ORIGIN gr + GlobRef.equal solution gr in let projs = List.filter (fun p -> List.for_all (match_proj_gref p) grefs) - (canonical_projections ()) + (CSTable.entries ()) in prlist_with_sep fnl - (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ + (fun { CSTable.projection; value; solution } -> + ValuePattern.print value ++ str " <- " ++ - pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") + pr_global projection ++ str " ( " ++ pr_global solution ++ str " )") projs (*************************************************************************) diff --git a/vernac/record.ml b/vernac/record.ml index 96e4a47d2d..53f3508806 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -22,6 +22,7 @@ open Type_errors open Constrexpr open Constrexpr_ops open Context.Rel.Declaration +open Structures module RelDecl = Context.Rel.Declaration @@ -348,7 +349,7 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = this could be refactored as noted above by moving to the higher-level declare constant API *) let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls - paramargs decl impls fid subst sp_projs nfi ti i indsp mib lifted_fields x rp = + paramargs decl impls fid subst nfi ti i indsp mib lifted_fields x rp = let ccl = subst_projection fid subst ti in let body, p_opt = match decl with | LocalDef (_,ci,_) -> subst_projection fid subst ci, None @@ -396,32 +397,33 @@ let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramde ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) + (Some kn, i, Projection term::subst) (** [build_proj] will build a projection for each field, or skip if the field is anonymous, i.e. [_ : t] *) let build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs - (nfi,i,kinds,sp_projs,subst) flags decl impls = + (nfi,i,kinds,subst) flags decl impls = let fi = RelDecl.get_name decl in let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = + let (sp_proj,i,subst) = match fi with | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) + (None,i,NoProjection fi::subst) | Name fid -> try build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls paramargs decl impls fid - subst sp_projs nfi ti i indsp mib lifted_fields x rp + subst nfi ti i indsp mib lifted_fields x rp with NotDefinable why as exn -> let _, info = Exninfo.capture exn in warning_or_error ~info flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) + (None,i,NoProjection fi::subst) in (nfi - 1, i, - { Recordops.pk_name = fi - ; pk_true_proj = is_local_assum decl - ; pk_canonical = flags.pf_canonical } :: kinds - , sp_projs, subst) + { Structure.proj_name = fi + ; proj_true = is_local_assum decl + ; proj_canonical = flags.pf_canonical + ; proj_body = sp_proj } :: kinds + , subst) (** [declare_projections] prepares the common context for all record projections and then calls [build_proj] for each one. *) @@ -445,11 +447,12 @@ let declare_projections indsp univs ?(kind=Decls.StructureComponent) binder_name | PrimRecord _ -> true | FakeRecord | NotRecord -> false in - let (_,_,kinds,sp_projs,_) = + let (_,_,canonical_projections,_) = List.fold_left3 (build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs) - (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) - in (kinds,sp_projs) + (List.length fields,0,[],[]) flags (List.rev fields) (List.rev fieldimpls) + in + List.rev canonical_projections open Typeclasses @@ -485,20 +488,17 @@ let check_template ~template ~poly ~univs ~params { Data.id; rdata = { DataR.min (* auto detect template *) ComInductive.should_auto_template id (template && template_candidate ()) -let load_structure i (_, structure) = - Recordops.register_structure structure +let load_structure i (_, structure) = Structure.register structure -let cache_structure o = - load_structure 1 o +let cache_structure o = load_structure 1 o -let subst_structure (subst, obj) = - Recordops.subst_structure subst obj +let subst_structure (subst, obj) = Structure.subst subst obj let discharge_structure (_, x) = Some x -let rebuild_structure s = Recordops.rebuild_structure (Global.env()) s +let rebuild_structure s = Structure.rebuild (Global.env()) s -let inStruc : Recordops.struc_typ -> Libobject.obj = +let inStruc : Structure.t -> Libobject.obj = let open Libobject in declare_object {(default_object "STRUCTURE") with cache_function = cache_structure; @@ -511,6 +511,32 @@ let inStruc : Recordops.struc_typ -> Libobject.obj = let declare_structure_entry o = Lib.add_anonymous_leaf (inStruc o) +(** In the type of every projection, the record is bound to a variable named + using the first character of the record type. We rename it to avoid + collisions with names already used in the field types. +*) + +(** Get all names bound at the head of [t]. *) +let rec add_bound_names_constr (names : Id.Set.t) (t : constr) : Id.Set.t = + match destProd t with + | (b, _, t) -> + let names = + match b.binder_name with + | Name.Anonymous -> names + | Name.Name n -> Id.Set.add n names + in add_bound_names_constr names t + | exception DestKO -> names + +(** Get all names bound in any record field. *) +let bound_names_rdata { DataR.fields; _ } : Id.Set.t = + let add_names names field = add_bound_names_constr names (RelDecl.get_type field) in + List.fold_left add_names Id.Set.empty fields + +(** Pick a variable name for a record, avoiding names bound in its fields. *) +let data_name { Data.id; Data.rdata; _ } = + let name = Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) in + Namegen.next_ident_away name (bound_names_rdata rdata) + (** Main record declaration part: The entry point is [definition_structure], which will match on the @@ -537,11 +563,7 @@ let declare_structure ~cumulative finite ~ubind ~univs ~variances paramimpls par in let binder_name = match name with - | None -> - let map { Data.id; _ } = - Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) - in - Array.map_of_list map record_data + | None -> Array.map_of_list data_name record_data | Some n -> n in let ntypes = List.length record_data in @@ -579,17 +601,10 @@ let declare_structure ~cumulative finite ~ubind ~univs ~variances paramimpls par let map i { Data.is_coercion; coers; rdata = { DataR.implfs; fields; _}; _ } = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in - let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers implfs fields in + let projections = declare_projections rsp ctx ~kind binder_name.(i) coers implfs fields in let build = GlobRef.ConstructRef cstr in let () = if is_coercion then ComCoercion.try_add_new_coercion build ~local:false ~poly in - let npars = Inductiveops.inductive_nparams (Global.env()) rsp in - let struc = { - Recordops.s_CONST = cstr; - s_PROJ = List.rev sp_projs; - s_PROJKIND = List.rev kinds; - s_EXPECTEDPARAM = npars; - } - in + let struc = Structure.make (Global.env ()) rsp projections in let () = declare_structure_entry struc in rsp in @@ -652,7 +667,7 @@ let build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template meth_info = b; meth_const = y; } in - let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + let l = List.map3 map (List.rev fields) coers (Structure.find_projections ind) in GlobRef.IndRef ind, l in List.map map inds @@ -751,11 +766,9 @@ let add_inductive_class env sigma ind = let k = let ctx = oneind.mind_arity_ctxt in let univs = Declareops.inductive_polymorphic_context mind in - let env = push_context ~strict:false (Univ.AUContext.repr univs) env in - let env = push_rel_context ctx env in let inst = Univ.make_abstract_instance univs in let ty = Inductive.type_of_inductive ((mind, oneind), inst) in - let r = Inductive.relevance_of_inductive env ind in + let r = oneind.mind_relevance in { cl_univs = univs; cl_impl = GlobRef.IndRef ind; cl_context = ctx; diff --git a/vernac/record.mli b/vernac/record.mli index 7a40af048c..feb257da3c 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -11,6 +11,7 @@ open Names open Vernacexpr open Constrexpr +open Structures module Ast : sig type t = @@ -51,8 +52,8 @@ module Internal : sig -> projection_flags list -> Impargs.manual_implicits list -> Constr.rel_context - -> Recordops.proj_kind list * Names.Constant.t option list + -> Structure.projection list - val declare_structure_entry : Recordops.struc_typ -> unit + val declare_structure_entry : Structure.t -> unit end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 38ca836b32..54f034c74e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -413,7 +413,7 @@ let sort_universes g = let levels = traverse LMap.empty [normalize Level.set, 0] in let max_level = LMap.fold (fun _ n accu -> max n accu) levels 0 in let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp i))) in + let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp "" i))) in let ulevels = Array.cons Level.set ulevels in (* Add the normal universes *) let fold (cur, ans) u = @@ -1568,6 +1568,13 @@ let () = let () = declare_bool_option { optdepr = false; + optkey = ["Printing";"Raw";"Literals"]; + optread = (fun () -> !Constrextern.print_raw_literal); + optwrite = (fun b -> Constrextern.print_raw_literal := b) } + +let () = + declare_bool_option + { optdepr = false; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } @@ -1927,10 +1934,9 @@ let vernac_search ~pstate ~atts s gopt r = let open ComSearch in let gopt = query_command_selector gopt in let sigma, env = - match gopt with | None -> - (* 1st goal by default if it exists, otherwise no goal at all *) - (try get_goal_or_global_context ~pstate 1 - with _ -> let env = Global.env () in (Evd.from_env env, env)) + match gopt with + (* 1st goal by default if it exists, otherwise no goal at all *) + | None -> get_goal_or_global_context ~pstate 1 (* if goal selector is given and wrong, then let exceptions be raised. *) | Some g -> get_goal_or_global_context ~pstate g in interp_search env sigma s r |