diff options
478 files changed, 8241 insertions, 5355 deletions
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000000..f5527192e0 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,91 @@ +name: GitHub CI + +on: [push, pull_request] + +jobs: + Windows: + runs-on: windows-latest + + steps: + - uses: actions/checkout@v2 + + - name: Set up Cygwin + uses: egor-tensin/setup-cygwin@v1 + with: + packages: rsync patch diffutils make unzip m4 findutils time wget curl git mingw64-x86_64-binutils mingw64-x86_64-gcc-core mingw64-x86_64-gcc-g++ mingw64-x86_64-pkg-config mingw64-x86_64-windows_default_manifest mingw64-x86_64-headers mingw64-x86_64-runtime mingw64-x86_64-pthreads mingw64-x86_64-zlib mingw64-x86_64-gmp python3 + + - name: Create home dir + run: | + C:\tools\cygwin\bin\bash.exe --login -c 'env' + + - name: Install opam + run: | + C:\tools\cygwin\bin\bash.exe dev\ci\azure-opam.sh + + - name: Build Coq + run: | + C:\tools\cygwin\bin\bash.exe dev\ci\azure-build.sh + + macOS: + runs-on: macOS-10.15 + + steps: + - uses: actions/checkout@v2 + + - name: Install system dependencies + run: | + brew install gnu-time opam gtksourceview3 adwaita-icon-theme + pip3 install macpack + + - name: Install OCaml dependencies + run: | + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER + opam switch set ocaml-base-compiler.$COMPILER + eval $(opam env) + opam update + opam install -j "$NJOBS" ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.10 + opam list + env: + COMPILER: "4.11.1" + FINDLIB_VER: ".1.8.1" + OPAMYES: "true" + MACOSX_DEPLOYMENT_TARGET: "10.11" + NJOBS: "2" + + - name: Build Coq + run: | + eval $(opam env) + ./configure -prefix "$(pwd)/_install_ci" -warn-error yes -native-compiler no -coqide opt + make -j "$NJOBS" byte + make -j "$NJOBS" + env: + MACOSX_DEPLOYMENT_TARGET: "10.11" + NJOBS: "2" + + - name: Run Coq Test Suite + run: | + eval $(opam env) + export OCAMLPATH=$(pwd):"$OCAMLPATH" + make -j "$NJOBS" test-suite PRINT_LOGS=1 + env: + NJOBS: "2" + + - name: Install Coq + run: | + make install + + - 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/.gitlab-ci.yml b/.gitlab-ci.yml index 99ae4c23ce..749b74d584 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,17 +9,17 @@ stages: - stage-5 # Only dependencies in stage 1, 2, 3, and 4 - deploy -# When a job has no dependencies, it goes to stage 1. Otherwise, we -# set both "needs" and "dependencies". "needs" is a superset of -# "dependencies" that should include all the transitive dependencies. -# "dependencies" only list the previous jobs whose artifact we need to -# keep. +# When a job has no dependencies, it goes to stage 1. Otherwise, we +# set "needs" to contain all transitive dependencies (with "artifacts: +# false" when we don't want the artifacts). We include the transitive +# dependencies due to gitlab bugs sometimes starting the job even if a +# transitive dep failed, see #10699 / 7b59d8c9d9b2104de7162ec0e40f6182a6830046. # some default values variables: - # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here - # for reference] - CACHEKEY: "bionic_coq-V2020-10-12-V89" + # Format: $IMAGE-V$DATE-$hash + # The $hash is the first 10 characters of the md5 of the dockerfile + CACHEKEY: "bionic_coq-V2020-11-26-50e9456f22" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -59,6 +59,7 @@ before_script: - eval $(opam env) - opam list - opam config list + - dev/tools/check-cachekey.sh ################ GITLAB CACHING ###################### # - use artifacts between jobs # @@ -111,7 +112,6 @@ before_script: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: [] script: # flambda can be pretty stack hungry, specially with -O3 # See also https://github.com/ocaml/ocaml/issues/7842#issuecomment-596863244 @@ -140,8 +140,6 @@ before_script: interruptible: true needs: - build:edge+flambda:dune:dev - dependencies: - - build:edge+flambda:dune:dev script: - tar xfj _build.tar.bz2 - set -e @@ -157,7 +155,7 @@ before_script: name: "$CI_JOB_NAME" expire_in: 2 months -# every non build job must set dependencies otherwise all build +# every non build job must set "needs" otherwise all build # artifacts are used together and we may get some random Coq. To that # purpose, we add a spurious dependency `not-a-real-job` that must be # overridden otherwise the CI will fail. @@ -168,7 +166,7 @@ before_script: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: + needs: - not-a-real-job script: - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/"' @@ -180,14 +178,14 @@ before_script: - _install_ci/share/doc/coq/ expire_in: 2 months -# set dependencies when using +# set "needs" when using .test-suite-template: stage: stage-2 except: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: + needs: - not-a-real-job script: - cd test-suite @@ -205,14 +203,14 @@ before_script: # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never -# set dependencies when using +# set "needs" when using .validate-template: stage: stage-2 except: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: + needs: - not-a-real-job script: # exit 0: workaround for https://gitlab.com/gitlab-org/gitlab/issues/202505 @@ -248,15 +246,11 @@ before_script: when: always needs: - build:base - dependencies: - - build:base .ci-template-flambda: extends: .ci-template needs: - build:edge+flambda - dependencies: - - build:edge+flambda variables: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" @@ -270,7 +264,6 @@ before_script: - artifacts when: always expire_in: 1 week - dependencies: [] tags: - windows-inria before_script: [] @@ -372,7 +365,6 @@ lint: variables: - $ONLY_WINDOWS == "true" script: dev/lint-repository.sh - dependencies: [] variables: GIT_DEPTH: "" # we need an unknown amount of history for per-commit linting OPAM_SWITCH: "edge" @@ -385,7 +377,6 @@ pkg:opam: - $ONLY_WINDOWS == "true" interruptible: true # OPAM will build out-of-tree so no point in importing artifacts - dependencies: [] script: - set -e - opam pin add --kind=path coq.dev . @@ -409,7 +400,6 @@ pkg:opam: GIT_STRATEGY: none NIXOS_PUBLIC_KEY: cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= - dependencies: [] # We don't need to download build artifacts before_script: [] # We don't want to use the shared 'before_script' script: - cat /proc/{cpu,mem}info || true @@ -453,7 +443,6 @@ pkg:nix:deploy:channel: - /^v.*\..*$/ variables: - $CACHIX_DEPLOYMENT_KEY - dependencies: [] needs: - pkg:nix:deploy script: @@ -475,8 +464,6 @@ pkg:nix: doc:refman: extends: .doc-template - dependencies: - - build:base needs: - build:base @@ -517,10 +504,6 @@ doc:refman:deploy: only: variables: - $DOCUMENTATION_DEPLOY_KEY - dependencies: - - doc:ml-api:odoc - - doc:refman:dune - - build:base needs: - doc:ml-api:odoc - doc:refman:dune @@ -551,15 +534,11 @@ doc:ml-api:odoc: test-suite:base: extends: .test-suite-template - dependencies: - - build:base needs: - build:base test-suite:base+32bit: extends: .test-suite-template - dependencies: - - build:base+32bit needs: - build:base+32bit variables: @@ -568,8 +547,6 @@ test-suite:base+32bit: test-suite:edge+flambda: extends: .test-suite-template - dependencies: - - build:edge+flambda needs: - build:edge+flambda variables: @@ -583,8 +560,6 @@ test-suite:edge:dune:dev: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: - - build:edge+flambda:dune:dev needs: - build:edge+flambda:dune:dev script: @@ -607,7 +582,6 @@ test-suite:edge:dune:dev: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: [] script: - opam switch create $OCAMLVER --empty - eval $(opam env) @@ -636,8 +610,6 @@ test-suite:edge:dune:dev: test-suite:base+async: extends: .test-suite-template - dependencies: - - build:base needs: - build:base variables: @@ -650,15 +622,11 @@ test-suite:base+async: validate:base: extends: .validate-template - dependencies: - - build:base needs: - build:base validate:base+32bit: extends: .validate-template - dependencies: - - build:base+32bit needs: - build:base+32bit variables: @@ -667,8 +635,6 @@ validate:base+32bit: validate:edge+flambda: extends: .validate-template - dependencies: - - build:edge+flambda needs: - build:edge+flambda variables: @@ -678,8 +644,6 @@ validate:edge+flambda: validate:quick: extends: .validate-template - dependencies: - - build:quick needs: - build:quick only: @@ -706,12 +670,14 @@ library:ci-color: needs: - build:edge+flambda - plugin:ci-bignums - dependencies: - - build:edge+flambda - - plugin:ci-bignums library:ci-compcert: + stage: stage-3 extends: .ci-template-flambda + needs: + - build:edge+flambda + - library:ci-flocq + - library:ci-menhir library:ci-coq_performance_tests: extends: .ci-template @@ -725,15 +691,16 @@ library:ci-coqprime: needs: - build:edge+flambda - plugin:ci-bignums - dependencies: - - build:edge+flambda - - plugin:ci-bignums library:ci-coqtail: extends: .ci-template library:ci-coquelicot: - extends: .ci-template + stage: stage-3 + extends: .ci-template-flambda + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-cross_crypto: extends: .ci-template @@ -752,11 +719,6 @@ library:ci-fiat_crypto: - library:ci-coqprime - plugin:ci-bignums - plugin:ci-rewriter - dependencies: - - build:edge+flambda - - library:ci-coqprime - - plugin:ci-bignums - - plugin:ci-rewriter library:ci-fiat_crypto_legacy: extends: .ci-template-flambda @@ -774,15 +736,36 @@ library:ci-fiat_crypto_ocaml: - plugin:ci-bignums - plugin:ci-rewriter - library:ci-fiat_crypto - dependencies: + +library:ci-flocq: + extends: .ci-template-flambda + +library:ci-menhir: + extends: .ci-template-flambda + +library:ci-interval: + extends: .ci-template-flambda + stage: stage-4 + needs: - build:edge+flambda - - library:ci-coqprime + - library:ci-coquelicot + - library:ci-flocq + - library:ci-mathcomp - plugin:ci-bignums - - plugin:ci-rewriter - - library:ci-fiat_crypto -library:ci-flocq: +library:ci-oddorder: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp + +library:ci-fourcolor: + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-corn: extends: .ci-template-flambda @@ -791,9 +774,13 @@ library:ci-corn: - build:edge+flambda - plugin:ci-bignums - library:ci-math_classes - dependencies: + +plugin:ci-gappa: + extends: .ci-template-flambda + stage: stage-3 + needs: - build:edge+flambda - - library:ci-math_classes + - library:ci-flocq library:ci-geocoq: extends: .ci-template-flambda @@ -810,9 +797,6 @@ library:ci-math_classes: needs: - build:edge+flambda - plugin:ci-bignums - dependencies: - - build:edge+flambda - - plugin:ci-bignums library:ci-mathcomp: extends: .ci-template-flambda @@ -838,9 +822,6 @@ library:ci-vst: needs: - build:edge+flambda - library:ci-flocq - dependencies: - - build:edge+flambda - - library:ci-flocq # Plugins are by definition the projects that depend on Coq's ML API @@ -871,9 +852,6 @@ plugin:ci-metacoq: needs: - build:base - plugin:ci-equations - dependencies: - - build:base - - plugin:ci-equations plugin:ci-mtac2: extends: .ci-template @@ -890,7 +868,6 @@ plugin:plugin-tutorial: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: [] script: - ./configure -local -warn-error yes - make -j "$NJOBS" plugin-tutorial diff --git a/INSTALL.md b/INSTALL.md index f672bb45d3..74f4091134 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -99,3 +99,13 @@ dependencies...) as Coq. Distribution of pre-compiled plugins and Coq version compiled with the same OCaml toolchain. An OCaml setup mismatch is the most probable cause for an `Error while loading ...: implementation mismatch on ...`. + +coq_environment.txt +------------------- +Coq binaries which honor environment variables, such as `COQLIB`, can +be seeded values for these variables by placing a text file named +`coq_environment.txt` next to them. The file can contain assignments +like `COQLIB="some path"`, that is a variable name followed by `=` and +a string that follows OCaml's escaping conventions. This feature can be +used by installers of binary package to make Coq aware of its installation +path. diff --git a/META.coq.in b/META.coq.in index 29b3ecbcb3..68ab0733ee 100644 --- a/META.coq.in +++ b/META.coq.in @@ -1,7 +1,7 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.13" +version = "8.14" directory = "" requires = "" @@ -9,7 +9,7 @@ requires = "" package "config" ( description = "Coq Configuration Variables" - version = "8.13" + version = "8.14" directory = "config" @@ -19,7 +19,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.13" + version = "8.14" directory = "clib" requires = "str, unix, threads" @@ -31,7 +31,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.13" + version = "8.14" directory = "lib" @@ -45,7 +45,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.13" + version = "8.14" directory = "kernel/byterun" @@ -64,7 +64,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.13" + version = "8.14" directory = "kernel" @@ -78,7 +78,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.13" + version = "8.14" requires = "coq.kernel" @@ -92,7 +92,7 @@ package "library" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.13" + version = "8.14" requires = "coq.library" directory = "engine" @@ -105,7 +105,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.13" + version = "8.14" requires = "coq.engine" directory = "pretyping" @@ -118,7 +118,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.13" + version = "8.14" requires = "zarith, coq.pretyping" directory = "interp" @@ -131,7 +131,7 @@ package "interp" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.13" + version = "8.14" requires = "coq.interp" directory = "proofs" @@ -144,7 +144,7 @@ package "proofs" ( package "gramlib" ( description = "Coq Grammar Engine" - version = "8.13" + version = "8.14" requires = "coq.lib" directory = "gramlib/.pack" @@ -156,7 +156,7 @@ package "gramlib" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.13" + version = "8.14" requires = "coq.gramlib, coq.proofs" directory = "parsing" @@ -169,7 +169,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.13" + version = "8.14" requires = "coq.parsing" directory = "printing" @@ -182,7 +182,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.13" + version = "8.14" requires = "coq.printing" directory = "tactics" @@ -195,7 +195,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.13" + version = "8.14" requires = "coq.tactics" directory = "vernac" @@ -208,7 +208,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.13" + version = "8.14" requires = "coq.vernac" directory = "stm" @@ -221,7 +221,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.13" + version = "8.14" requires = "coq.stm" directory = "toplevel" @@ -234,7 +234,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.13" + version = "8.14" requires = "coq.toplevel" directory = "ide" @@ -247,7 +247,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.13" + version = "8.14" requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" @@ -260,7 +260,7 @@ package "ide" ( package "ideprotocol" ( description = "Coq IDE protocol" - version = "8.13" + version = "8.14" requires = "coq.toplevel" directory = "ide/protocol" @@ -273,14 +273,14 @@ package "ideprotocol" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.13" + version = "8.14" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.13" + version = "8.14" requires = "coq.stm" directory = "ltac" @@ -295,7 +295,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "ltac" @@ -310,7 +310,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "omega" @@ -325,7 +325,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "micromega" @@ -340,7 +340,7 @@ package "plugins" ( package "zify" ( description = "Coq Zify plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "micromega" @@ -355,7 +355,7 @@ package "plugins" ( package "ring" ( description = "Coq ring plugin" - version = "8.13" + version = "8.14" requires = "" directory = "ring" @@ -370,7 +370,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "extraction" @@ -385,7 +385,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "cc" @@ -400,7 +400,7 @@ package "plugins" ( package "firstorder" ( description = "Coq ground plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "firstorder" @@ -415,7 +415,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "rtauto" @@ -430,7 +430,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "btauto" @@ -445,7 +445,7 @@ package "plugins" ( package "funind" ( description = "Coq recdef plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.extraction" directory = "funind" @@ -460,7 +460,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.13" + version = "8.14" requires = "zarith, coq.plugins.ltac" directory = "nsatz" @@ -475,7 +475,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.13" + version = "8.14" requires = "" directory = "syntax" @@ -490,7 +490,7 @@ package "plugins" ( package "int63syntax" ( description = "Coq int63syntax plugin" - version = "8.13" + version = "8.14" requires = "" directory = "syntax" @@ -505,7 +505,7 @@ package "plugins" ( package "string_notation" ( description = "Coq string_notation plugin" - version = "8.13" + version = "8.14" requires = "coq.vernac" directory = "syntax" @@ -519,7 +519,7 @@ package "plugins" ( package "numeral_notation" ( description = "Coq numeral notation plugin" - version = "8.13" + version = "8.14" requires = "coq.vernac" directory = "numeral_notation" @@ -534,7 +534,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.13" + version = "8.14" requires = "" directory = "derive" @@ -549,7 +549,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -564,7 +564,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ssrmatching" directory = "ssr" @@ -579,7 +579,7 @@ package "plugins" ( package "ltac2" ( description = "Coq Ltac2 Plugin" - version = "8.13" + version = "8.14" requires = "coq.plugins.ltac" directory = "../user-contrib/Ltac2" diff --git a/Makefile.ci b/Makefile.ci index af78f252df..d549ed1b39 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -34,14 +34,19 @@ CI_TARGETS= \ ci-fiat_crypto_ocaml \ ci-fiat_parsers \ ci-flocq \ + ci-fourcolor \ + ci-gappa \ ci-geocoq \ ci-coqhammer \ ci-hott \ + ci-interval \ ci-iris \ ci-math_classes \ ci-mathcomp \ + ci-menhir \ ci-metacoq \ ci-mtac2 \ + ci-oddorder \ ci-paramcoq \ ci-perennial \ ci-quickchick \ @@ -68,7 +73,7 @@ ci-all: $(CI_TARGETS) ci-color: ci-bignums ci-coqprime: ci-bignums - +ci-coquelicot: ci-mathcomp ci-math_classes: ci-bignums ci-corn: ci-math_classes @@ -78,6 +83,10 @@ ci-mtac2: ci-unicoq ci-fiat_crypto: ci-coqprime ci-rewriter 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-simple_io: ci-ext_lib ci-quickchick: ci-ext_lib ci-simple_io @@ -85,6 +94,9 @@ ci-metacoq: ci-equations ci-vst: ci-flocq +ci-compcert: ci-menhir ci-flocq +ci-gappa: ci-flocq + # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.ide b/Makefile.ide index 789acee5ec..9964a474f8 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -262,7 +262,7 @@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.dylib $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.dylib $@ || $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib @@ -271,8 +271,9 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ > $@/gtk-3.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.dylib |\ + { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.{dylib,so} |\ sed -e "s!/.*\(/immodules/.*.dylib\)!@executable_path/../Resources/\1!" |\ + sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ > $@/gtk-3.0/gtk-immodules.loaders $(MKDIR) $@/pango @@ -281,7 +282,7 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) $(MKDIR) $@ macpack -d ../Resources/lib $(COQIDEINAPP) - for i in $@/../loaders/*.so $@/../immodules/*.dylib; \ + for i in $@/../loaders/*.so $@/../immodules/*.{dylib,so}; \ do \ macpack -d ../lib $$i; \ done @@ -1,7 +1,7 @@ # Coq -[![GitLab][gitlab-badge]][gitlab-link] -[![Azure Pipelines][azure-badge]][azure-link] +[![GitLab CI][gitlab-badge]][gitlab-link] +[![GitHub CI][action-badge]][action-link] [![Zulip][zulip-badge]][zulip-link] [![Discourse][discourse-badge]][discourse-link] [![DOI][doi-badge]][doi-link] @@ -9,8 +9,8 @@ [gitlab-badge]: https://gitlab.com/coq/coq/badges/master/pipeline.svg [gitlab-link]: https://gitlab.com/coq/coq/commits/master -[azure-badge]: https://dev.azure.com/coq/coq/_apis/build/status/coq.coq?branchName=master -[azure-link]: https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master +[action-badge]: https://github.com/coq/coq/workflows/GitHub%20CI/badge.svg?branch=master +[action-link]: https://github.com/coq/coq/actions?query=workflow:"GitHub%20CI" [discourse-badge]: https://img.shields.io/badge/Discourse-forum-informational.svg [discourse-link]: https://coq.discourse.group/ diff --git a/azure-pipelines.yml b/azure-pipelines.yml deleted file mode 100644 index 46bd4367a7..0000000000 --- a/azure-pipelines.yml +++ /dev/null @@ -1,116 +0,0 @@ - -# NB: image names can be found at -# https://docs.microsoft.com/en-us/azure/devops/pipelines/agents/hosted - -variables: - NJOBS: "2" - -jobs: -- job: Windows - pool: - vmImage: 'vs2017-win2016' - - # Equivalent to allow_failure: true - # continueOnError: true - - steps: - - checkout: self - fetchDepth: 10 - - # cygwin package list not checked for minimality - - script: | - powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" - SET CYGROOT=C:\cygwin64 - SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib,mingw64-x86_64-gmp -P python3 - - SET TARGET_ARCH=x86_64-w64-mingw32 - SET CD_MFMT=%cd:\=/% - SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% - C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh - displayName: 'Install cygwin' - env: - CYGMIRROR: "http://mirror.cs.vt.edu/pub/cygwin/cygwin" - - - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh - displayName: 'Install opam' - - - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh - displayName: 'Build Coq' - - # We are hitting a bug where Dune is rebuilding Coq to run the - # test-suite, also it seems to time out, so we just build for now - # - # - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh - # displayName: 'Test Coq' - - - publish: _build/log - artifact: Dune Build Log - condition: always() - -- job: macOS - pool: - vmImage: 'macOS-10.14' - - variables: - MACOSX_DEPLOYMENT_TARGET: '10.11' - - steps: - - - checkout: self - fetchDepth: 10 - - - script: | - set -e - brew install gnu-time opam gtksourceview3 adwaita-icon-theme - pip3 install macpack - displayName: 'Install system dependencies' - - - script: | - set -e - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER - opam switch set ocaml-base-compiler.$COMPILER - eval $(opam env) - opam update - opam install -j "$NJOBS" ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.10 - opam list - displayName: 'Install OCaml dependencies' - env: - COMPILER: "4.11.1" - FINDLIB_VER: ".1.8.1" - OPAMYES: "true" - - - script: | - set -e - - eval $(opam env) - ./configure -prefix '$(Build.BinariesDirectory)' -warn-error yes -native-compiler no -coqide opt - make -j "$NJOBS" byte - make -j "$NJOBS" - displayName: 'Build Coq' - - - script: | - eval $(opam env) - export OCAMLPATH=$(pwd):"$OCAMLPATH" - make -j "$NJOBS" test-suite PRINT_LOGS=1 - displayName: 'Run Coq Test Suite' - - - script: | - make install - displayName: 'Install Coq' - -# - script: | -# set -e -# eval $(opam env) -# export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig -# ./dev/build/osx/make-macos-dmg.sh -# mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" -# displayName: 'Create the dmg bundle' -# env: -# OUTDIR: '$(Build.BinariesDirectory)' - -# - task: PublishBuildArtifacts@1 -# inputs: -# pathtoPublish: '$(Build.ArtifactStagingDirectory)' -# artifactName: coq-macOS-installer diff --git a/clib/cList.ml b/clib/cList.ml index 6b13fac48c..d5520aa2b7 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -23,6 +23,7 @@ sig val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val prefix_of : 'a eq -> 'a list -> 'a list -> bool + val same_length : 'a list -> 'b list -> bool val interval : int -> int -> int list val make : int -> 'a -> 'a list val addn : int -> 'a -> 'a list -> 'a list @@ -154,6 +155,11 @@ external cast : 'a cell -> 'a list = "%identity" (** {6 Equality, testing} *) +let rec same_length l1 l2 = match l1, l2 with +| [], [] -> true +| _ :: l1, _ :: l2 -> same_length l1 l2 +| ([], _ :: _) | (_ :: _, []) -> false + let rec compare cmp l1 l2 = if l1 == l2 then 0 else match l1,l2 with diff --git a/clib/cList.mli b/clib/cList.mli index c8e471f989..6c8df88767 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -42,6 +42,9 @@ sig (** [prefix_of eq l1 l2] returns [true] if [l1] is a prefix of [l2], [false] otherwise. It uses [eq] to compare elements *) + val same_length : 'a list -> 'b list -> bool + (** A more efficient variant of [for_all2eq (fun _ _ -> true)] *) + (** {6 Creating lists} *) val interval : int -> int -> int list diff --git a/clib/hashset.ml b/clib/hashset.ml index 89136e7870..ae43e7db92 100644 --- a/clib/hashset.ml +++ b/clib/hashset.ml @@ -52,7 +52,7 @@ module Make (E : EqType) = mutable rover : int; (* for internal bookkeeping *) } - let get_index t h = (h land max_int) mod (Array.length t.table) + let get_index t h = (h land max_int) mod (Array.length t) let limit = 7 let over_limit = 2 @@ -135,7 +135,7 @@ module Make (E : EqType) = let add_weak ob oh oi = let setter nb ni _ = Weak.blit ob oi nb ni 1 in let h = oh.(oi) in - add_aux newt setter None h (get_index newt h); + add_aux newt setter None h (get_index newt.table h); in iter_weak add_weak t; t.table <- newt.table; @@ -178,24 +178,28 @@ module Make (E : EqType) = in loop 0 - let find_or h t d ifnotfound = - let index = get_index t h in - let bucket = t.table.(index) in + let repr h d t = + let table = t.table in + let index = get_index table h in + let bucket = table.(index) in let hashes = t.hashes.(index) in let sz = Weak.length bucket in - let rec loop i = - if i >= sz then ifnotfound index - else if Int.equal h hashes.(i) then begin + let pos = ref 0 in + let ans = ref None in + while !pos < sz && !ans == None do + let i = !pos in + if Int.equal h hashes.(i) then begin match Weak.get bucket i with - | Some v when E.eq v d -> v - | _ -> loop (i + 1) - end else loop (i + 1) - in - loop 0 - - let repr h d t = - let ifnotfound index = add_aux t Weak.set (Some d) h index; d in - find_or h t d ifnotfound + | Some v as res when E.eq v d -> ans := res + | _ -> incr pos + end else incr pos + done; + if !pos >= sz then + let () = add_aux t Weak.set (Some d) h index in + d + else match !ans with + | None -> assert false + | Some v -> v let stats t = let fold accu bucket = max (count_bucket 0 bucket 0) accu in diff --git a/configure.ml b/configure.ml index e32f780a3d..40d77ed109 100644 --- a/configure.ml +++ b/configure.ml @@ -12,11 +12,11 @@ #load "str.cma" open Printf -let coq_version = "8.13+alpha" -let coq_macos_version = "8.12.90" (** "[...] should be a string comprised of +let coq_version = "8.14+alpha" +let coq_macos_version = "8.13.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 81291 -let state_magic = 581291 +let vo_magic = 81391 +let state_magic = 581391 let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; diff --git a/coq-doc.opam b/coq-doc.opam index 67cdbd8bf0..3a872db33d 100644 --- a/coq-doc.opam +++ b/coq-doc.opam @@ -20,7 +20,8 @@ depends: [ "coq" {build & = version} ] build: [ - ["dune" "subst"] {pinned} +# Disabled until Dune 2.8 is available +# ["dune" "subst"] {pinned} [ "dune" "build" @@ -26,7 +26,8 @@ depends: [ "zarith" {>= "1.10"} ] build: [ - ["dune" "subst"] {pinned} +# Disabled until Dune 2.8 is available +# ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coq.opam.docker b/coq.opam.docker index 74ca68ac0b..253e648d3e 100644 --- a/coq.opam.docker +++ b/coq.opam.docker @@ -27,8 +27,14 @@ depends: [ "conf-findutils" {build} ] +depopts: [ + "coq-native" +] + build: [ - [ "./configure" "-prefix" prefix "-coqide" "no" ] + [ "./configure" "-prefix" prefix "-coqide" "no" + "-native-compiler" "yes" {coq-native:installed} "no" {!coq-native:installed} + ] [make "-j%{jobs}%"] [make "-j%{jobs}%" "byte"] ] diff --git a/coqide-server.opam b/coqide-server.opam index 101cd4ad78..cbb0db2893 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -23,7 +23,8 @@ depends: [ "coq" {= version} ] build: [ - ["dune" "subst"] {pinned} +# Disabled until Dune 2.8 is available +# ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coqide.opam b/coqide.opam index 3007200fe5..9e4fb05701 100644 --- a/coqide.opam +++ b/coqide.opam @@ -21,7 +21,8 @@ depends: [ "coqide-server" {= version} ] build: [ - ["dune" "subst"] {pinned} +# Disabled until Dune 2.8 is available +# ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/default.nix b/default.nix index 7f9e62b28c..0b23bdb48c 100644 --- a/default.nix +++ b/default.nix @@ -29,7 +29,7 @@ , shell ? false # We don't use lib.inNixShell because that would also apply # when in a nix-shell of some package depending on this one. -, coq-version ? "8.13-git" +, coq-version ? "8.14-git" }: with pkgs; diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index 7796ae3b01..b616371ef8 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -287,8 +287,8 @@ create_opam() { /usr/bin/time -o "$log_dir/coq.$RUNNER.1.time" --format="%U %M %F" \ perf stat -e instructions:u,cycles:u -o "$log_dir/coq.$RUNNER.1.perf" \ opam pin add -y -b -j "$number_of_processors" --kind=path coq.dev . \ - 3>$log_dir/coq.$RUNNER.opam_install.1.stdout 1>&3 \ - 4>$log_dir/coq.$RUNNER.opam_install.1.stderr 2>&4 || \ + 3>$log_dir/coq.$RUNNER.opam_install.1.stdout.log 1>&3 \ + 4>$log_dir/coq.$RUNNER.opam_install.1.stderr.log 2>&4 || \ _RES=$? if [ $_RES = 0 ]; then echo "Coq ($RUNNER) installed successfully" @@ -363,8 +363,8 @@ for coq_opam_package in $sorted_coq_opam_packages; do opam config set-global jobs $number_of_processors opam install $coq_opam_package -v -b -j$number_of_processors --deps-only -y \ - 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stdout 1>&3 \ - 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stderr 2>&4 || continue 2 + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stdout.log 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stderr.log 2>&4 || continue 2 opam config set-global jobs 1 @@ -375,8 +375,8 @@ for coq_opam_package in $sorted_coq_opam_packages; do /usr/bin/time -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.time" --format="%U %M %F" \ perf stat -e instructions:u,cycles:u -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.perf" \ opam install -v -b -j1 $coq_opam_package \ - 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stdout 1>&3 \ - 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stderr 2>&4 || \ + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stdout.log 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stderr.log 2>&4 || \ _RES=$? if [ $_RES = 0 ]; then diff --git a/dev/bench/render_results b/dev/bench/render_results index 72affd70b2..bd4308837b 100755 --- a/dev/bench/render_results +++ b/dev/bench/render_results @@ -76,25 +76,13 @@ let run_and_read cmd = ;; let ( %> ) f g x = g (f x) -;; let run = run_and_read %> snd -;; module Float = struct let nan = Pervasives.nan end -module Tuple4 = struct - - let first (x,_,_,_) = x - let second (_,y,_,_) = y - let third (_,_,z,_) = z - let fourth (_,_,_,z) = z - -end -;; - module List = struct include List @@ -149,6 +137,151 @@ module String = struct end ;; +module Table : +sig + type header = string + type row = string list list + val print : header list -> row list -> string +end = +struct + type header = string + + type row = string list list + + let val_padding = 2 + (* Padding between data in the same row *) + let row_padding = 1 + (* Padding between rows *) + + let homogeneous b = if b then () else failwith "Heterogeneous data" + + let vert_split (ls : 'a list list) = + let split l = match l with + | [] -> failwith "vert_split" + | x :: l -> (x, l) + in + let ls = List.map split ls in + List.split ls + + let rec last = function + | [] -> assert false + | [x] -> [], x + | x :: l -> + let (l, y) = last l in + (x :: l, y) + + let justify n s = + let len = String.length s in + let () = assert (len <= n) in + let lft = (n - len) / 2 in + let rgt = n - lft - len in + String.make lft ' ' ^ s ^ String.make rgt ' ' + + let justify_row layout data = + let map n s = + let len = String.length s in + let () = assert (len <= n) in + (* Right align *) + let pad = n - len in + String.make pad ' ' ^ s + in + let data = List.map2 map layout data in + String.concat (String.make val_padding ' ') data + + let angle hkind vkind = match hkind, vkind with + | `Lft, `Top -> "┌" + | `Rgt, `Top -> "┐" + | `Mid, `Top -> "┬" + | `Lft, `Mid -> "├" + | `Rgt, `Mid -> "┤" + | `Mid, `Mid -> "┼" + | `Lft, `Bot -> "└" + | `Rgt, `Bot -> "┘" + | `Mid, `Bot -> "┴" + + let print_separator vkind col_size = + let rec dashes n = if n = 0 then "" else "─" ^ dashes (n - 1) in + let len = List.length col_size in + let pad = dashes row_padding in + let () = assert (0 < len) in + let map n = dashes n in + angle `Lft vkind ^ pad ^ + String.concat (pad ^ angle `Mid vkind ^ pad) (List.map map col_size) ^ + pad ^ angle `Rgt vkind + + let print_blank col_size = + let len = List.length col_size in + let () = assert (0 < len) in + let pad = String.make row_padding ' ' in + let map n = String.make n ' ' in + "│" ^ pad ^ String.concat (pad ^ "│" ^ pad) (List.map map col_size) ^ pad ^ "│" + + let print_row row = + let len = List.length row in + let () = assert (0 < len) in + let pad = String.make row_padding ' ' in + "│" ^ pad ^ String.concat (pad ^ "│" ^ pad) row ^ pad ^ "│" + + (* Invariant : all rows must have the same shape *) + + let print (headers : header list) (rows : row list) = + (* Sanitize input *) + let ncolums = List.length headers in + let shape = ref None in + let check row = + let () = homogeneous (List.length row = ncolums) in + let rshape : int list = List.map (fun data -> List.length data) row in + match !shape with + | None -> shape := Some rshape + | Some s -> homogeneous (rshape = s) + in + let () = List.iter check rows in + (* Compute layout *) + let rec layout n (rows : row list) = + if n = 0 then [] + else + let (col, rows) = vert_split rows in + let ans = layout (n - 1) rows in + let data = ref None in + let iter args = + let size = List.map String.length args in + match !data with + | None -> data := Some size + | Some s -> + data := Some (List.map2 (fun len1 len2 -> max len1 len2) s size) + in + let () = List.iter iter col in + let data = match !data with None -> [] | Some s -> s in + data :: ans + in + let layout = layout ncolums rows in + let map hd shape = + let data_size = match shape with + | [] -> 0 + | n :: shape -> List.fold_left (fun accu n -> accu + n + val_padding) n shape + in + max (String.length hd) data_size + in + let col_size = List.map2 map headers layout in + (* Justify the data *) + let headers = List.map2 justify col_size headers in + let rows = List.map (fun row -> List.map2 justify col_size (List.map2 justify_row layout row)) rows in + (* Print the table *) + let rows, last = last rows in + let sep = print_separator `Mid col_size in + let rows = List.concat @@ List.map (fun r -> [print_row r; sep]) rows in + let lines = + print_separator `Top col_size :: + print_row headers :: + print_blank col_size :: + rows @ + print_row last :: + print_separator `Bot col_size :: + [] + in + String.concat "\n" lines +end + (******************************************************************************) (* END Copied from batteries, to remove *) (******************************************************************************) @@ -203,10 +336,6 @@ let proportional_difference_of_integers new_value old_value = else float_of_int (new_value - old_value) /. float_of_int old_value *. 100.0 in -let count_number_of_digits_before_decimal_point = - log10 %> floor %> int_of_float %> succ %> max 1 -in - (* parse the *.time and *.perf files *) coq_opam_packages |> List.map @@ -259,138 +388,39 @@ coq_opam_packages (* Below we take the measurements and format them to stdout. *) +|> List.map begin fun (package_name, new_t, old_t, perc) -> + + let precision = 2 in + let prf f = Printf.sprintf "%.*f" precision f in + let pri n = Printf.sprintf "%d" n in + + [ + [ package_name ]; + [ prf new_t.user_time; prf old_t.user_time; prf perc.user_time ]; + [ pri new_t.num_cycles; pri old_t.num_cycles; prf perc.num_cycles ]; + [ pri new_t.num_instr; pri old_t.num_instr; prf perc.num_instr ]; + [ pri new_t.num_mem; pri old_t.num_mem; prf perc.num_mem ]; + [ pri new_t.num_faults; pri old_t.num_faults; prf perc.num_faults ]; + ] + + end + |> fun measurements -> - let precision = 2 in - - (* the labels that we will print *) - let package_name__label = "package_name" in - let new__label = "NEW" in - let old__label = "OLD" in - let proportional_difference__label = "PDIFF" in - - (* the lengths of labels that we will print *) - let new__label__length = String.length new__label in - let proportional_difference__label__length = String.length proportional_difference__label in - - (* widths of individual columns of the table *) - let package_name__width = - max (measurements |> List.map (Tuple4.first %> String.length) |> List.max) - (String.length package_name__label) in - - let llf proj = - let lls = count_number_of_digits_before_decimal_point (List.max proj) + 1 + precision in - max lls new__label__length in - - let lli proj = - let lls = count_number_of_digits_before_decimal_point (float_of_int (List.(max proj))) + 1 + precision in - max lls new__label__length in - - let new_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.second measurements in - let old_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.third measurements in - - let llp proj = - let lls = - count_number_of_digits_before_decimal_point List.(max List.(map abs_float proj)) + 2 + precision in - max lls proportional_difference__label__length in - - let perc_timing_width = reduce_pkg_timings llp llp @@ List.map Tuple4.fourth measurements in - - (* print the table *) - let rec make_dashes = function - | 0 -> "" - | count -> "─" ^ make_dashes (pred count) - in - - let vertical_separator left_glyph middle_glyph right_glyph = - sprintf "%s─%s─%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s\n" - left_glyph - (make_dashes package_name__width) - middle_glyph - (make_dashes new_timing_width.user_time) - (make_dashes old_timing_width.user_time) - (make_dashes perc_timing_width.user_time) - middle_glyph - (make_dashes new_timing_width.num_cycles) - (make_dashes old_timing_width.num_cycles) - (make_dashes perc_timing_width.num_cycles) - middle_glyph - (make_dashes new_timing_width.num_instr) - (make_dashes old_timing_width.num_instr) - (make_dashes perc_timing_width.num_instr) - middle_glyph - (make_dashes new_timing_width.num_mem) - (make_dashes old_timing_width.num_mem) - (make_dashes perc_timing_width.num_mem) - middle_glyph - (make_dashes new_timing_width.num_faults) - (make_dashes old_timing_width.num_faults) - (make_dashes perc_timing_width.num_faults) - right_glyph - in - - let center_string string width = - let string_length = String.length string in - let width = max width string_length in - let left_hfill = (width - string_length) / 2 in - let right_hfill = width - left_hfill - string_length in - String.make left_hfill ' ' ^ string ^ String.make right_hfill ' ' - in - printf "\n"; - print_string (vertical_separator "┌" "┬" "┐"); - "│" ^ String.make (1 + package_name__width + 1) ' ' ^ "│" - ^ center_string "user time [s]" (1 + new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) ^ "│" - ^ center_string "CPU cycles" (1 + new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) ^ "│" - ^ center_string "CPU instructions" (1 + new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) ^ "│" - ^ center_string "max resident mem [KB]" (1 + new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) ^ "│" - ^ center_string "mem faults" (1 + new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) - ^ "│\n" |> print_string; - printf "│%*s │ %*s│ %*s│ %*s│ %*s│ %*s│\n" - (1 + package_name__width) "" - (new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) "" - (new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) "" - (new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) "" - (new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) "" - (new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) ""; - printf "│ %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │\n" - package_name__width package_name__label - new_timing_width.user_time new__label - old_timing_width.user_time old__label - perc_timing_width.user_time proportional_difference__label - new_timing_width.num_cycles new__label - old_timing_width.num_cycles old__label - perc_timing_width.num_cycles proportional_difference__label - new_timing_width.num_instr new__label - old_timing_width.num_instr old__label - perc_timing_width.num_instr proportional_difference__label - new_timing_width.num_mem new__label - old_timing_width.num_mem old__label - perc_timing_width.num_mem proportional_difference__label - new_timing_width.num_faults new__label - old_timing_width.num_faults old__label - perc_timing_width.num_faults proportional_difference__label; - measurements |> List.iter - (fun (package_name, new_t, old_t, perc) -> - print_string (vertical_separator "├" "┼" "┤"); - printf "│ %*s │ %*.*f %*.*f %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │\n" - package_name__width package_name - new_timing_width.user_time precision new_t.user_time - old_timing_width.user_time precision old_t.user_time - perc_timing_width.user_time precision perc.user_time - new_timing_width.num_cycles new_t.num_cycles - old_timing_width.num_cycles old_t.num_cycles - perc_timing_width.num_cycles precision perc.num_cycles - new_timing_width.num_instr new_t.num_instr - old_timing_width.num_instr old_t.num_instr - perc_timing_width.num_instr precision perc.num_instr - new_timing_width.num_mem new_t.num_mem - old_timing_width.num_mem old_t.num_mem - perc_timing_width.num_mem precision perc.num_mem - new_timing_width.num_faults new_t.num_faults - old_timing_width.num_faults old_t.num_faults - perc_timing_width.num_faults precision perc.num_faults); - -print_string (vertical_separator "└" "┴" "┘"); + let headers = [ + ""; + "user time [s]"; + "CPU cycles"; + "CPU instructions"; + "max resident mem [KB]"; + "mem faults"; + ] in + + let descr = ["NEW"; "OLD"; "PDIFF"] in + let top = [ [ "package_name" ]; descr; descr; descr; descr; descr ] in + + printf "%s%!" (Table.print headers (top :: measurements)) +; (* ejgallego: disable this as it is very verbose and brings up little info in the log. *) if false then begin diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 6f6b3cd6d2..ebbf10f548 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1200,7 +1200,7 @@ function make_elpi { make_dune make_re - if build_prep https://github.com/LPCIC/elpi/archive v1.11.4 tar.gz 1 elpi; then + if build_prep https://github.com/LPCIC/elpi/archive v1.12.0 tar.gz 1 elpi; then log2 dune build -p elpi log2 dune install elpi @@ -1749,7 +1749,7 @@ function make_addon_compcert { installer_addon_dependency_end if build_prep_overlay compcert; then installer_addon_section compcert "CompCert" "ATTENTION: THIS IS NOT OPEN SOURCE! CompCert verified C compiler and Clightgen (required for using VST for your own code)" "off" - logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin + logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin -use-external-MenhirLib -use-external-Flocq log1 make $MAKE_OPT log2 make install logn install-license-1 install -D -T "LICENSE" "$PREFIXCOQ/lib/coq/user-contrib/compcert/LICENSE" diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 801e29ac95..f5ca6c495f 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -171,7 +171,7 @@ loaded by subsequent jobs. **IMPORTANT**: When updating Coq's CI docker image, you must modify the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) -and [`Dockerfile`](docker/bionic_coq/Dockerfile) +(see comment near it for details). The Docker building job reuses the uploaded image if it is available, but if you wish to save more time you can skip the job by setting diff --git a/dev/ci/azure-build.sh b/dev/ci/azure-build.sh index 494651c5bf..1b02cd45ed 100755 --- a/dev/ci/azure-build.sh +++ b/dev/ci/azure-build.sh @@ -4,4 +4,5 @@ set -e -x cd $(dirname $0)/../.. +eval $(opam env) dune build coq.install coqide-server.install diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 75d9efaadc..97d9537508 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -1,54 +1,71 @@ #!/usr/bin/env bash -# This is the basic overlay set for repositories in the CI. - -# Maybe we should just use Ruby to have real objects... - -# : "${foo:=bar}" sets foo to "bar" if it is unset or null +# This is the list of repositories used by the CI scripts, unless overridden +# by a call to the "overlay" function in ci-common + +declare -a projects # the list of project repos that can be be overlayed + +# checks if the given argument is a known project +function is_in_projects { + for x in "${projects[@]}"; do + if [ "$1" = "$x" ]; then return 0; fi; + done + return 1 +} + +# project <name> <giturl> <ref> [<archiveurl>] +# [<archiveurl>] defaults to <giturl>/archive on github.com +# and <giturl>/-/archive on gitlab +function project { + + local var_ref=${1}_CI_REF + local var_giturl=${1}_CI_GITURL + local var_archiveurl=${1}_CI_ARCHIVEURL + local giturl=$2 + local ref=$3 + local archiveurl=$4 + case $giturl in + *github.com*) archiveurl=${archiveurl:-$giturl/archive} ;; + *gitlab*) archiveurl=${archiveurl:-$giturl/-/archive} ;; + esac + + # register the project in the list of projects + projects[${#projects[*]}]=$1 + + # bash idiom for setting a variable if not already set + : "${!var_ref:=$ref}" + : "${!var_giturl:=$giturl}" + : "${!var_archiveurl:=$archiveurl}" + +} ######################################################################## # MathComp ######################################################################## -: "${mathcomp_CI_REF:=master}" -: "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp}" -: "${mathcomp_CI_ARCHIVEURL:=${mathcomp_CI_GITURL}/archive}" +project mathcomp "https://github.com/math-comp/math-comp" "master" -: "${fourcolor_CI_REF:=master}" -: "${fourcolor_CI_GITURL:=https://github.com/math-comp/fourcolor}" -: "${fourcolor_CI_ARCHIVEURL:=${fourcolor_CI_GITURL}/archive}" +project fourcolor "https://github.com/math-comp/fourcolor" "master" -: "${oddorder_CI_REF:=master}" -: "${oddorder_CI_GITURL:=https://github.com/math-comp/odd-order}" -: "${oddorder_CI_ARCHIVEURL:=${oddorder_CI_GITURL}/archive}" +project oddorder "https://github.com/math-comp/odd-order" "master" ######################################################################## # UniMath ######################################################################## -: "${unimath_CI_REF:=master}" -: "${unimath_CI_GITURL:=https://github.com/UniMath/UniMath}" -: "${unimath_CI_ARCHIVEURL:=${unimath_CI_GITURL}/archive}" +project unimath "https://github.com/UniMath/UniMath" "master" ######################################################################## # Unicoq + Mtac2 ######################################################################## -: "${unicoq_CI_REF:=master}" -: "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq}" -: "${unicoq_CI_ARCHIVEURL:=${unicoq_CI_GITURL}/archive}" +project unicoq "https://github.com/unicoq/unicoq" "master" -: "${mtac2_CI_REF:=master}" -: "${mtac2_CI_GITURL:=https://github.com/Mtac2/Mtac2}" -: "${mtac2_CI_ARCHIVEURL:=${mtac2_CI_GITURL}/archive}" +project mtac2 "https://github.com/Mtac2/Mtac2" "master" ######################################################################## # Mathclasses + Corn ######################################################################## -: "${math_classes_CI_REF:=master}" -: "${math_classes_CI_GITURL:=https://github.com/coq-community/math-classes}" -: "${math_classes_CI_ARCHIVEURL:=${math_classes_CI_GITURL}/archive}" +project math_classes "https://github.com/coq-community/math-classes" "master" -: "${corn_CI_REF:=master}" -: "${corn_CI_GITURL:=https://github.com/coq-community/corn}" -: "${corn_CI_ARCHIVEURL:=${corn_CI_GITURL}/archive}" +project corn "https://github.com/coq-community/corn" "master" ######################################################################## # Iris @@ -56,342 +73,238 @@ # NB: stdpp and Iris refs are gotten from the opam files in the Iris # and lambdaRust repos respectively. -: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" -: "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" +project stdpp "https://gitlab.mpi-sws.org/iris/stdpp" "" -: "${iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" -: "${iris_CI_ARCHIVEURL:=${iris_CI_GITURL}/-/archive}" +project iris "https://gitlab.mpi-sws.org/iris/iris" "" -: "${autosubst_CI_REF:=coq86-devel}" -: "${autosubst_CI_GITURL:=https://github.com/RalfJung/autosubst}" -: "${autosubst_CI_ARCHIVEURL:=${autosubst_CI_GITURL}/archive}" +project autosubst "https://github.com/coq-community/autosubst" "master" -: "${iris_string_ident_CI_REF:=master}" -: "${iris_string_ident_CI_GITURL:=https://gitlab.mpi-sws.org/iris/string-ident}" -: "${iris_string_ident_CI_ARCHIVEURL:=${iris_string_ident_CI_GITURL}/-/archive}" +project iris_string_ident "https://gitlab.mpi-sws.org/iris/string-ident" "master" -: "${iris_examples_CI_REF:=master}" -: "${iris_examples_CI_GITURL:=https://gitlab.mpi-sws.org/iris/examples}" -: "${iris_examples_CI_ARCHIVEURL:=${iris_examples_CI_GITURL}/-/archive}" +project iris_examples "https://gitlab.mpi-sws.org/iris/examples" "master" ######################################################################## # HoTT ######################################################################## -: "${hott_CI_REF:=master}" -: "${hott_CI_GITURL:=https://github.com/HoTT/HoTT}" -: "${hott_CI_ARCHIVEURL:=${hott_CI_GITURL}/archive}" +project hott "https://github.com/HoTT/HoTT" "master" ######################################################################## # CoqHammer ######################################################################## -: "${coqhammer_CI_REF:=master}" -: "${coqhammer_CI_GITURL:=https://github.com/lukaszcz/coqhammer}" -: "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" +project coqhammer "https://github.com/lukaszcz/coqhammer" "master" ######################################################################## # GeoCoq ######################################################################## -: "${geocoq_CI_REF:=master}" -: "${geocoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" -: "${geocoq_CI_ARCHIVEURL:=${geocoq_CI_GITURL}/archive}" +project geocoq "https://github.com/GeoCoq/GeoCoq" "master" ######################################################################## # Flocq ######################################################################## -: "${flocq_CI_REF:=master}" -: "${flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" -: "${flocq_CI_ARCHIVEURL:=${flocq_CI_GITURL}/-/archive}" +project flocq "https://gitlab.inria.fr/flocq/flocq" "master" ######################################################################## # coq-performance-tests ######################################################################## -: "${coq_performance_tests_CI_REF:=master}" -: "${coq_performance_tests_CI_GITURL:=https://github.com/coq-community/coq-performance-tests}" -: "${coq_performance_tests_CI_ARCHIVEURL:=${coq_performance_tests_CI_GITURL}/archive}" +project coq_performance_tests "https://github.com/coq-community/coq-performance-tests" "master" ######################################################################## # coq-tools ######################################################################## -: "${coq_tools_CI_REF:=master}" -: "${coq_tools_CI_GITURL:=https://github.com/JasonGross/coq-tools}" -: "${coq_tools_CI_ARCHIVEURL:=${coq_tools_CI_GITURL}/archive}" +project coq_tools "https://github.com/JasonGross/coq-tools" "master" ######################################################################## # Coquelicot ######################################################################## -: "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" -: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" +project coquelicot "https://gitlab.inria.fr/coquelicot/coquelicot" "master" ######################################################################## # Coq-interval ######################################################################## -: "${interval_CI_REF:=master}" -: "${interval_CI_GITURL:=https://gitlab.inria.fr/coqinterval/interval}" -: "${interval_CI_ARCHIVEURL:=${interval_CI_GITURL}/-/archive}" +project interval "https://gitlab.inria.fr/coqinterval/interval" "master" ######################################################################## # Gappa stand alone tool ######################################################################## -: "${gappa_tool_CI_REF:=master}" -: "${gappa_tool_CI_GITURL:=https://gitlab.inria.fr/gappa/gappa}" -: "${gappa_tool_CI_ARCHIVEURL:=${gappa_tool_CI_GITURL}/-/archive}" +project gappa_tool "https://gitlab.inria.fr/gappa/gappa" "master" ######################################################################## # Gappa plugin ######################################################################## -: "${gappa_plugin_CI_REF:=master}" -: "${gappa_plugin_CI_GITURL:=https://gitlab.inria.fr/gappa/coq}" -: "${gappa_plugin_CI_ARCHIVEURL:=${gappa_plugin_CI_GITURL}/-/archive}" +project gappa "https://gitlab.inria.fr/gappa/coq" "master" ######################################################################## # CompCert ######################################################################## -: "${compcert_CI_REF:=master}" -: "${compcert_CI_GITURL:=https://github.com/AbsInt/CompCert}" -: "${compcert_CI_ARCHIVEURL:=${compcert_CI_GITURL}/archive}" +project compcert "https://github.com/AbsInt/CompCert" "master" ######################################################################## # VST ######################################################################## -: "${vst_CI_REF:=master}" -: "${vst_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" -: "${vst_CI_ARCHIVEURL:=${vst_CI_GITURL}/archive}" +project vst "https://github.com/PrincetonUniversity/VST" "master" ######################################################################## # cross-crypto ######################################################################## -: "${cross_crypto_CI_REF:=master}" -: "${cross_crypto_CI_GITURL:=https://github.com/mit-plv/cross-crypto}" -: "${cross_crypto_CI_ARCHIVEURL:=${cross_crypto_CI_GITURL}/archive}" +project cross_crypto "https://github.com/mit-plv/cross-crypto" "master" ######################################################################## # rewriter ######################################################################## -: "${rewriter_CI_REF:=master}" -: "${rewriter_CI_GITURL:=https://github.com/mit-plv/rewriter}" -: "${rewriter_CI_ARCHIVEURL:=${rewriter_CI_GITURL}/archive}" +project rewriter "https://github.com/mit-plv/rewriter" "master" ######################################################################## # fiat_parsers ######################################################################## -: "${fiat_parsers_CI_REF:=master}" -: "${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat}" -: "${fiat_parsers_CI_ARCHIVEURL:=${fiat_parsers_CI_GITURL}/archive}" +project fiat_parsers "https://github.com/mit-plv/fiat" "master" ######################################################################## # fiat_crypto ######################################################################## -: "${fiat_crypto_CI_REF:=master}" -: "${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" -: "${fiat_crypto_CI_ARCHIVEURL:=${fiat_crypto_CI_GITURL}/archive}" +project fiat_crypto "https://github.com/mit-plv/fiat-crypto" "master" ######################################################################## # fiat_crypto_legacy ######################################################################## -: "${fiat_crypto_legacy_CI_REF:=sp2019latest}" -: "${fiat_crypto_legacy_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" -: "${fiat_crypto_legacy_CI_ARCHIVEURL:=${fiat_crypto_legacy_CI_GITURL}/archive}" +project fiat_crypto_legacy "https://github.com/mit-plv/fiat-crypto" "sp2019latest" ######################################################################## # coq_dpdgraph ######################################################################## -: "${coq_dpdgraph_CI_REF:=coq-master}" -: "${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph}" -: "${coq_dpdgraph_CI_ARCHIVEURL:=${coq_dpdgraph_CI_GITURL}/archive}" +project coq_dpdgraph "https://github.com/Karmaki/coq-dpdgraph" "coq-master" ######################################################################## # CoLoR ######################################################################## -: "${color_CI_REF:=master}" -: "${color_CI_GITURL:=https://github.com/fblanqui/color}" -: "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}" +project color "https://github.com/fblanqui/color" "master" ######################################################################## # TLC ######################################################################## -: "${tlc_CI_REF:=master-for-coq-ci}" -: "${tlc_CI_GITURL:=https://github.com/charguer/tlc}" -: "${tlc_CI_ARCHIVEURL:=${tlc_CI_GITURL}/archive}" +project tlc "https://github.com/charguer/tlc" "master-for-coq-ci" ######################################################################## # Bignums ######################################################################## -: "${bignums_CI_REF:=master}" -: "${bignums_CI_GITURL:=https://github.com/coq/bignums}" -: "${bignums_CI_ARCHIVEURL:=${bignums_CI_GITURL}/archive}" +project bignums "https://github.com/coq/bignums" "master" ######################################################################## # coqprime ######################################################################## -: "${coqprime_CI_REF:=master}" -: "${coqprime_CI_GITURL:=https://github.com/thery/coqprime}" -: "${coqprime_CI_ARCHIVEURL:=${coqprime_CI_GITURL}/archive}" +project coqprime "https://github.com/thery/coqprime" "master" ######################################################################## # bbv ######################################################################## -: "${bbv_CI_REF:=master}" -: "${bbv_CI_GITURL:=https://github.com/mit-plv/bbv}" -: "${bbv_CI_ARCHIVEURL:=${bbv_CI_GITURL}/archive}" +project bbv "https://github.com/mit-plv/bbv" "master" ######################################################################## # bedrock2 ######################################################################## -: "${bedrock2_CI_REF:=tested}" -: "${bedrock2_CI_GITURL:=https://github.com/mit-plv/bedrock2}" -: "${bedrock2_CI_ARCHIVEURL:=${bedrock2_CI_GITURL}/archive}" +project bedrock2 "https://github.com/mit-plv/bedrock2" "tested" ######################################################################## # Equations ######################################################################## -: "${equations_CI_REF:=master}" -: "${equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" -: "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}" +project equations "https://github.com/mattam82/Coq-Equations" "master" ######################################################################## # Elpi + Hierarchy Builder ######################################################################## -: "${elpi_CI_REF:=coq-master}" -: "${elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" -: "${elpi_CI_ARCHIVEURL:=${elpi_CI_GITURL}/archive}" +project elpi "https://github.com/LPCIC/coq-elpi" "coq-master" -: "${elpi_hb_CI_REF:=coq-master}" -: "${elpi_hb_CI_GITURL:=https://github.com/math-comp/hierarchy-builder}" -: "${elpi_hb_CI_ARCHIVEURL:=${elpi_hb_CI_GITURL}/archive}" +project hierarchy_builder "https://github.com/math-comp/hierarchy-builder" "coq-master" ######################################################################## # Engine-Bench ######################################################################## -: "${engine_bench_CI_REF:=master}" -: "${engine_bench_CI_GITURL:=https://github.com/mit-plv/engine-bench}" -: "${engine_bench_CI_ARCHIVEURL:=${engine_bench_CI_GITURL}/archive}" +project engine_bench "https://github.com/mit-plv/engine-bench" "master" ######################################################################## # fcsl-pcm ######################################################################## -: "${fcsl_pcm_CI_REF:=master}" -: "${fcsl_pcm_CI_GITURL:=https://github.com/imdea-software/fcsl-pcm}" -: "${fcsl_pcm_CI_ARCHIVEURL:=${fcsl_pcm_CI_GITURL}/archive}" +project fcsl_pcm "https://github.com/imdea-software/fcsl-pcm" "master" ######################################################################## # ext-lib ######################################################################## -: "${ext_lib_CI_REF:=master}" -: "${ext_lib_CI_GITURL:=https://github.com/coq-community/coq-ext-lib}" -: "${ext_lib_CI_ARCHIVEURL:=${ext_lib_CI_GITURL}/archive}" +project ext_lib "https://github.com/coq-community/coq-ext-lib" "master" ######################################################################## # simple-io ######################################################################## -: "${simple_io_CI_REF:=master}" -: "${simple_io_CI_GITURL:=https://github.com/Lysxia/coq-simple-io}" -: "${simple_io_CI_ARCHIVEURL:=${simple_io_CI_GITURL}/archive}" +project simple_io "https://github.com/Lysxia/coq-simple-io" "master" ######################################################################## # quickchick ######################################################################## -: "${quickchick_CI_REF:=master}" -: "${quickchick_CI_GITURL:=https://github.com/QuickChick/QuickChick}" -: "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" +project quickchick "https://github.com/QuickChick/QuickChick" "master" ######################################################################## # reduction-effects ######################################################################## -: "${reduction_effects_CI_REF:=master}" -: "${reduction_effects_CI_GITURL:=https://github.com/coq-community/reduction-effects}" -: "${reduction_effects_CI_ARCHIVEURL:=${reduction_effects_CI_GITURL}/archive}" +project reduction_effects "https://github.com/coq-community/reduction-effects" "master" ######################################################################## # menhirlib ######################################################################## # Note: menhirlib is now in subfolder coq-menhirlib of menhir -: "${menhirlib_CI_REF:=master}" -: "${menhirlib_CI_GITURL:=https://gitlab.inria.fr/fpottier/menhir}" -: "${menhirlib_CI_ARCHIVEURL:=${menhirlib_CI_GITURL}/-/archive}" +project menhirlib "https://gitlab.inria.fr/fpottier/menhir" "20201122" ######################################################################## # aac_tactics ######################################################################## -: "${aac_tactics_CI_REF:=master}" -: "${aac_tactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}" -: "${aac_tactics_CI_ARCHIVEURL:=${aac_tactics_CI_GITURL}/archive}" +project aac_tactics "https://github.com/coq-community/aac-tactics" "master" ######################################################################## # paramcoq ######################################################################## -: "${paramcoq_CI_REF:=master}" -: "${paramcoq_CI_GITURL:=https://github.com/coq-community/paramcoq}" -: "${paramcoq_CI_ARCHIVEURL:=${paramcoq_CI_GITURL}/archive}" +project paramcoq "https://github.com/coq-community/paramcoq" "master" ######################################################################## # relation_algebra ######################################################################## -: "${relation_algebra_CI_REF:=master}" -: "${relation_algebra_CI_GITURL:=https://github.com/damien-pous/relation-algebra}" -: "${relation_algebra_CI_ARCHIVEURL:=${relation_algebra_CI_GITURL}/archive}" +project relation_algebra "https://github.com/damien-pous/relation-algebra" "master" ######################################################################## # StructTact + InfSeqExt + Cheerios + Verdi + Verdi Raft ######################################################################## -: "${struct_tact_CI_REF:=master}" -: "${struct_tact_CI_GITURL:=https://github.com/uwplse/StructTact}" -: "${struct_tact_CI_ARCHIVEURL:=${struct_tact_CI_GITURL}/archive}" +project struct_tact "https://github.com/uwplse/StructTact" "master" -: "${inf_seq_ext_CI_REF:=master}" -: "${inf_seq_ext_CI_GITURL:=https://github.com/DistributedComponents/InfSeqExt}" -: "${inf_seq_ext_CI_ARCHIVEURL:=${inf_seq_ext_CI_GITURL}/archive}" +project inf_seq_ext "https://github.com/DistributedComponents/InfSeqExt" "master" -: "${cheerios_CI_REF:=master}" -: "${cheerios_CI_GITURL:=https://github.com/uwplse/cheerios}" -: "${cheerios_CI_ARCHIVEURL:=${cheerios_CI_GITURL}/archive}" +project cheerios "https://github.com/uwplse/cheerios" "master" -: "${verdi_CI_REF:=master}" -: "${verdi_CI_GITURL:=https://github.com/uwplse/verdi}" -: "${verdi_CI_ARCHIVEURL:=${verdi_CI_GITURL}/archive}" +project verdi "https://github.com/uwplse/verdi" "master" -: "${verdi_raft_CI_REF:=master}" -: "${verdi_raft_CI_GITURL:=https://github.com/uwplse/verdi-raft}" -: "${verdi_raft_CI_ARCHIVEURL:=${verdi_raft_CI_GITURL}/archive}" +project verdi_raft "https://github.com/uwplse/verdi-raft" "master" ######################################################################## # stdlib2 ######################################################################## -: "${stdlib2_CI_REF:=master}" -: "${stdlib2_CI_GITURL:=https://github.com/coq/stdlib2}" -: "${stdlib2_CI_ARCHIVEURL:=${stdlib2_CI_GITURL}/archive}" +project stdlib2 "https://github.com/coq/stdlib2" "master" ######################################################################## # argosy ######################################################################## -: "${argosy_CI_REF:=master}" -: "${argosy_CI_GITURL:=https://github.com/mit-pdos/argosy}" -: "${argosy_CI_ARCHIVEURL:=${argosy_CI_GITURL}/archive}" +project argosy "https://github.com/mit-pdos/argosy" "master" ######################################################################## # perennial ######################################################################## -: "${perennial_CI_REF:=coq/tested}" -: "${perennial_CI_GITURL:=https://github.com/mit-pdos/perennial}" -: "${perennial_CI_ARCHIVEURL:=${perennial_CI_GITURL}/archive}" +project perennial "https://github.com/mit-pdos/perennial" "coq/tested" ######################################################################## # metacoq ######################################################################## -: "${metacoq_CI_REF:=master}" -: "${metacoq_CI_GITURL:=https://github.com/MetaCoq/metacoq}" -: "${metacoq_CI_ARCHIVEURL:=${metacoq_CI_GITURL}/archive}" +project metacoq "https://github.com/MetaCoq/metacoq" "master" ######################################################################## # SF suite ######################################################################## -: "${sf_CI_REF:=master}" -: "${sf_CI_GITURL:=https://github.com/DeepSpec/sf}" -: "${sf_CI_ARCHIVEURL:=${sf_CI_GITURL}/archive}" +project sf "https://github.com/DeepSpec/sf" "master" ######################################################################## # Coqtail ######################################################################## -: "${coqtail_CI_REF:=master}" -: "${coqtail_CI_GITURL:=https://github.com/whonore/Coqtail}" -: "${coqtail_CI_ARCHIVEURL:=${coqtail_CI_GITURL}/archive}" +project coqtail "https://github.com/whonore/Coqtail" "master" diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index b85261d7fc..8d8f78e10c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -19,20 +19,20 @@ then elif [ -d "$PWD/_build/install/default/" ]; then # Dune build - export OCAMLPATH="$PWD/_build/install/default/lib/:$OCAMLPATH" + export OCAMLPATH="$PWD/_build/install/default/lib/:$PWD/_install_ci/lib:$OCAMLPATH" export COQBIN="$PWD/_build/install/default/bin" export COQLIB="$PWD/_build/install/default/lib/coq" CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" export CI_BRANCH else # We assume we are in `-profile devel` build, thus `-local` is set - export OCAMLPATH="$PWD:$OCAMLPATH" + export OCAMLPATH="$PWD:$PWD/_install_ci/lib:$OCAMLPATH" export COQBIN="$PWD/bin" CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" export CI_BRANCH fi -export PATH="$COQBIN:$PATH" +export PATH="$COQBIN:$PWD/_install_ci/bin:$PATH" # Coq's tools need an ending slash :S, we should fix them. export COQBIN="$COQBIN/" @@ -42,28 +42,45 @@ ls -l "$COQBIN" # Where we download and build external developments CI_BUILD_DIR="$PWD/_build_ci" +# Where we install external binaries and ocaml libraries +CI_INSTALL_DIR="$PWD/_install_ci" + ls -l "$CI_BUILD_DIR" || true declare -A overlays -overlay() +# overlay <project> <giturl> <ref> <prnumber> [<prbranch>] +# creates an overlay for project using a given url and branch which is +# active for prnumber or prbranch. prbranch defaults to ref. +function overlay() { local project=$1 local ov_url=$2 local ov_ref=$3 - - overlays[${project}_URL]=$ov_url - overlays[${project}_REF]=$ov_ref + local ov_prnumber=$4 + local ov_prbranch=$5 + : "${ov_prbranch:=$ov_ref}" + + if [ "$CI_PULL_REQUEST" = "$ov_prnumber" ] || [ "$CI_BRANCH" = "$ov_prbranch" ]; then + if ! is_in_projects "$project"; then + echo "Error: $1 is not a known project which can be overlayed" + exit 1 + fi + + overlays[${project}_URL]=$ov_url + overlays[${project}_REF]=$ov_ref + fi } set +x +# shellcheck source=ci-basic-overlay.sh +. "${ci_dir}/ci-basic-overlay.sh" + for overlay in "${ci_dir}"/user-overlays/*.sh; do # shellcheck source=/dev/null - . "${overlay}" + # the directoy can be empty + if [ -e "${overlay}" ]; then . "${overlay}"; fi done - -# shellcheck source=ci-basic-overlay.sh -. "${ci_dir}/ci-basic-overlay.sh" set -x # [git_download project] will download [project] and unpack it diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 6b09726606..3c8d65f5c1 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -7,6 +7,6 @@ git_download compcert export COQCOPTS='-native-compiler no -w -undeclared-scope -w -omega-is-deprecated' ( cd "${CI_BUILD_DIR}/compcert" && \ - ./configure -ignore-coq-version x86_32-linux && \ + ./configure -ignore-coq-version x86_32-linux -use-external-MenhirLib -use-external-Flocq && \ make && \ make check-proof COQCHK='"$(COQBIN)coqchk" -silent -o $(COQINCLUDES)') diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index ffe92dcecf..777d36a6d7 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download coquelicot -( cd "${CI_BUILD_DIR}/coquelicot" && autoreconf -i -s && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/coquelicot" && ( if [ ! -x ./configure ]; then autoreconf -i -s && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh index 4f185db813..d8caf8ee87 100755 --- a/dev/ci/ci-elpi.sh +++ b/dev/ci/ci-elpi.sh @@ -7,6 +7,6 @@ git_download elpi ( cd "${CI_BUILD_DIR}/elpi" && make && make install ) -git_download elpi_hb +git_download hierarchy_builder -( cd "${CI_BUILD_DIR}/elpi_hb" && make && make install ) +( cd "${CI_BUILD_DIR}/hierarchy_builder" && make && make install ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index a3a704091b..cb6c3e6452 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download flocq -( cd "${CI_BUILD_DIR}/flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) +( cd "${CI_BUILD_DIR}/flocq" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-fourcolor.sh b/dev/ci/ci-fourcolor.sh new file mode 100755 index 0000000000..72a1567398 --- /dev/null +++ b/dev/ci/ci-fourcolor.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download fourcolor + +( cd "${CI_BUILD_DIR}/fourcolor" && make && make install ) diff --git a/dev/ci/ci-gappa.sh b/dev/ci/ci-gappa.sh new file mode 100755 index 0000000000..1af37aa7c1 --- /dev/null +++ b/dev/ci/ci-gappa.sh @@ -0,0 +1,12 @@ + #!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download gappa_tool + +( cd "${CI_BUILD_DIR}/gappa_tool" && ( if [ ! -x ./configure ]; then autoreconf && touch stamp-config_h.in && ./configure --prefix=${CI_INSTALL_DIR}; fi ) && ./remake "-j${NJOBS}" && ./remake install ) + +git_download gappa + +( cd "${CI_BUILD_DIR}/gappa" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-interval.sh b/dev/ci/ci-interval.sh new file mode 100755 index 0000000000..fe7b3f9fbe --- /dev/null +++ b/dev/ci/ci-interval.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download interval + +export COQEXTRAFLAGS='-native-compiler no' +( cd "${CI_BUILD_DIR}/interval" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-mathcomp.sh b/dev/ci/ci-mathcomp.sh index b1aa56ec4e..f170b35327 100755 --- a/dev/ci/ci-mathcomp.sh +++ b/dev/ci/ci-mathcomp.sh @@ -7,11 +7,3 @@ ci_dir="$(dirname "$0")" git_download mathcomp ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && make && make test-suite && make install ) - -git_download fourcolor - -( cd "${CI_BUILD_DIR}/fourcolor" && make && make install ) - -git_download oddorder - -( cd "${CI_BUILD_DIR}/oddorder" && make ) diff --git a/dev/ci/ci-menhir.sh b/dev/ci/ci-menhir.sh new file mode 100755 index 0000000000..5ad78383d8 --- /dev/null +++ b/dev/ci/ci-menhir.sh @@ -0,0 +1,8 @@ +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download menhirlib + +( cd "${CI_BUILD_DIR}/menhirlib" && dune build @install -p menhirLib,menhirSdk,menhir && dune install -p menhirLib,menhirSdk,menhir menhir menhirSdk menhirLib --prefix=${CI_INSTALL_DIR} ) + +( cd "${CI_BUILD_DIR}/menhirlib" && make -C coq-menhirlib && make -C coq-menhirlib install ) diff --git a/dev/ci/ci-oddorder.sh b/dev/ci/ci-oddorder.sh new file mode 100755 index 0000000000..b2da32ad61 --- /dev/null +++ b/dev/ci/ci-oddorder.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download oddorder + +( cd "${CI_BUILD_DIR}/oddorder" && make && make install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index c17ec502e7..1aefebb007 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,5 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-10-12-V89" -# ^^ Update when modifying this file. +# Update CACHEKEY in the .gitlab-ci.yml when modifying this file. FROM ubuntu:bionic LABEL maintainer="e@x80.org" @@ -16,6 +15,8 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ perl libgmp-dev libgmp-dev:i386 \ # Dependencies of lablgtk (for CoqIDE) libgtksourceview-3.0-dev \ + # Dependencies of Gappa + libboost1.65-all-dev libmpfr-dev autoconf-archive bison flex \ # Dependencies of stdlib and sphinx doc texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ python3-pip python3-setuptools python3-pexpect python3-bs4 fonts-freefont-otf \ @@ -42,8 +43,8 @@ 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="menhir.20190626 ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.11.4" + CI_OPAM="ocamlgraph.1.8.8" \ + BASE_ONLY_OPAM="elpi.1.12.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" @@ -62,7 +63,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.11.1" \ - BASE_OPAM_EDGE="dune.2.5.1 dune-release.1.3.3 ocamlformat.0.15.0" + BASE_OPAM_EDGE="dune.2.5.1 dune-release.1.3.3" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh deleted file mode 100644 index d9b49ad0d1..0000000000 --- a/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12218" ] || [ "$CI_BRANCH" = "numeral-notations-non-inductive" ]; then - - stdlib2_CI_REF=numeral-notations-non-inductive - stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 - - hott_CI_REF=numeral-notations-non-inductive - hott_CI_GITURL=https://github.com/proux01/HoTT - - paramcoq_CI_REF=numeral-notations-non-inductive - paramcoq_CI_GITURL=https://github.com/proux01/paramcoq - - quickchick_CI_REF=numeral-notations-non-inductive - quickchick_CI_GITURL=https://github.com/proux01/QuickChick - - metacoq_CI_REF=numeral-notations-non-inductive - metacoq_CI_GITURL=https://github.com/proux01/metacoq - -fi diff --git a/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh b/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh deleted file mode 100644 index fb5947d218..0000000000 --- a/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12449" ] || [ "$CI_BRANCH" = "minim-prop-toset" ]; then - - mtac2_CI_REF=janno/coq-12449 - mtac2_CI_GITURL=https://github.com/mtac2/mtac2 - -fi diff --git a/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh b/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh deleted file mode 100644 index b7d21ed59c..0000000000 --- a/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12611" ] || [ "$CI_BRANCH" = "record+refactor" ]; then - - elpi_CI_REF=record+refactor - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -# mtac2_CI_REF=record+refactor -# mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - -fi diff --git a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh deleted file mode 100644 index 1473f6df8b..0000000000 --- a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12653" ] || [ "$CI_BRANCH" = "cumul-syntax" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi cumul-syntax - - overlay equations https://github.com/SkySkimmer/Coq-Equations cumul-syntax - - overlay mtac2 https://github.com/SkySkimmer/Mtac2 cumul-syntax - - overlay paramcoq https://github.com/SkySkimmer/paramcoq cumul-syntax - - overlay rewriter https://github.com/SkySkimmer/rewriter cumul-syntax - - overlay metacoq https://github.com/SkySkimmer/metacoq cumul-syntax - -fi diff --git a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh deleted file mode 100644 index 7680e8da78..0000000000 --- a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12873" ] || [ "$CI_BRANCH" = "master+minifix-unification-error-reporting-recheck-applications" ]; then - - equations_CI_REF=master+fix12873-better-unification - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh deleted file mode 100644 index 8b223719ea..0000000000 --- a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13075" ] || [ "$CI_BRANCH" = "explicit-names-quotient" ]; then - - elpi_CI_REF=explicit-names-quotient - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - coq_dpdgraph_CI_REF=explicit-names-quotient - coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph - -fi diff --git a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh deleted file mode 100644 index f16cf1497e..0000000000 --- a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance - -fi diff --git a/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh b/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh deleted file mode 100644 index 2f70f43a2b..0000000000 --- a/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13139" ] || [ "$CI_BRANCH" = "clean-hint-constr" ]; then - - equations_CI_REF=clean-hint-constr - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - fiat_parsers_CI_REF=clean-hint-constr - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat - -fi diff --git a/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh b/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh deleted file mode 100644 index 7d55cf6883..0000000000 --- a/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13166" ] || [ "$CI_BRANCH" = "master+fixes13165-missing-impargs-defined-fields" ]; then - - elpi_CI_REF=coq-master+adapt-coq-pr13166-impargs-record-fields - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh b/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh deleted file mode 100644 index 3bdbcf7d6e..0000000000 --- a/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13312" ] || [ "$CI_BRANCH" = "attributes+bool_single" ]; then - - overlay unicoq https://github.com/ejgallego/unicoq attributes+bool_single - overlay elpi https://github.com/ejgallego/coq-elpi attributes+bool_single - -fi diff --git a/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh deleted file mode 100644 index 95f0de2bd3..0000000000 --- a/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13386" ] || [ "$CI_BRANCH" = "master+fix9971-primproj-canonical-structure-on-evar-type" ]; then - - unicoq_CI_REF=master+adapting-coq-pr13386 - unicoq_CI_GITURL=https://github.com/herbelin/unicoq - - elpi_CI_REF=coq-master+adapting-coq-pr13386 - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh b/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh new file mode 100644 index 0000000000..aa686ea619 --- /dev/null +++ b/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "13537" ] || [ "$CI_BRANCH" = "lazy-subst-kernel" ]; then + + overlay mtac2 https://github.com/ppedrot/Mtac2 lazy-subst-kernel + +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 3f9ad5e878..cf1d71c1cd 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -5,30 +5,29 @@ have prepared a branch with the fix, you can add an "overlay" to your pull request to test it with the adapted version of the external project. An overlay is a file which defines where to look for the patched -version so that testing is possible. This is done by calling the -`overlay` command for each project with the project name (as used in -the variables in [`ci-basic-overlay.sh`](../ci-basic-overlay.sh)), the -location of your fork and the branch containing the patch on your -fork. - -Moreover, the file contains very simple logic to test the pull request number -or branch name and apply it only in this case. - +version so that testing is possible. The name of your overlay file should start with a five-digit pull request number, followed by a dash, anything (for instance your GitHub nickname and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). -Example: `13128-SkySkimmer-noinstance.sh` containing - +This file must contain one or more invocation of the `overlay` function: ``` -if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance +overlay <project> <giturl> <ref> <prnumber> [<prbranch>] +``` +Each call creates an overlay for `project` using a given `giturl` and +`ref` which is active for `prnumber` or `prbranch` (`prbranch` defaults +to `ref`). -fi +Example of an overlay for the project `elpi` that uses the branch `noinstance` +from the fork of `SkySkimmer` and is active for pull request `13128` +``` +overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance 13128 ``` -(`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](../ci-common.sh)) +Such a file can be created automatically using the scripts +[`create_overlays.sh`](../../dev/tools/create_overlays.sh). +See also the list of projects for which one can write an overlay in +the file [`ci-basic-overlay.sh`](../ci-basic-overlay.sh). ### Branching conventions diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 5adeafaa38..26c4b01c9f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -37,6 +37,11 @@ Dumpglob: plugins to temporarily change/pause the output of Dumpglob, and then restore it to the original setting. +Glob_term: + +- Removing useless `binding_kind` argument of `GLocalDef` in + `extended_glob_local_binder`. + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 37619833ac..79c2155823 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -312,6 +312,26 @@ Conversion machines risk: none without using -allow-sprop (off by default in 8.10.0), otherwise could be exploited by mistake + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow on large accumulators + introduced: 8.1 + impacted released versions: 8.1-8.12.1 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.0 + found by: Dolan, Roux, Melquiond + GH issue number: ocaml/ocaml#6385, #11170 + risk: medium, as it can happen for large irreducible applications + + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow on large records and closures + introduced: 8.1 + impacted released versions: 8.1-now + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: + found by: Dolan, Roux, Melquiond + GH issue number: ocaml/ocaml#6385, #11170 + risk: unlikely to be activated by chance, might happen for autogenerated code + Side-effects component: side-effects diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index da9f37f666..19562b60a2 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -80,6 +80,9 @@ in time. exists, a branch dedicated to compatibility with the corresponding Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this semi-automatically. + - [ ] Notify upstream authors about the pinning, see + `dev/tools/notify-upstream-pins.sh`. As of today there is no automated + way to track these issues. - [ ] Remove all remaining unmerged feature PRs from the beta milestone. - [ ] Start a new project to track PR backporting. The project should have a "Request X.X+beta1 inclusion" column for the PRs that were @@ -114,15 +117,14 @@ in time. Coq has been tagged. - [ ] Have some people test the recently auto-generated Windows and MacOS packages. -- [ ] In a PR: +- [ ] In a PR against `vX.X` (for testing): - Change the version name from alpha to beta1 (see [#7009](https://github.com/coq/coq/pull/7009/files)). - We generally do not update the magic numbers at this point. - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X+beta1` tag using `git tag -s`. -- [ ] Check using `git push --tags --dry-run` that you are not - pushing anything else than the new tag. If needed, remove spurious - tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Push the new tag with `git push upstream VX.X+beta1 --dry-run` + (remove the `--dry-run` and redo if all looks OK). - [ ] Set `is_a_released_version` to `false` in `configure.ml` (if you forget about it, you'll be reminded whenever you try to backport a PR with a changelog entry). @@ -138,29 +140,28 @@ in time. - [ ] Draft a release on GitHub. - [ ] Sign the Windows and MacOS packages and upload them on GitHub. + The Windows packages must be signed by the Inria IT security service. They - should be sent as a link to the binary together with its SHA256 hash in a - signed e-mail, via our local contact (currently `@maximedenes`). - + The MacOS packages should be signed by our own certificate, by sending them - to `@maximedenes`. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). + should be sent as a link to the binary (via [filesender](https://filesender.renater.fr) for example) + together with its SHA256 hash in a signed e-mail to `dsi.securite` @ `inria.fr` + putting `@maximedenes` in carbon copy. + + The MacOS packages should be signed with our own certificate. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). - [ ] Prepare a page of news on the website with the link to the GitHub release (see [coq/www#63](https://github.com/coq/www/pull/63)). -- [ ] Upload the new version of the reference manual to the website. - *TODO: setup some continuous deployment for this.* - [ ] Merge the website update, publish the release - and send announcement e-mails. + and send announcement e-mails, typically on + the `coq-club@inria.fr` mailing list and the discourse forum + ([posting by mail](https://github.com/coq/coq/wiki/Discourse)) - [ ] Close the milestone ## At the final release time ## - [ ] Prepare the release notes (see above) -- [ ] In a PR: +- [ ] In a PR against `vX.X` (for testing): - Change the version name from X.X.0 and the magic numbers (see [#7271](https://github.com/coq/coq/pull/7271/files)). - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X.0` tag. -- [ ] Check using `git push --tags --dry-run` that you are not - pushing anything else than the new tag. If needed, remove spurious - tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Push the new tag with `git push upstream VX.X.0 --dry-run` + (remove the `--dry-run` and redo if all looks OK). - [ ] Set `is_a_released_version` to `false` in `configure.ml` (if you forget about it, you'll be reminded whenever you try to backport a PR with a changelog entry). @@ -170,7 +171,19 @@ Repeat the generic process documented above for all releases. Ping `@Zimmi48` to: - [ ] Switch the default version of the reference manual on the website. -- [ ] Publish a new version on Zenodo. + + This is done by logging into the server (`vps697916.ovh.net`), + editing two `ProxyPass` lines (one for the refman and one for the + stdlib doc) with `sudo vim /etc/apache2/sites-available/000-coq.inria.fr.conf`, + then running `sudo systemctl reload apache2`. + + *TODO:* automate this or make it doable through the `www` git + repository. See [coq/www#111](https://github.com/coq/www/issues/111) + and [coq/www#131](https://github.com/coq/www/issues/131). + +- [ ] Publish a new version on Zenodo (only once per major version). + + *TODO:* automate this with coqbot. ## At the patch-level release time ## diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 2e8a7455de..0bad2f4c62 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -9,10 +9,10 @@ CODE=0 -if [[ $(git log -n 1 --pretty='format:%s') == "Bot merge"* ]]; then - # The FIRST parent of bot merges is from the PR, the second is +if [[ $(git log -n 1 --pretty='format:%s') == "[CI merge]"* ]]; then + # The second parent of bot merges is from the PR, the first is # current master - head=$(git rev-parse HEAD~) + head=$(git rev-parse HEAD^2) else head=$(git rev-parse HEAD) fi @@ -32,4 +32,7 @@ find . "(" -path ./.git -prune ")" -o -type f -print0 | echo Checking overlays dev/tools/check-overlays.sh || CODE=1 +echo Checking CACHEKEY +dev/tools/check-cachekey.sh || CODE=1 + exit $CODE diff --git a/dev/shim/dune b/dev/shim/dune index 84b2e642e8..8006c629ed 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -7,7 +7,7 @@ (with-stdout-to coqtop-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \\$@") + (bash "echo '$(dirname $0)/%{bin:coqtop} -coqlib $(dirname $0)/%{project_root}' \\$@") (run chmod +x %{targets}))))) (rule @@ -19,7 +19,7 @@ (with-stdout-to coqc-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqc} -coqlib $(pwd)/%{project_root}\" \\$@") + (bash "echo '$(dirname $0)/%{bin:coqc} -coqlib $(dirname $0)/%{project_root}' \\$@") (run chmod +x %{targets}))))) (rule @@ -32,7 +32,7 @@ (with-stdout-to %{targets} (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \\$@") + (bash "echo '$(dirname $0)/%{bin:coqtop.byte} -coqlib $(dirname $0)/%{project_root}' \\$@") (run chmod +x %{targets}))))) (rule @@ -48,5 +48,5 @@ (with-stdout-to coqide-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \\$@") + (bash "echo '$(dirname $0)/%{bin:coqide} -coqlib $(dirname $0)/%{project_root}' \\$@") (run chmod +x %{targets}))))) diff --git a/dev/tools/check-cachekey.sh b/dev/tools/check-cachekey.sh new file mode 100755 index 0000000000..15e3fa93cb --- /dev/null +++ b/dev/tools/check-cachekey.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +hash=$(md5sum dev/ci/docker/bionic_coq/Dockerfile | head -c 10) +key=$(grep CACHEKEY: .gitlab-ci.yml) +keyhash=${key%\"} +keyhash=${keyhash##*-} +if ! [ "$hash" = "$keyhash" ]; then + echo "Bad CACHEKEY: expected '$hash' but got '$keyhash'" + exit 1 +fi diff --git a/dev/tools/create_overlays.sh b/dev/tools/create_overlays.sh index 78ed27ba03..ac8fd1676d 100755 --- a/dev/tools/create_overlays.sh +++ b/dev/tools/create_overlays.sh @@ -42,7 +42,7 @@ OVERLAY_BRANCH=$(git rev-parse --abbrev-ref HEAD) OVERLAY_FILE=$(mktemp overlay-XXXX) # Create the overlay file -printf 'if [ "$CI_PULL_REQUEST" = "%s" ] || [ "$CI_BRANCH" = "%s" ]; then\n\n' "$PR_NUMBER" "$OVERLAY_BRANCH" > "$OVERLAY_FILE" +> "$OVERLAY_FILE" # We first try to build the contribs while test $# -gt 0 @@ -66,12 +66,11 @@ do make ci-$_CONTRIB_NAME || true setup_contrib_git $_CONTRIB_DIR $_CONTRIB_GITPUSHURL - echo " overlay ${_CONTRIB_NAME} $_CONTRIB_GITURL $OVERLAY_BRANCH" >> $OVERLAY_FILE + echo "overlay ${_CONTRIB_NAME} $_CONTRIB_GITURL $OVERLAY_BRANCH $PR_NUMBER" >> $OVERLAY_FILE echo "" >> $OVERLAY_FILE shift done -# End the file; copy to overlays folder. -echo "fi" >> $OVERLAY_FILE +# Copy to overlays folder. PR_NUMBER=$(printf '%05d' "$PR_NUMBER") mv $OVERLAY_FILE dev/ci/user-overlays/$PR_NUMBER-$DEVELOPER_NAME-${OVERLAY_BRANCH///}.sh diff --git a/dev/tools/notify-upstream-pins.sh b/dev/tools/notify-upstream-pins.sh new file mode 100755 index 0000000000..ebf920b0f7 --- /dev/null +++ b/dev/tools/notify-upstream-pins.sh @@ -0,0 +1,101 @@ + +#!/usr/bin/env bash + +# Script to notify upstreams that we need a tag to put in a platform/installer + +VERSION="8.13" +DATEBETA="December 7, 2020" +DATEFINAL="January 7, 2020" +CC="CC: https://github.com/coq/coq/issues/12334" +#CC="\n@coqbot column:...." +REASON="bundled in the Windows installer" +#REASON="bundled in the Coq platform" + +git show master:dev/ci/ci-basic-overlay.sh > /tmp/master-ci-basic-overlay.sh +git show v${VERSION}:dev/ci/ci-basic-overlay.sh > /tmp/branch-ci-basic-overlay.sh + +# reads a variable value from a ci-basic-overlay.sh file +function read_from() { + ( . $1; varname="$2"; echo ${!varname} ) +} + +# https://gist.github.com/cdown/1163649 +function urlencode() { + # urlencode <string> + + old_lc_collate=$LC_COLLATE + LC_COLLATE=C + + local length="${#1}" + for (( i = 0; i < length; i++ )); do + local c="${1:$i:1}" + case $c in + [a-zA-Z0-9.~_-]) printf '%s' "$c" ;; + *) printf '%%%02X' "'$c" ;; + esac + done + + LC_COLLATE=$old_lc_collate +} + +function template { + TITLE="Please create a tag for the upcoming release of Coq $VERSION" + BODY="The Coq team is planning to release Coq $VERSION-beta1 on $DATEBETA, +and Coq $VERSION.0 on $DATEFINAL. + +Your project is currently scheduled for being $REASON. + +We are currently testing commit $3 +on branch $1/tree/$2 +but we would like to ship a released version instead (a tag in git's slang). + +Could you please tag that commit, or communicate us any other tag +that works with the Coq branch v$VERSION at the *latest* 15 days before the +date of the final release? + +Thanks! +$CC +" + UUTITLE=$(urlencode "$TITLE") + UUBODY=$(urlencode "$BODY") + + case $1 in + ( http*github.com* ) + echo "$1/issues/new?title=$UUTITLE&body=$UUBODY" + ;; + ( http*gitlab* ) + echo "$1/-/issues/new" + echo + echo -e "$TITLE" + echo + echo -e "$BODY" + ;; + ( * ) + echo "$1" + echo + echo -e "$TITLE" + echo + echo -e "$BODY" + + ;; + esac +} + +# TODO: filter w.r.t. what is in the platform +PROJECTS=`read_from /tmp/branch-ci-basic-overlay.sh "projects[@]"` + +for addon in $PROJECTS; do + URL=`read_from /tmp/master-ci-basic-overlay.sh "${addon}_CI_GITURL"` + REF=`read_from /tmp/master-ci-basic-overlay.sh "${addon}_CI_REF"` + PIN=`read_from /tmp/branch-ci-basic-overlay.sh "${addon}_CI_REF"` + if [ "${#PIN}" = "40" ]; then + echo -e "Addon $addon is pinned to a hash, to open an issue open the following url:\n" + template $URL $REF $PIN + elif [ "${#PIN}" = "0" ]; then + echo "Addon $addon has no pin!" + exit 1 + else + echo "Addon $addon is already pinned to version $PIN" + fi + echo -e "\n----------------------------------------------" +done diff --git a/dev/tools/pin-ci.sh b/dev/tools/pin-ci.sh index dbf54d7f0a..676688bedc 100755 --- a/dev/tools/pin-ci.sh +++ b/dev/tools/pin-ci.sh @@ -38,9 +38,7 @@ process_development() { # Execute the script to set the overlay variables . $OVERLAYS -# Find all variables declared in the base overlay of the form *_CI_GITURL -for REPO_VAR in $(compgen -A variable | grep _CI_GITURL) +for project in ${projects[@]} do - DEV=${REPO_VAR%_CI_GITURL} - process_development $DEV + process_development $project done diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index 21d6fbe9aa..bfc186c862 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -46,6 +46,7 @@ install_printer Top_printers.pp_idpred install_printer Top_printers.pp_cpred install_printer Top_printers.pp_transparent_state install_printer Top_printers.pp_stack_t +install_printer Top_printers.pp_estack_t install_printer Top_printers.pp_state_t install_printer Top_printers.ppmetas install_printer Top_printers.ppevm diff --git a/dev/top_printers.ml b/dev/top_printers.ml index e4dd7ef52c..4faa12af79 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -27,6 +27,11 @@ let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true let _ = Goptions.set_bool_option_value ["Printing";"Matching"] false +let with_env_evm f x = + let env = Global.env() in + let sigma = Evd.from_env env in + f env sigma x + (* std_ppcmds *) let pp x = Pp.pp_with !Topfmt.std_ft x @@ -75,7 +80,7 @@ let ppeconstr x = pp (pr_econstr x) let ppconstr_expr x = let sigma,env = get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x -let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) +let ppglob_constr = (fun x -> pp(with_env_evm pr_lglob_constr_env x)) let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) let pptype = (fun x -> try pp(envpp (fun env evm t -> pr_ltype_env env evm t) x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) @@ -130,7 +135,7 @@ let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = and pr_closed_glob_constr_idmap x = pridmap (fun _ -> pr_closed_glob_constr) x and pr_closed_glob_constr {closure=closure;term=term} = - pr_closure closure ++ (pr_lglob_constr_env Global.(env ())) term + pr_closure closure ++ with_env_evm pr_lglob_constr_env term let ppclosure x = pp (pr_closure x) let ppclosedglobconstr x = pp (pr_closed_glob_constr x) @@ -165,6 +170,7 @@ let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) let pp_transparent_state s = pp (pr_transparent_state s) let pp_stack_t n = pp (Reductionops.Stack.pr (EConstr.of_constr %> pr_econstr) n) +let pp_estack_t n = pp (Reductionops.Stack.pr pr_econstr n) let pp_state_t n = pp (Reductionops.pr_state Global.(env()) Evd.empty n) (* proof printers *) @@ -211,7 +217,7 @@ let pproof p = pp(Proof.pr_proof p) let ppuni u = pp(Universe.pr u) let ppuni_level u = pp (Level.pr u) -let prlev = UnivNames.pr_with_global_universes +let prlev = UnivNames.pr_with_global_universes Id.Map.empty let ppuniverse_set l = pp (LSet.pr prlev l) let ppuniverse_instance l = pp (Instance.pr prlev l) let ppuniverse_context l = pp (pr_universe_context prlev l) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 712f66112c..50495dc0a4 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -108,6 +108,7 @@ val pp_cpred : Names.Cpred.t -> unit val pp_transparent_state : TransparentState.t -> unit val pp_stack_t : Constr.t Reductionops.Stack.t -> unit +val pp_estack_t : EConstr.t Reductionops.Stack.t -> unit val pp_state_t : Reductionops.state -> unit val ppmetas : Evd.Metaset.t -> unit diff --git a/doc/changelog/01-kernel/00000-title.rst b/doc/changelog/01-kernel/00000-title.rst index f680628a05..287382eab0 100644 --- a/doc/changelog/01-kernel/00000-title.rst +++ b/doc/changelog/01-kernel/00000-title.rst @@ -1,3 +1,4 @@ -**Kernel** +Kernel +^^^^^^ diff --git a/doc/changelog/01-kernel/10390-uip.rst b/doc/changelog/01-kernel/10390-uip.rst deleted file mode 100644 index dab096d8db..0000000000 --- a/doc/changelog/01-kernel/10390-uip.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Definitional UIP, only when :flag:`Definitional UIP` is enabled. See - documentation of the flag for details. - (`#10390 <https://github.com/coq/coq/pull/10390>`_, - by Gaëtan Gilbert). diff --git a/doc/changelog/01-kernel/11604-persistent-arrays.rst b/doc/changelog/01-kernel/11604-persistent-arrays.rst deleted file mode 100644 index fbade033d2..0000000000 --- a/doc/changelog/01-kernel/11604-persistent-arrays.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - Built-in support for persistent arrays, which expose a functional - interface but are implemented using an imperative data structure, for - better performance. - (`#11604 <https://github.com/coq/coq/pull/11604>`_, - by Maxime Dénès and Benjamin Grégoire, with help from Gaëtan Gilbert). diff --git a/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst b/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst deleted file mode 100644 index bec121836c..0000000000 --- a/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Fixed:** - A loss of definitional equality for declarations obtained through - :cmd:`Include` when entering the scope of a :cmd:`Module` or - :cmd:`Module Type` was causing :cmd:`Search` not to see the included - declarations - (`#12537 <https://github.com/coq/coq/pull/12537>`_, fixes `#12525 - <https://github.com/coq/coq/pull/12525>`_ and `#12647 - <https://github.com/coq/coq/pull/12647>`_, by Hugo Herbelin). diff --git a/doc/changelog/01-kernel/13356-primarray-cumul.rst b/doc/changelog/01-kernel/13356-primarray-cumul.rst deleted file mode 100644 index 978ca325bf..0000000000 --- a/doc/changelog/01-kernel/13356-primarray-cumul.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** Primitive arrays are now irrelevant in their single - polymorphic universe (same as a polymorphic cumulative list - inductive would be) (`#13356 - <https://github.com/coq/coq/pull/13356>`_, fixes `#13354 - <https://github.com/coq/coq/issues/13354>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/00000-title.rst b/doc/changelog/02-specification-language/00000-title.rst index 99bd2c5b44..2d3e49a69d 100644 --- a/doc/changelog/02-specification-language/00000-title.rst +++ b/doc/changelog/02-specification-language/00000-title.rst @@ -1,3 +1,4 @@ -**Specification language, type inference** +Specification language, type inference +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/doc/changelog/02-specification-language/07825-rechable-from-evars.rst b/doc/changelog/02-specification-language/07825-rechable-from-evars.rst deleted file mode 100644 index e57d5a7bc5..0000000000 --- a/doc/changelog/02-specification-language/07825-rechable-from-evars.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Changed:** - In :tacn:`refine`, new existential variables unified with existing ones are no - longer considered as fresh. The behavior of :tacn:`simple refine` no longer depends on - the orientation of evar-evar unification problems, and new existential variables - are always turned into (unshelved) goals. This can break compatibility in - some cases (`#7825 <https://github.com/coq/coq/pull/7825>`_, by Matthieu - Sozeau, with help from Maxime Dénès, review by Pierre-Marie Pédrot and - Enrico Tassi, fixes `#4095 <https://github.com/coq/coq/issues/4095>`_ and - `#4413 <https://github.com/coq/coq/issues/4413>`_). diff --git a/doc/changelog/02-specification-language/10331-minim-prop-toset.rst b/doc/changelog/02-specification-language/10331-minim-prop-toset.rst deleted file mode 100644 index 6c442ca1aa..0000000000 --- a/doc/changelog/02-specification-language/10331-minim-prop-toset.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** Heuristics for universe minimization to :g:`Set`: also - use constraints ``Prop <= i`` (`#10331 - <https://github.com/coq/coq/pull/10331>`_, by Gaëtan Gilbert with - help from Maxime Dénès and Matthieu Sozeau, fixes `#12414 - <https://github.com/coq/coq/issues/12414>`_). diff --git a/doc/changelog/02-specification-language/12653-cumul-syntax.rst b/doc/changelog/02-specification-language/12653-cumul-syntax.rst deleted file mode 100644 index ba97f7c796..0000000000 --- a/doc/changelog/02-specification-language/12653-cumul-syntax.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** Commands :cmd:`Inductive`, :cmd:`Record` and synonyms now - support syntax `Inductive foo@{=i +j *k l}` to specify variance - information for their universes (in :ref:`Cumulative <cumulative>` - mode) (`#12653 <https://github.com/coq/coq/pull/12653>`_, by Gaëtan - Gilbert). diff --git a/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst b/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst deleted file mode 100644 index b0cf4ca4e3..0000000000 --- a/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Changed:** - Tweaked the algorithm giving default names to arguments. - Should reduce the frequency that argument names get an - unexpected suffix. - Also makes :flag:`Mangle Names` not mess up argument names. - (`#12756 <https://github.com/coq/coq/pull/12756>`_, - fixes `#12001 <https://github.com/coq/coq/issues/12001>`_ - and `#6785 <https://github.com/coq/coq/issues/6785>`_, - by Jasper Hugunin). diff --git a/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst b/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst deleted file mode 100644 index c9e941743c..0000000000 --- a/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Added:** - Warning on unused variables in pattern-matching branches of - :n:`match` serving as catch-all branches for at least two distinct - patterns. - (`#12768 <https://github.com/coq/coq/pull/12768>`_, - fixes `#12762 <https://github.com/coq/coq/issues/12762>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst b/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst deleted file mode 100644 index 7fe69c39c1..0000000000 --- a/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Removed:** - Undocumented and experimental forward class hint feature ``:>>``. - Use ``:>`` (see :n:`@of_type`) instead - (`#13106 <https://github.com/coq/coq/pull/13106>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/02-specification-language/13166-master+fixes13165-missing-impargs-defined-fields.rst b/doc/changelog/02-specification-language/13166-master+fixes13165-missing-impargs-defined-fields.rst deleted file mode 100644 index 006989e6b3..0000000000 --- a/doc/changelog/02-specification-language/13166-master+fixes13165-missing-impargs-defined-fields.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Implicit arguments taken into account in defined fields of a record type declaration - (`#13166 <https://github.com/coq/coq/pull/13166>`_, - fixes `#13165 <https://github.com/coq/coq/issues/13165>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13183-using-att.rst b/doc/changelog/02-specification-language/13183-using-att.rst deleted file mode 100644 index c380d932ed..0000000000 --- a/doc/changelog/02-specification-language/13183-using-att.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - Definition and (Co)Fixpoint now support the :attr:`using` attribute. - It has the same effect as :cmd:`Proof using`, which is only available in - interactive mode. - (`#13183 <https://github.com/coq/coq/pull/13183>`_, - by Enrico Tassi). diff --git a/doc/changelog/02-specification-language/13188-instance-gen.rst b/doc/changelog/02-specification-language/13188-instance-gen.rst deleted file mode 100644 index 6a431f85ed..0000000000 --- a/doc/changelog/02-specification-language/13188-instance-gen.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Removed:** The type given to :cmd:`Instance` is no longer automatically - generalized over unbound and :ref:`generalizable <implicit-generalization>` variables. - Use :n:`Instance : \`{@type}` instead of :n:`Instance : @type` to get the old behaviour, or - enable the compatibility flag :flag:`Instance Generalized Output`. - (`#13188 <https://github.com/coq/coq/pull/13188>`_, fixes `#6042 - <https://github.com/coq/coq/issues/6042>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/13217-master+fix13216-typeclass-for-match-return-clause.rst b/doc/changelog/02-specification-language/13217-master+fix13216-typeclass-for-match-return-clause.rst deleted file mode 100644 index 2d8230b965..0000000000 --- a/doc/changelog/02-specification-language/13217-master+fix13216-typeclass-for-match-return-clause.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Allow use of type classes inference for the return predicate of a :n:`match` - (was deactivated in versions 8.10 to 8.12, `#13217 <https://github.com/coq/coq/pull/13217>`_, - fixes `#13216 <https://github.com/coq/coq/issues/13216>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst b/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst deleted file mode 100644 index bf792fda6d..0000000000 --- a/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - Inference of return predicate of a :g:`match` by inversion takes - sort elimination constraints into account - (`#13290 <https://github.com/coq/coq/pull/13290>`_, - grants `#13278 <https://github.com/coq/coq/issues/13278>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13312-attributes+bool_single.rst b/doc/changelog/02-specification-language/13312-attributes+bool_single.rst deleted file mode 100644 index f069bc616b..0000000000 --- a/doc/changelog/02-specification-language/13312-attributes+bool_single.rst +++ /dev/null @@ -1,17 +0,0 @@ -- **Changed:** - :term:`Boolean attributes <boolean attribute>` are now specified using - key/value pairs, that is to say :n:`@ident__attr{? = {| yes | no } }`. - If the value is missing, the default is :n:`yes`. The old syntax is still - supported, but produces the ``deprecated-attribute-syntax`` warning. - - Deprecated attributes are :attr:`universes(monomorphic)`, - :attr:`universes(notemplate)` and :attr:`universes(noncumulative)`, which are - respectively replaced by :attr:`universes(polymorphic=no) <universes(polymorphic)>`, - :attr:`universes(template=no) <universes(template)>` - and :attr:`universes(cumulative=no) <universes(cumulative)>`. - Attributes :attr:`program` and :attr:`canonical` are also affected, - with the syntax :n:`@ident__attr(false)` being deprecated in favor of - :n:`@ident__attr=no`. - - (`#13312 <https://github.com/coq/coq/pull/13312>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst b/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst deleted file mode 100644 index 5758f35c3d..0000000000 --- a/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - A case of unification raising an anomaly IllTypedInstance - (`#13376 <https://github.com/coq/coq/pull/13376>`_, - fixes `#13266 <https://github.com/coq/coq/issues/13266>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst b/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst deleted file mode 100644 index c0e5a81641..0000000000 --- a/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Using :n:`{wf ...}` in local fixpoints is an error, not an anomaly - (`#13383 <https://github.com/coq/coq/pull/13383>`_, - fixes `#11816 <https://github.com/coq/coq/issues/11816>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst b/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst deleted file mode 100644 index 4bd214d7be..0000000000 --- a/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - issue when two expressions involving different projections and one is - primitive need to be unified - (`#13386 <https://github.com/coq/coq/pull/13386>`_, - fixes `#9971 <https://github.com/coq/coq/issues/9971>`_, - by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst b/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst deleted file mode 100644 index eaf049dc97..0000000000 --- a/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - A bug producing ill-typed instances of existential variables when let-ins - interleaved with assumptions - (`#13387 <https://github.com/coq/coq/pull/13387>`_, - fixes `#12348 <https://github.com/coq/coq/issues/13387>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/00000-title.rst b/doc/changelog/03-notations/00000-title.rst index abc532df11..0780bf9468 100644 --- a/doc/changelog/03-notations/00000-title.rst +++ b/doc/changelog/03-notations/00000-title.rst @@ -1,3 +1,4 @@ -**Notations** +Notations +^^^^^^^^^ diff --git a/doc/changelog/03-notations/11986-float-low-level-printing.rst b/doc/changelog/03-notations/11986-float-low-level-printing.rst deleted file mode 100644 index aba74891c6..0000000000 --- a/doc/changelog/03-notations/11986-float-low-level-printing.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - :flag:`Printing Float` flag to print primitive floats as hexadecimal - instead of decimal values. This is included in the :flag:`Printing All` flag - (`#11986 <https://github.com/coq/coq/pull/11986>`_, - by Pierre Roux). diff --git a/doc/changelog/03-notations/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst b/doc/changelog/03-notations/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst deleted file mode 100644 index e9b02aed6d..0000000000 --- a/doc/changelog/03-notations/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - Improved support for notations/abbreviations with mixed terms and patterns (such as the forcing modality) - (`#12099 <https://github.com/coq/coq/pull/12099>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst b/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst deleted file mode 100644 index 5ea37e7494..0000000000 --- a/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst +++ /dev/null @@ -1,19 +0,0 @@ -- **Deprecated** - ``Numeral.v`` is deprecated, please use ``Number.v`` instead. -- **Changed** - Rational and real constants are parsed differently. - The exponent is now encoded separately from the fractional part - using ``Z.pow_pos``. This way, parsing large exponents can no longer - blow up and constants are printed in a form closer to the one they - were parsed (i.e., ``102e-2`` is reprinted as such and not ``1.02``). -- **Removed** - OCaml parser and printer for real constants have been removed. - Real constants are now handled with proven Coq code. -- **Added:** - :ref:`Number Notation <number-notations>` and :ref:`String Notation - <string-notations>` commands now - support parameterized inductive and non inductive types - (`#12218 <https://github.com/coq/coq/pull/12218>`_, - fixes `#12035 <https://github.com/coq/coq/issues/12035>`_, - by Pierre Roux, review by Jason Gross and Jim Fehrle for the - reference manual). diff --git a/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst b/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst deleted file mode 100644 index 048835a0e9..0000000000 --- a/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - Scope information is propagated in indirect applications to a - reference prefixed with :g:`@@`; this covers for instance the case - :g:`r.(@@p) t` where scope information from :g:`p` is now taken into - account for interpreting :g:`t` (`#12685 - <https://github.com/coq/coq/pull/12685>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst b/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst deleted file mode 100644 index 82cbefc60b..0000000000 --- a/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - Added support for encoding notations of the form :g:`x ⪯ y ⪯ .. ⪯ z ⪯ t` - (`#12765 <https://github.com/coq/coq/pull/12765>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst b/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst deleted file mode 100644 index 16fc91f911..0000000000 --- a/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst +++ /dev/null @@ -1,10 +0,0 @@ -- **Changed:** - New model for ``only parsing`` and ``only printing`` notations with - support for at most one parsing-and-printing or only-parsing - notation per notation and scope, but an arbitrary number of - only-printing notations - (`#12950 <https://github.com/coq/coq/pull/12950>`_, - fixes `#4738 <https://github.com/coq/coq/issues/4738>`_ - and `#9682 <https://github.com/coq/coq/issues/9682>`_ - and part 2 of `#12908 <https://github.com/coq/coq/issues/12908>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst b/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst deleted file mode 100644 index fc909e7a1d..0000000000 --- a/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Fixed:** - Issues in the presence of notations recursively referring to another - applicative notations, such as missing scope propagation, or failure - to use a notation for printing - (`#12960 <https://github.com/coq/coq/pull/12960>`_, - fixes `#9403 <https://github.com/coq/coq/issues/9403>`_ - and `#10803 <https://github.com/coq/coq/issues/10803>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12965-master+fix9569-propagage-binding-vars-notations.rst b/doc/changelog/03-notations/12965-master+fix9569-propagage-binding-vars-notations.rst deleted file mode 100644 index e63ab9696e..0000000000 --- a/doc/changelog/03-notations/12965-master+fix9569-propagage-binding-vars-notations.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Capture of the name of global references by - binders in the presence of notations for binders - (`#12965 <https://github.com/coq/coq/pull/12965>`_, - fixes `#9569 <https://github.com/coq/coq/issues/9569>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12979-doc-numbers.rst b/doc/changelog/03-notations/12979-doc-numbers.rst deleted file mode 100644 index 631bd6ec69..0000000000 --- a/doc/changelog/03-notations/12979-doc-numbers.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Deprecated:** - :n:`Numeral Notation`, please use :ref:`Number Notation <number-notations>` instead. - (`#12979 <https://github.com/coq/coq/pull/12979>`_, - by Pierre Roux). diff --git a/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst b/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst deleted file mode 100644 index d472e6fdf0..0000000000 --- a/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst +++ /dev/null @@ -1,12 +0,0 @@ -- **Changed:** - Redeclaring a notation reactivates also its printing rule; in - particular a second :cmd:`Import` of the same module reactivates the - printing rules declared in this module. In theory, this leads to - changes of behavior for printing. However, this is mitigated in - general by the adoption in `#12986 - <https://github.com/coq/coq/pull/12986>`_ of a priority given to - notations which match a larger part of the term to print - (`#12984 <https://github.com/coq/coq/pull/12984>`_, - fixes `#7443 <https://github.com/coq/coq/issues/7443>`_ - and `#10824 <https://github.com/coq/coq/issues/10824>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst b/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst deleted file mode 100644 index 8b233972bf..0000000000 --- a/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - Use of notations for printing now gives preference - to notations which match a larger part of the term to abbreviate - (`#12986 <https://github.com/coq/coq/pull/12986>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst b/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst deleted file mode 100644 index fb12c91729..0000000000 --- a/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Preventing notations for constructors to involve binders - (`#13092 <https://github.com/coq/coq/pull/13092>`_, - fixes `#13078 <https://github.com/coq/coq/issues/13078>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst b/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst deleted file mode 100644 index c973e157dd..0000000000 --- a/doc/changelog/03-notations/13265-master+allow-single-binder-entry.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - The :n:`@binder` entry of :cmd:`Notation` can now be used in - notations expecting a single (non-recursive) binder - (`#13265 <https://github.com/coq/coq/pull/13265>`_, - by Hugo Herbelin, see section :n:`notations-and-binders` of the - reference manual). diff --git a/doc/changelog/03-notations/13519-primitiveArrayNotations.rst b/doc/changelog/03-notations/13519-primitiveArrayNotations.rst new file mode 100644 index 0000000000..fb2545652c --- /dev/null +++ b/doc/changelog/03-notations/13519-primitiveArrayNotations.rst @@ -0,0 +1,8 @@ +- **Added:** + :cmd:`Number Notation` and :cmd:`String Notation` now support + parsing and printing of primitive floats, primitive arrays + and type constants of primitive types. + (`#13519 <https://github.com/coq/coq/pull/13519>`_, + fixes `#13484 <https://github.com/coq/coq/issues/13484>`_ + and `#13517 <https://github.com/coq/coq/issues/13517>`_, + by Fabian Kunze, with help of Jason Gross) diff --git a/doc/changelog/04-tactics/00000-title.rst b/doc/changelog/04-tactics/00000-title.rst index 3c7802d632..afa7821f40 100644 --- a/doc/changelog/04-tactics/00000-title.rst +++ b/doc/changelog/04-tactics/00000-title.rst @@ -1,3 +1,4 @@ -**Tactics** +Tactics +^^^^^^^ diff --git a/doc/changelog/04-tactics/11906-micromega-booleans.rst b/doc/changelog/04-tactics/11906-micromega-booleans.rst deleted file mode 100644 index 39d1525ac3..0000000000 --- a/doc/changelog/04-tactics/11906-micromega-booleans.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - :tacn:`lia` is extended to deal with boolean operators e.g. `andb` or `Z.leb`. - (As `lia` gets more powerful, this may break proof scripts relying on `lia` failure.) - (`#11906 <https://github.com/coq/coq/pull/11906>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/12399-rm-prolog.rst b/doc/changelog/04-tactics/12399-rm-prolog.rst deleted file mode 100644 index afde7db370..0000000000 --- a/doc/changelog/04-tactics/12399-rm-prolog.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Removed:** - The deprecated and undocumented "prolog" tactic was removed - (`#12399 <https://github.com/coq/coq/pull/12399>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/12423-rm-info.rst b/doc/changelog/04-tactics/12423-rm-info.rst deleted file mode 100644 index bf20453e6b..0000000000 --- a/doc/changelog/04-tactics/12423-rm-info.rst +++ /dev/null @@ -1,2 +0,0 @@ -- **Removed:** Removed info tactic that was deprecated in 8.5. - (`#12423 <https://github.com/coq/coq/pull/12423>`_, by Jim Fehrle). diff --git a/doc/changelog/04-tactics/12552-zify-pre-hook.rst b/doc/changelog/04-tactics/12552-zify-pre-hook.rst deleted file mode 100644 index 975c917b19..0000000000 --- a/doc/changelog/04-tactics/12552-zify-pre-hook.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - Thhe :tacn:`zify` tactic can now be extended by redefining the `zify_pre_hook` - tactic. (`#12552 <https://github.com/coq/coq/pull/12552>`_, - by Kazuhiko Sakaguchi). diff --git a/doc/changelog/04-tactics/12648-zify-int63.rst b/doc/changelog/04-tactics/12648-zify-int63.rst deleted file mode 100644 index ec7a1273e4..0000000000 --- a/doc/changelog/04-tactics/12648-zify-int63.rst +++ /dev/null @@ -1,3 +0,0 @@ -- **Added:** - The :tacn:`zify` tactic provides support for primitive integers (module :g:`ZifyInt63`). - (`#12648 <https://github.com/coq/coq/pull/12648>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/12993-remove-cutrewrite.rst b/doc/changelog/04-tactics/12993-remove-cutrewrite.rst deleted file mode 100644 index b719c5618e..0000000000 --- a/doc/changelog/04-tactics/12993-remove-cutrewrite.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Removed:** - Deprecated ``cutrewrite`` tactic. Use :tacn:`replace` instead - (`#12993 <https://github.com/coq/coq/pull/12993>`_, - by Théo Zimmermann). diff --git a/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst b/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst deleted file mode 100644 index bc67fd025a..0000000000 --- a/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - Giving an empty list of occurrences after :n:`in` in tactics is no - longer permitted. Omitting the :n:`in` gives the same behavior - (`#13237 <https://github.com/coq/coq/pull/13236>`_, - fixes `#13235 <https://github.com/coq/coq/issues/13235>`_, - by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst b/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst deleted file mode 100644 index 089647a4b2..0000000000 --- a/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Avoiding exposing an internal name of the form :n:`_tmp` when applying the - :n:`_` introduction pattern would break a dependency - (`#13337 <https://github.com/coq/coq/pull/13337>`_, - fixes `#13336 <https://github.com/coq/coq/issues/13336>`_, - by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst b/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst deleted file mode 100644 index c02129a33f..0000000000 --- a/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - The case of tactics, such as :tacn:`eapply`, producing existential variables - under binders with an ill-formed instance - (`#13373 <https://github.com/coq/coq/pull/13373>`_, - fixes `#13363 <https://github.com/coq/coq/issues/13363>`_, - by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13381-bfs_eauto.rst b/doc/changelog/04-tactics/13381-bfs_eauto.rst deleted file mode 100644 index f37fbfe52b..0000000000 --- a/doc/changelog/04-tactics/13381-bfs_eauto.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Deprecated:** - Undocumented :n:`eauto @int_or_var @int_or_var` syntax in favor of new ``bfs eauto``. - Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``. - (Use ``bfs eauto`` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) - (`#13381 <https://github.com/coq/coq/pull/13381>`_, - by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13403-occs_nums_nat.rst b/doc/changelog/04-tactics/13403-occs_nums_nat.rst deleted file mode 100644 index 5dfa90a267..0000000000 --- a/doc/changelog/04-tactics/13403-occs_nums_nat.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Removed:** - :n:`at @occs_nums` clauses in tactics such as tacn:`unfold` - no longer allow negative values. A "-" before the - list (for set complement) is still supported. Ex: "at -1 -2" - is no longer supported but "at -1 2" is. - (`#13403 <https://github.com/coq/coq/pull/13403>`_, - by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13509-master+remove-bracketing-last-introduction-pattern-flag.rst b/doc/changelog/04-tactics/13509-master+remove-bracketing-last-introduction-pattern-flag.rst new file mode 100644 index 0000000000..06c1e280c3 --- /dev/null +++ b/doc/changelog/04-tactics/13509-master+remove-bracketing-last-introduction-pattern-flag.rst @@ -0,0 +1,6 @@ +- **Removed:** + Deprecated flag ``Bracketing Last Introduction Pattern`` affecting the + behavior of trailing disjunctive introduction patterns is + definitively removed + (`#13509 <https://github.com/coq/coq/pull/13509>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13568-master+fix13566-check-invalid-occurrences-especially-rewrite.rst b/doc/changelog/04-tactics/13568-master+fix13566-check-invalid-occurrences-especially-rewrite.rst new file mode 100644 index 0000000000..160e83f123 --- /dev/null +++ b/doc/changelog/04-tactics/13568-master+fix13566-check-invalid-occurrences-especially-rewrite.rst @@ -0,0 +1,6 @@ +- **Changed:** + More systematic checks that occurrences of an :n:`at` clause are + valid in tactics such as :tacn:`rewrite` or :tacn:`pattern` + (`#13568 <https://github.com/coq/coq/pull/13568>`_, + fixes `#13566 <https://github.com/coq/coq/issues/13566>`_, + by Hugo Herbelin). diff --git a/doc/changelog/05-tactic-language/00000-title.rst b/doc/changelog/05-tactic-language/00000-title.rst index b34d190298..bc12b18b7d 100644 --- a/doc/changelog/05-tactic-language/00000-title.rst +++ b/doc/changelog/05-tactic-language/00000-title.rst @@ -1,3 +1,4 @@ -**Tactic language** +Tactic language +^^^^^^^^^^^^^^^ diff --git a/doc/changelog/05-tactic-language/13028-master+fix-quotations-printing.rst b/doc/changelog/05-tactic-language/13028-master+fix-quotations-printing.rst deleted file mode 100644 index a191716b2f..0000000000 --- a/doc/changelog/05-tactic-language/13028-master+fix-quotations-printing.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - printing of the quotation qualifiers when printing :g:`Ltac` functions - (`#13028 <https://github.com/coq/coq/pull/13028>`_, - fixes `#9716 <https://github.com/coq/coq/issues/9716>`_ - and `#13004 <https://github.com/coq/coq/issues/13004>`_, - by Hugo Herbelin). diff --git a/doc/changelog/05-tactic-language/13232-ltac2-if-then-else.rst b/doc/changelog/05-tactic-language/13232-ltac2-if-then-else.rst deleted file mode 100644 index d105561a23..0000000000 --- a/doc/changelog/05-tactic-language/13232-ltac2-if-then-else.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - An if-then-else syntax to Ltac2 - (`#13232 <https://github.com/coq/coq/pull/13232>`_, - fixes `#10110 <https://github.com/coq/coq/issues/10110>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13442-ltac2-abstract-ffi.rst b/doc/changelog/05-tactic-language/13442-ltac2-abstract-ffi.rst new file mode 100644 index 0000000000..26b72de2aa --- /dev/null +++ b/doc/changelog/05-tactic-language/13442-ltac2-abstract-ffi.rst @@ -0,0 +1,6 @@ +- **Added:** + A function Ltac1.lambda allowing to embed Ltac2 functions + into Ltac1 runtime values + (`#13442 <https://github.com/coq/coq/pull/13442>`_, + fixes `#12871 <https://github.com/coq/coq/issues/12871>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/06-ssreflect/00000-title.rst b/doc/changelog/06-ssreflect/00000-title.rst index 2e724627ec..43cccd6d60 100644 --- a/doc/changelog/06-ssreflect/00000-title.rst +++ b/doc/changelog/06-ssreflect/00000-title.rst @@ -1,3 +1,4 @@ -**SSReflect** +SSReflect +^^^^^^^^^ diff --git a/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst b/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst deleted file mode 100644 index 8d1564533d..0000000000 --- a/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - SSReflect intro pattern ltac views ``/[dup]``, ``/[swap]`` and ``/[apply]`` - (`#13317 <https://github.com/coq/coq/pull/13317>`_, - by Cyril Cohen). diff --git a/doc/changelog/06-ssreflect/13473-test_pred.rst b/doc/changelog/06-ssreflect/13473-test_pred.rst new file mode 100644 index 0000000000..3c7df11540 --- /dev/null +++ b/doc/changelog/06-ssreflect/13473-test_pred.rst @@ -0,0 +1,4 @@ +- **Added:** + Adding a test that the notations `{in _, _}` and `{pred _}` from `ssrbool.v` are displayed correctly. + (`#13473 <https://github.com/coq/coq/pull/13473>`_, + by Cyril Cohen). diff --git a/doc/changelog/06-ssreflect/13490-backport-ssrbool.rst b/doc/changelog/06-ssreflect/13490-backport-ssrbool.rst new file mode 100644 index 0000000000..096c9d574b --- /dev/null +++ b/doc/changelog/06-ssreflect/13490-backport-ssrbool.rst @@ -0,0 +1,5 @@ +- **Added:** + Lemmas about interaction between :n:`{in _, _}`, :n:`{on _, _}`, and :n:`sig` + have been backported from Mathematical Components 1.12.0 + (`#13490 <https://github.com/coq/coq/pull/13490>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/00000-title.rst b/doc/changelog/07-commands-and-options/00000-title.rst deleted file mode 100644 index 1a0272983e..0000000000 --- a/doc/changelog/07-commands-and-options/00000-title.rst +++ /dev/null @@ -1,3 +0,0 @@ - -**Commands and options** - diff --git a/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst b/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst deleted file mode 100644 index 1c7c3102a3..0000000000 --- a/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Deprecated:** - :cmd:`Grab Existential Variables` and :cmd:`Existential` commands - (`#12516 <https://github.com/coq/coq/pull/12516>`_, - by Maxime Dénès). diff --git a/doc/changelog/07-commands-and-options/13016-remove-Ocaml-value.rst b/doc/changelog/07-commands-and-options/13016-remove-Ocaml-value.rst deleted file mode 100644 index c67b0f6e80..0000000000 --- a/doc/changelog/07-commands-and-options/13016-remove-Ocaml-value.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Removed:** - In the :cmd:`Extraction Language` command, remove `Ocaml` as a valid value. - Use `OCaml` instead. This was deprecated in Coq 8.8, `#6261 <https://github.com/coq/coq/pull/6261>`_ - (`#13016 <https://github.com/coq/coq/pull/13016>`_, by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst b/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst deleted file mode 100644 index 74818f8464..0000000000 --- a/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Changed:** - When compiled with OCaml >= 4.10.0, Coq will use the new best-fit GC - policy, which should provide some performance benefits. Coq's policy - is optimized for speed, but could increase memory consumption in - some cases. You are welcome to tune it using the ``OCAMLRUNPARAM`` - variable and report back setting so we could optimize more. - (`#13040 <https://github.com/coq/coq/pull/13040>`_, - fixes `#11277 <https://github.com/coq/coq/issues/11277>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst b/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst deleted file mode 100644 index 0ab9a58e6f..0000000000 --- a/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - Drop prefixes from grammar non-terminal names, - e.g. "constr:global" -> "global", "Prim.name" -> "name". - Visible in the output of :cmd:`Print Grammar` and :cmd:`Print Custom Grammar`. - (`#13096 <https://github.com/coq/coq/pull/13096>`_, - by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/13139-clean-hint-constr.rst b/doc/changelog/07-commands-and-options/13139-clean-hint-constr.rst deleted file mode 100644 index 1a6bc88c6c..0000000000 --- a/doc/changelog/07-commands-and-options/13139-clean-hint-constr.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - When declaring arbitrary terms as hints, unsolved - evars are not abstracted implicitly anymore and instead - raise an error - (`#13139 <https://github.com/coq/coq/pull/13139>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst b/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst deleted file mode 100644 index 03be92f897..0000000000 --- a/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Added:** - Added support for automatic insertion of coercions in :cmd:`Search` - patterns. Additionally, head patterns are now automatically - interpreted as types - (`#13255 <https://github.com/coq/coq/pull/13255>`_, - fixes `#13244 <https://github.com/coq/coq/issues/13244>`_, - by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst b/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst deleted file mode 100644 index 9ae759be56..0000000000 --- a/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - The :cmd:`Proof using` command can now be used without loading the - Ltac plugin (`-noinit` mode) - (`#13339 <https://github.com/coq/coq/pull/13339>`_, - by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst b/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst deleted file mode 100644 index dc8010b456..0000000000 --- a/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Clarify in the documentation that :cmd:`Add ML Path` is not exported to compiled files - (`#13345 <https://github.com/coq/coq/pull/13345>`_, - fixes `#13344 <https://github.com/coq/coq/issues/13344>`_, - by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/13352-cep-48.rst b/doc/changelog/07-commands-and-options/13352-cep-48.rst deleted file mode 100644 index cb2eeea74b..0000000000 --- a/doc/changelog/07-commands-and-options/13352-cep-48.rst +++ /dev/null @@ -1,12 +0,0 @@ -- **Changed:** - Option -native-compiler of the configure script now impacts the - default value of the option -native-compiler of coqc. The - -native-compiler option of the configure script is added an ondemand - value, which becomes the default, thus preserving the previous default - behavior. - The stdlib is still precompiled when configuring with -native-compiler - yes. It is not precompiled otherwise. - This an implementation of point 2 of - `CEP #48 <https://github.com/coq/ceps/pull/48>`_ - (`#13352 <https://github.com/coq/coq/pull/13352>`_, - by Pierre Roux). diff --git a/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst b/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst deleted file mode 100644 index 8ec7198b72..0000000000 --- a/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Deprecated:** - The default value for hint locality is currently :attr:`local` in a section and - :attr:`global` otherwise, but is scheduled to change in a future release. For the - time being, adding hints outside of sections without specifying an explicit - locality is therefore triggering a deprecation warning. It is recommended to - use :attr:`export` whenever possible - (`#13384 <https://github.com/coq/coq/pull/13384>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst b/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst deleted file mode 100644 index df2bdfeabb..0000000000 --- a/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - The :attr:`export` locality can now be used for all Hint commands, - including Hint Cut, Hint Mode, Hint Transparent / Opaque and - Remove Hints - (`#13388 <https://github.com/coq/coq/pull/13388>`_, - by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-vernac-commands-and-options/00000-title.rst b/doc/changelog/07-vernac-commands-and-options/00000-title.rst new file mode 100644 index 0000000000..fe50ae0e16 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/00000-title.rst @@ -0,0 +1,4 @@ + +Commands and options +^^^^^^^^^^^^^^^^^^^^ + diff --git a/doc/changelog/07-vernac-commands-and-options/13556-master.rst b/doc/changelog/07-vernac-commands-and-options/13556-master.rst new file mode 100644 index 0000000000..05a60026a3 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13556-master.rst @@ -0,0 +1,4 @@ +- **Changed:** + The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). + (`#13556 <https://github.com/coq/coq/pull/13556>`_, + by Simon Friis Vindum). diff --git a/doc/changelog/08-cli-tools/00000-title.rst b/doc/changelog/08-cli-tools/00000-title.rst new file mode 100644 index 0000000000..4c0de43f66 --- /dev/null +++ b/doc/changelog/08-cli-tools/00000-title.rst @@ -0,0 +1,4 @@ + +Command-line tools +^^^^^^^^^^^^^^^^^^ + diff --git a/doc/changelog/08-tools/00000-title.rst b/doc/changelog/08-tools/00000-title.rst deleted file mode 100644 index bf462744fb..0000000000 --- a/doc/changelog/08-tools/00000-title.rst +++ /dev/null @@ -1,3 +0,0 @@ - -**Tools** - diff --git a/doc/changelog/08-tools/12389-coq_makefile.rst b/doc/changelog/08-tools/12389-coq_makefile.rst deleted file mode 100644 index 74e3a68170..0000000000 --- a/doc/changelog/08-tools/12389-coq_makefile.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - Adding the possibility in coq_makefile to directly set the installation folders, - through the :n:`COQLIBINSTALL` and :n:`COQDOCINSTALL` variables. - See :ref:`coqmakefilelocal`. - (`#12389 <https://github.com/coq/coq/pull/12389>`_, by Martin Bodin, review of Enrico Tassi). diff --git a/doc/changelog/08-tools/12410-add-fixes.rst b/doc/changelog/08-tools/12410-add-fixes.rst deleted file mode 100644 index f4c41dc3c3..0000000000 --- a/doc/changelog/08-tools/12410-add-fixes.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - ``dev/tools/make-changelog.sh`` now asks for a list of bugs fixed by the PR - (`#12410 <https://github.com/coq/coq/pull/12410>`_, fixes `#12386 - <https://github.com/coq/coq/issues/12386>`_, by Jason Gross). diff --git a/doc/changelog/08-tools/12613-coqchk-noi.rst b/doc/changelog/08-tools/12613-coqchk-noi.rst deleted file mode 100644 index b83c9c69a2..0000000000 --- a/doc/changelog/08-tools/12613-coqchk-noi.rst +++ /dev/null @@ -1,3 +0,0 @@ -- **Removed:** The option ``-I`` of coqchk was removed (it was - deprecated in Coq 8.8) (`#12613 - <https://github.com/coq/coq/pull/12613>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/08-tools/12862-more-mod-checking.rst b/doc/changelog/08-tools/12862-more-mod-checking.rst deleted file mode 100644 index bb1bf9e789..0000000000 --- a/doc/changelog/08-tools/12862-more-mod-checking.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - ``coqchk`` no longer reports names from inner modules of opaque modules as - axioms (`#12862 <https://github.com/coq/coq/pull/12862>`_, fixes `#12845 - <https://github.com/coq/coq/issues/12845>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/00000-title.rst b/doc/changelog/09-coqide/00000-title.rst index 0fc27cf380..81cf05b844 100644 --- a/doc/changelog/09-coqide/00000-title.rst +++ b/doc/changelog/09-coqide/00000-title.rst @@ -1,3 +1,4 @@ -**CoqIDE** +CoqIDE +^^^^^^ diff --git a/doc/changelog/09-coqide/12874-show_proof_diffs.rst b/doc/changelog/09-coqide/12874-show_proof_diffs.rst deleted file mode 100644 index 51bebad9be..0000000000 --- a/doc/changelog/09-coqide/12874-show_proof_diffs.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Support showing diffs for :cmd:`Show Proof` in CoqIDE from the :n:`View` menu. - See :ref:`showing_proof_diffs`. - (`#12874 <https://github.com/coq/coq/pull/12874>`_, - by Jim Fehrle and Enrico Tassi) diff --git a/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst b/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst deleted file mode 100644 index f7446cc5aa..0000000000 --- a/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - Support for flag :flag:`Printing Goal Names` in View menu - (`#13145 <https://github.com/coq/coq/pull/13145>`_, - by Hugo Herbelin). diff --git a/doc/changelog/10-standard-library/00000-title.rst b/doc/changelog/10-standard-library/00000-title.rst index d517a0e709..f636f48084 100644 --- a/doc/changelog/10-standard-library/00000-title.rst +++ b/doc/changelog/10-standard-library/00000-title.rst @@ -1,3 +1,4 @@ -**Standard library** +Standard library +^^^^^^^^^^^^^^^^ diff --git a/doc/changelog/10-standard-library/12094-app_inj_tail.rst b/doc/changelog/10-standard-library/12094-app_inj_tail.rst deleted file mode 100644 index 702fbb3d64..0000000000 --- a/doc/changelog/10-standard-library/12094-app_inj_tail.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Extend some list lemmas to both directions: `app_inj_tail_iff`, `app_inv_head_iff`, `app_inv_tail_iff`. - (`#12094 <https://github.com/coq/coq/pull/12094>`_, - fixes `#12093 <https://github.com/coq/coq/issues/12093>`_, - by Edward Wang). diff --git a/doc/changelog/10-standard-library/12186-creal-new-modulus.rst b/doc/changelog/10-standard-library/12186-creal-new-modulus.rst deleted file mode 100644 index 778bf78d59..0000000000 --- a/doc/changelog/10-standard-library/12186-creal-new-modulus.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - In the reals theory changed the epsilon in the definition of the modulus of convergence for CReal from 1/n (n in positive) to 2^z (z in Z) - so that a precision coarser than one is possible. Also added an upper bound to CReal to enable more efficient computations. - (`#12186 <https://github.com/coq/coq/pull/12186>`_, - by Michael Soegtrop). diff --git a/doc/changelog/10-standard-library/12420-decidable.rst b/doc/changelog/10-standard-library/12420-decidable.rst deleted file mode 100644 index 6a4da91fa3..0000000000 --- a/doc/changelog/10-standard-library/12420-decidable.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - ``Decidable`` instance for negation - (`#12420 <https://github.com/coq/coq/pull/12420>`_, - by Yishuai Li). diff --git a/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst b/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst deleted file mode 100644 index 208855b4c8..0000000000 --- a/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Changed:** - Int63 notations now match up with the rest of the standard library: :g:`a \% - m`, :g:`m == n`, :g:`m < n`, :g:`m <= n`, and :g:`m ≤ n` have been replaced - with :g:`a mod m`, :g:`m =? n`, :g:`m <? n`, :g:`m <=? n`, and :g:`m ≤? n`. - The old notations are still available as deprecated notations. Additionally, - there is now a ``Coq.Numbers.Cyclic.Int63.Int63.Int63Notations`` module that - users can import to get the ``Int63`` notations without unqualifying the - various primitives (`#12479 <https://github.com/coq/coq/pull/12479>`_, fixes - `#12454 <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst b/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst deleted file mode 100644 index 1709cf1eae..0000000000 --- a/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Changed:** - PrimFloat notations now match up with the rest of the standard library: :g:`m - == n`, :g:`m < n`, and :g:`m <= n` have been replaced with :g:`m =? n`, :g:`m - <? n`, and :g:`m <=? n`. The old notations are still available as deprecated - notations. Additionally, there is now a - ``Coq.Floats.PrimFloat.PrimFloatNotations`` module that users can import to - get the ``PrimFloat`` notations without unqualifying the various primitives - (`#12556 <https://github.com/coq/coq/pull/12556>`_, fixes `#12454 - <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12716-curry.rst b/doc/changelog/10-standard-library/12716-curry.rst deleted file mode 100644 index 51b59e4a94..0000000000 --- a/doc/changelog/10-standard-library/12716-curry.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Deprecated:** - ``prod_curry`` and ``prod_uncurry``, in favor of ``uncurry`` and ``curry`` - (`#12716 <https://github.com/coq/coq/pull/12716>`_, - by Yishuai Li). diff --git a/doc/changelog/10-standard-library/12799-list-repeat.rst b/doc/changelog/10-standard-library/12799-list-repeat.rst deleted file mode 100644 index adfc48f67b..0000000000 --- a/doc/changelog/10-standard-library/12799-list-repeat.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - New lemmas about ``repeat`` in ``List`` and ``Permutation``: ``repeat_app``, ``repeat_eq_app``, ``repeat_eq_cons``, ``repeat_eq_elt``, ``Forall_eq_repeat``, ``Permutation_repeat`` - (`#12799 <https://github.com/coq/coq/pull/12799>`_, - by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12801-cyclic-set.rst b/doc/changelog/10-standard-library/12801-cyclic-set.rst deleted file mode 100644 index 9a07d78144..0000000000 --- a/doc/changelog/10-standard-library/12801-cyclic-set.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - Change the sort of cyclic numbers from Type to Set. For backward compatibility, a dynamic sort was defined in the 3 packages bignums, coqprime and color. - See for example commit 6f62bda in bignums. - (`#12801 <https://github.com/coq/coq/pull/12801>`_, - by Vincent Semeria). diff --git a/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst b/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst deleted file mode 100644 index 41359098e3..0000000000 --- a/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Changed:** - ``Require Import Coq.nsatz.NsatzTactic`` now allows using :tacn:`nsatz` - with `Z` and `Q` without having to supply instances or using ``Require Import Coq.nsatz.Nsatz``, which - transitively requires unneeded files declaring axioms used in the reals - (`#12861 <https://github.com/coq/coq/pull/12861>`_, - fixes `#12860 <https://github.com/coq/coq/issues/12860>`_, - by Jason Gross). diff --git a/doc/changelog/10-standard-library/13365-axiom-free-wf.rst b/doc/changelog/10-standard-library/13365-axiom-free-wf.rst deleted file mode 100644 index 1fc40894eb..0000000000 --- a/doc/changelog/10-standard-library/13365-axiom-free-wf.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - `Coq.Program.Wf.Fix_F_inv` and `Coq.Program.Wf.Fix_eq` are now axiom-free. They no longer assume proof irrelevance. - (`#13365 <https://github.com/coq/coq/pull/13365>`_, - by Li-yao Xia). diff --git a/doc/changelog/10-standard-library/13582-exp_ineq.rst b/doc/changelog/10-standard-library/13582-exp_ineq.rst new file mode 100644 index 0000000000..27d89b2f8b --- /dev/null +++ b/doc/changelog/10-standard-library/13582-exp_ineq.rst @@ -0,0 +1,9 @@ +- **Changed:** + Minor Changes to Rpower: + Generalizes exp_ineq1 to hold for all non-zero numbers. + 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 + +). diff --git a/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst index 6b301f59d3..7358fe192f 100644 --- a/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst +++ b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst @@ -1,3 +1,4 @@ -**Infrastructure and dependencies** +Infrastructure and dependencies +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst b/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst deleted file mode 100644 index 3b34e11ff8..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Changed:** - Coq's core system now uses the `zarith <https://github.com/ocaml/Zarith>`_ - library, based on GNU's gmp instead of ``num`` which is - deprecated upstream. The custom ``bigint`` module is - not longer provided; note that the ``micromega`` still uses - ``num`` - (`#11742 <https://github.com/coq/coq/pull/11742>`_, - by Emilio Jesus Gallego Arias and Vicent Laporte). diff --git a/doc/changelog/11-infrastructure-and-dependencies/13007-zarith+goodbye_num.rst b/doc/changelog/11-infrastructure-and-dependencies/13007-zarith+goodbye_num.rst deleted file mode 100644 index c142eec561..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/13007-zarith+goodbye_num.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Removed:** - The `num` library is not linked to Coq anymore - (`#13007 <https://github.com/coq/coq/pull/13007>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/12-misc/00000-title.rst b/doc/changelog/12-misc/00000-title.rst index 5e709e2b27..1391ec2164 100644 --- a/doc/changelog/12-misc/00000-title.rst +++ b/doc/changelog/12-misc/00000-title.rst @@ -1,3 +1,4 @@ -**Miscellaneous** +Miscellaneous +^^^^^^^^^^^^^ diff --git a/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst b/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst new file mode 100644 index 0000000000..9ed013245e --- /dev/null +++ b/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst @@ -0,0 +1,6 @@ +- **Changed:** + The representation of micromega caches was slightly + altered for efficiency purposes. As a consequence + all stale caches must be cleaned up + (`#13405 <https://github.com/coq/coq/pull/13405>`_, + by Pierre-Marie Pédrot). diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 8c3f7ac3c1..abb08d98cc 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -266,3 +266,13 @@ code span.error { .rst-content tt.literal, .rst-content tt.literal, .rst-content code.literal { color: inherit !important; } + +/* make the error message index readable */ +.indextable code { + white-space: inherit; /* break long lines */ +} + +.indextable tr td + td { + padding-left: 2em; /* indent 2nd & subsequent lines */ + text-indent: -2em; +} diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 27ae7cea3a..039a23e8c2 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -535,11 +535,19 @@ pass additional arguments such as ``using relation``. .. tacn:: setoid_reflexivity setoid_symmetry {? in @ident } setoid_transitivity @one_term - setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } {? at @occurrences } {? in @ident } - setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } in @ident at @occurrences + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } {? at @rewrite_occs } {? in @ident } + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } in @ident at @rewrite_occs setoid_replace @one_term with @one_term {? using relation @one_term } {? in @ident } {? at {+ @int_or_var } } {? by @ltac_expr3 } :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; _; setoid_replace + .. todo: move rewrite_occs to rewrite chapter when that chapter is revised + + .. insertprodn rewrite_occs rewrite_occs + + .. prodn:: + rewrite_occs ::= {+ @integer } + | @ident + The ``using relation`` arguments cannot be passed to the unprefixed form. The latter argument tells the tactic what parametric relation should be used to replace the first tactic argument with the second one. If @@ -714,6 +722,8 @@ instances are tried at each node of the search tree). To speed it up, declare your constant as rigid for proof search using the command :cmd:`Typeclasses Opaque`. +.. _strategies4rewriting: + Strategies for rewriting ------------------------ diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index fb9965e43a..28b60878d2 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -250,11 +250,11 @@ proof by abstracting monomials by variables. `psatz`: a proof procedure for non-linear arithmetic ---------------------------------------------------- -.. tacn:: psatz @one_term {? @int_or_var } +.. tacn:: psatz @one_term {? @nat_or_var } :name: psatz This tactic explores the *Cone* by increasing degrees – hence the - depth parameter *n*. In theory, such a proof search is complete – if the + depth parameter :token:`nat_or_var`. In theory, such a proof search is complete – if the goal is provable the search eventually stops. Unfortunately, the external oracle is using numeric (approximate) optimization techniques that might miss a refutation. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 22527dc379..4143d836c4 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -335,12 +335,6 @@ Summary of the commands .. cmd:: Instance {? @ident_decl {* @binder } } : @type {? @hint_info } {? {| := %{ {* @field_def } %} | := @term } } - .. insertprodn hint_info one_pattern - - .. prodn:: - hint_info ::= %| {? @natural } {? @one_pattern } - one_pattern ::= @one_term - Declares a typeclass instance named :token:`ident_decl` of the class :n:`@type` with the specified parameters and with fields defined by :token:`field_def`, where each field must be a declared field of @@ -405,7 +399,7 @@ Summary of the commands Shows the list of instances associated with the typeclass :token:`reference`. -.. tacn:: typeclasses eauto {? bfs } {? @int_or_var } {? with {+ @ident } } +.. tacn:: typeclasses eauto {? bfs } {? @nat_or_var } {? with {+ @ident } } This proof search tactic uses the resolution engine that is run implicitly during type checking. This tactic uses a different resolution @@ -445,11 +439,11 @@ Summary of the commands + Use the :cmd:`Typeclasses eauto` command to customize the behavior of this tactic. - :n:`@int_or_var` + :n:`@nat_or_var` Specifies the maximum depth of the search. .. warning:: - The semantics for the limit :n:`@int_or_var` + The semantics for the limit :n:`@nat_or_var` are different than for :tacn:`auto`. By default, if no limit is given, the search is unbounded. Unlike :tacn:`auto`, introduction steps count against the limit, which might result in larger limits being necessary when @@ -503,7 +497,7 @@ Typeclasses Transparent, Typeclasses Opaque It is useful when some constants prevent some unifications and make resolution fail. It is also useful to declare constants which - should never be unfolded during proof-search, like fixpoints or + should never be unfolded during proof search, like fixpoints or anything which does not look like an abbreviation. This can additionally speed up proof search as the typeclass map can be indexed by such rigid constants (see @@ -555,7 +549,7 @@ Settings This can be expensive as it requires rebuilding hint clauses dynamically, and does not benefit from the invertibility status of the product introduction rule, resulting in potentially more - expensive proof-search (i.e. more useless backtracking). + expensive proof search (i.e. more useless backtracking). .. flag:: Typeclass Resolution For Conversion diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 4615a8dfca..bb78b142ca 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -412,7 +412,7 @@ Explicit Universes | _ | @qualid univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} - cumul_univ_decl ::= @%{ {* {? {| = | + | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} + cumul_univ_decl ::= @%{ {* {? {| + | = | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} univ_constraint ::= @universe_name {| < | = | <= } @universe_name The syntax has been extended to allow users to explicitly bind names diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 24fa71059c..fcb150e3da 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -8,6 +8,688 @@ Recent changes .. include:: ../unreleased.rst +Version 8.13 +------------ + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.13 integrates many usability improvements, as well +as extensions of the core language. +The main changes include: + + - :ref:`Introduction <813PrimArrays>` of :ref:`primitive persistent arrays<primitive-arrays>` + in the core language, implemented using imperative persistent arrays. + - Introduction of :ref:`definitional proof irrelevance <813UIP>` for the equality type + defined in the SProp sort. + - Cumulative record and inductive type declarations can now + :ref:`specify <813VarianceDecl>` the variance of their universes. + - Various bugfixes and uniformization of behavior with respect to the use of + implicit arguments and the handling of existential variables in + declarations, unification and tactics. + - New warning for :ref:`unused variables <813UnusedVar>` in catch-all match + branches that match multiple distinct patterns. + - New :ref:`warning <813HintWarning>` for `Hint` commands outside + sections without a locality attribute, whose goal is to eventually + remove the fragile default behavior of importing hints only when + using `Require`. The recommended fix is to declare hints as `export`, + instead of the current default `global`, meaning that they are imported + through `Require Import` only, not `Require`. + See the following `rationale and guidelines <https://coq.discourse.group/t/change-of-default-locality-for-hint-commands-in-coq-8-13/1140>`_ + for details. + - General support for :ref:`boolean attributes <813BooleanAttrs>`. + - Many improvements to the handling of :ref:`notations <813Notations>`, + including number notations, recursive notations and notations with bindings. + A new algorithm chooses the most precise notation available to print an expression, + which might introduce changes in printing behavior. + - Tactic :ref:`improvements <813Tactics>` in :tacn:`lia` and its :tacn:`zify` preprocessing step, + now supporting reasoning on boolean operators such as :g:`Z.leb` and supporting + primitive integers :g:`Int63`. + - Typing flags can now be specified :ref:`per-constant / inductive <813TypingFlags>`. + - Improvements to the reference manual including updated syntax + descriptions that match Coq's grammar in several chapters, and splitting parts of + the tactics chapter to independent sections. + +See the `Changes in 8.13+beta1`_ section and following sections for the +detailed list of changes, including potentially breaking changes marked +with **Changed**. + +Coq's documentation is available at https://coq.github.io/doc/v8.13/refman (reference +manual), and https://coq.github.io/doc/v8.13/stdlib (documentation of +the standard library). Developer documentation of the ML API is available +at https://coq.github.io/doc/v8.13/api. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop and Théo Zimmermann worked on maintaining and improving the +continuous integration system and package building infrastructure. + +Erik Martin-Dorel has maintained the `Coq Docker images +<https://hub.docker.com/r/coqorg/coq>`_ that are used in many Coq +projects for continuous integration. + +The OPAM repository for Coq packages has been maintained by +Guillaume Claret, Karl Palmskog, Matthieu Sozeau and Enrico Tassi with +contributions from many users. A list of packages is available at +https://coq.inria.fr/opam/www/. + +Our current 32 maintainers are Yves Bertot, Frédéric Besson, Tej +Chajed, Cyril Cohen, Pierre Corbineau, Pierre Courtieu, Maxime Dénès, +Jim Fehrle, Julien Forest, Emilio Jesús Gallego Arias, Gaëtan Gilbert, +Georges Gonthier, Benjamin Grégoire, Jason Gross, Hugo Herbelin, +Vincent Laporte, Olivier Laurent, Assia Mahboubi, Kenji Maillard, +Guillaume Melquiond, Pierre-Marie Pédrot, Clément Pit-Claudel, +Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Arnaud Spiwack, +Matthieu Sozeau, Enrico Tassi, Laurent Théry, Anton Trunov, Li-yao Xia +and Théo Zimmermann. + +The 52 contributors to this version are Reynald Affeldt, Tanaka Akira, Frédéric +Besson, Lasse Blaauwbroek, Clément Blaudeau, Martin Bodin, Ali Caglayan, Tej Chajed, +Cyril Cohen, Julien Coolen, Matthew Dempsky, Maxime Dénès, Andres Erbsen, +Jim Fehrle, Emilio Jesús Gallego Arias, Paolo G. Giarrusso, Attila Gáspár, Gaëtan Gilbert, +Jason Gross, Benjamin Grégoire, Hugo Herbelin, Wolf Honore, Jasper Hugunin, Ignat Insarov, +Ralf Jung, Fabian Kunze, Vincent Laporte, Olivier Laurent, Larry D. Lee Jr, +Thomas Letan, Yishuai Li, Xia Li-yao, James Lottes, Jean-Christophe Léchenet, +Kenji Maillard, Erik Martin-Dorel, Yusuke Matsushita, Guillaume Melquiond, +Carl Patenaude-Poulin, Clément Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, +Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Matthieu Sozeau, +Enrico Tassi, Anton Trunov, Edward Wang, Li-yao Xia, Beta Ziliani and Théo Zimmermann. + +The Coq community at large helped improve the design of this new version via +the GitHub issue and pull request system, the Coq development mailing list +coqdev@inria.fr, the coq-club@inria.fr mailing list, the `Discourse forum +<https://coq.discourse.group/>`_ and the `Coq Zulip chat <http://coq.zulipchat.com>`_. + +Version 8.13's development spanned 5 months from the release of +Coq 8.12.0. Enrico Tassi and Maxime Dénès are the release managers of Coq 8.13. +This release is the result of 400 merged PRs, closing ~100 issues. + +| Nantes, November 2020, +| Matthieu Sozeau for the Coq development team +| + + +Changes in 8.13+beta1 +~~~~~~~~~~~~~~~~~~~~~ + +.. contents:: + :local: + +Kernel +^^^^^^ + + .. _813UIP: + +- **Added:** + Definitional UIP, only when :flag:`Definitional UIP` is enabled. + This models definitional uniqueness of identity proofs for the equality + type in SProp. It is deactivated by default as it can lead to + non-termination in combination with impredicativity. + Use of this flag is also printed by :cmd:`Print Assumptions`. See + documentation of the flag for details. + (`#10390 <https://github.com/coq/coq/pull/10390>`_, + by Gaëtan Gilbert). + + .. _813PrimArrays: + +- **Added:** + Built-in support for persistent arrays, which expose a functional + interface but are implemented using an imperative data structure, for + better performance. + (`#11604 <https://github.com/coq/coq/pull/11604>`_, + by Maxime Dénès and Benjamin Grégoire, with help from Gaëtan Gilbert). + + Primitive arrays are irrelevant in their single + polymorphic universe (same as a polymorphic cumulative list + inductive would be) (`#13356 + <https://github.com/coq/coq/pull/13356>`_, fixes `#13354 + <https://github.com/coq/coq/issues/13354>`_, by Gaëtan Gilbert). + +- **Fixed:** + A loss of definitional equality for declarations obtained through + :cmd:`Include` when entering the scope of a :cmd:`Module` or + :cmd:`Module Type` was causing :cmd:`Search` not to see the included + declarations + (`#12537 <https://github.com/coq/coq/pull/12537>`_, fixes `#12525 + <https://github.com/coq/coq/pull/12525>`_ and `#12647 + <https://github.com/coq/coq/pull/12647>`_, by Hugo Herbelin). + +- **Fixed:** + Fix an incompleteness in the typechecking of `match` for + cumulative inductive types. This could result in breaking subject + reduction. + (`#13501 <https://github.com/coq/coq/pull/13501>`_, + fixes `#13495 <https://github.com/coq/coq/issues/13495>`_, + by Matthieu Sozeau). + +Specification language, type inference +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + .. _813BooleanAttrs: + +- **Changed:** + :term:`Boolean attributes <boolean attribute>` are now specified using + key/value pairs, that is to say :n:`@ident__attr{? = {| yes | no } }`. + If the value is missing, the default is :n:`yes`. The old syntax is still + supported, but produces the ``deprecated-attribute-syntax`` warning. + + Deprecated attributes are :attr:`universes(monomorphic)`, + :attr:`universes(notemplate)` and :attr:`universes(noncumulative)`, which are + respectively replaced by :attr:`universes(polymorphic=no) <universes(polymorphic)>`, + :attr:`universes(template=no) <universes(template)>` + and :attr:`universes(cumulative=no) <universes(cumulative)>`. + Attributes :attr:`program` and :attr:`canonical` are also affected, + with the syntax :n:`@ident__attr(false)` being deprecated in favor of + :n:`@ident__attr=no`. + (`#13312 <https://github.com/coq/coq/pull/13312>`_, + by Emilio Jesus Gallego Arias). +- **Changed:** Heuristics for universe minimization to :g:`Set`: also + use constraints ``Prop <= i`` (`#10331 + <https://github.com/coq/coq/pull/10331>`_, by Gaëtan Gilbert with + help from Maxime Dénès and Matthieu Sozeau, fixes `#12414 + <https://github.com/coq/coq/issues/12414>`_). +- **Changed:** The type given to :cmd:`Instance` is no longer automatically + generalized over unbound and :ref:`generalizable <implicit-generalization>` variables. + Use ``Instance : `{type}`` instead of :n:`Instance : @type` to get the old behaviour, or + enable the compatibility flag :flag:`Instance Generalized Output`. + (`#13188 <https://github.com/coq/coq/pull/13188>`_, fixes `#6042 + <https://github.com/coq/coq/issues/6042>`_, by Gaëtan Gilbert). +- **Changed:** + Tweaked the algorithm giving default names to arguments. + Should reduce the frequency that argument names get an + unexpected suffix. + Also makes :flag:`Mangle Names` not mess up argument names. + (`#12756 <https://github.com/coq/coq/pull/12756>`_, + fixes `#12001 <https://github.com/coq/coq/issues/12001>`_ + and `#6785 <https://github.com/coq/coq/issues/6785>`_, + by Jasper Hugunin). +- **Removed:** + Undocumented and experimental forward class hint feature ``:>>``. + Use ``:>`` (see :n:`@of_type`) instead + (`#13106 <https://github.com/coq/coq/pull/13106>`_, + by Pierre-Marie Pédrot). + + .. _813VarianceDecl: + +- **Added:** Commands :cmd:`Inductive`, :cmd:`Record` and synonyms now + support syntax `Inductive foo@{=i +j *k l}` to specify variance + information for their universes (in :ref:`Cumulative <cumulative>` + mode) (`#12653 <https://github.com/coq/coq/pull/12653>`_, by Gaëtan + Gilbert). + + .. _813UnusedVar: + +- **Added:** + Warning on unused variables in pattern-matching branches of + :n:`match` serving as catch-all branches for at least two distinct + patterns. + (`#12768 <https://github.com/coq/coq/pull/12768>`_, + fixes `#12762 <https://github.com/coq/coq/issues/12762>`_, + by Hugo Herbelin). +- **Added:** + Definition and (Co)Fixpoint now support the :attr:`using` attribute. + It has the same effect as :cmd:`Proof using`, which is only available in + interactive mode. + (`#13183 <https://github.com/coq/coq/pull/13183>`_, + by Enrico Tassi). + + .. _813TypingFlags: + +- **Added:** + Typing flags can now be specified per-constant / inductive, this + allows to fine-grain specify them from plugins or attributes. See + :ref:`controlling-typing-flags` for details on attribute syntax. + (`#12586 <https://github.com/coq/coq/pull/12586>`_, + by Emilio Jesus Gallego Arias). + +- **Added:** + Inference of return predicate of a :g:`match` by inversion takes + sort elimination constraints into account + (`#13290 <https://github.com/coq/coq/pull/13290>`_, + grants `#13278 <https://github.com/coq/coq/issues/13278>`_, + by Hugo Herbelin). +- **Fixed:** + Implicit arguments taken into account in defined fields of a record type declaration + (`#13166 <https://github.com/coq/coq/pull/13166>`_, + fixes `#13165 <https://github.com/coq/coq/issues/13165>`_, + by Hugo Herbelin). +- **Fixed:** + Allow use of typeclass inference for the return predicate of a :n:`match` + (was deactivated in versions 8.10 to 8.12, `#13217 <https://github.com/coq/coq/pull/13217>`_, + fixes `#13216 <https://github.com/coq/coq/issues/13216>`_, + by Hugo Herbelin). +- **Fixed:** + A case of unification raising an anomaly IllTypedInstance + (`#13376 <https://github.com/coq/coq/pull/13376>`_, + fixes `#13266 <https://github.com/coq/coq/issues/13266>`_, + by Hugo Herbelin). +- **Fixed:** + Using :n:`{wf ...}` in local fixpoints is an error, not an anomaly + (`#13383 <https://github.com/coq/coq/pull/13383>`_, + fixes `#11816 <https://github.com/coq/coq/issues/11816>`_, + by Hugo Herbelin). +- **Fixed:** + Issue when two expressions involving different projections and one is + primitive need to be unified + (`#13386 <https://github.com/coq/coq/pull/13386>`_, + fixes `#9971 <https://github.com/coq/coq/issues/9971>`_, + by Hugo Herbelin). +- **Fixed:** + A bug producing ill-typed instances of existential variables when let-ins + interleaved with assumptions + (`#13387 <https://github.com/coq/coq/pull/13387>`_, + fixes `#12348 <https://github.com/coq/coq/issues/13387>`_, + by Hugo Herbelin). + + .. _813Notations: + +Notations +^^^^^^^^^ + +- **Changed:** + In notations (except in custom entries), the misleading :n:`@syntax_modifier` + :n:`@ident ident` (which accepted either an identifier or + a :g:`_`) is deprecated and should be replaced by :n:`@ident name`. If + the intent was really to only parse identifiers, this will + eventually become possible, but only as of Coq 8.15. + In custom entries, the meaning of :n:`@ident ident` is silently changed + from parsing identifiers or :g:`_` to parsing only identifiers + without warning, but this presumably affects only rare, recent and + relatively experimental code + (`#11841 <https://github.com/coq/coq/pull/11841>`_, + fixes `#9514 <https://github.com/coq/coq/pull/9514>`_, + by Hugo Herbelin). +- **Changed:** + Improved support for notations/abbreviations with mixed terms and patterns (such as the forcing modality) + (`#12099 <https://github.com/coq/coq/pull/12099>`_, + by Hugo Herbelin). +- **Changed** + Rational and real constants are parsed differently. + The exponent is now encoded separately from the fractional part + using ``Z.pow_pos``. This way, parsing large exponents can no longer + blow up and constants are printed in a form closer to the one in which they + were parsed (i.e., ``102e-2`` is reprinted as such and not ``1.02``). + (`#12218 <https://github.com/coq/coq/pull/12218>`_, + by Pierre Roux). +- **Changed:** + Scope information is propagated in indirect applications to a + reference prefixed with :g:`@`; this covers for instance the case + :g:`r.(@p) t` where scope information from :g:`p` is now taken into + account for interpreting :g:`t` (`#12685 + <https://github.com/coq/coq/pull/12685>`_, by Hugo Herbelin). +- **Changed:** + New model for ``only parsing`` and ``only printing`` notations with + support for at most one parsing-and-printing or only-parsing + notation per notation and scope, but an arbitrary number of + only-printing notations + (`#12950 <https://github.com/coq/coq/pull/12950>`_, + fixes `#4738 <https://github.com/coq/coq/issues/4738>`_ + and `#9682 <https://github.com/coq/coq/issues/9682>`_ + and part 2 of `#12908 <https://github.com/coq/coq/issues/12908>`_, + by Hugo Herbelin). +- **Changed:** + Redeclaring a notation also reactivates its printing rule; in + particular a second :cmd:`Import` of the same module reactivates the + printing rules declared in this module. In theory, this leads to + changes in behavior for printing. However, this is mitigated in + general by the adoption in `#12986 + <https://github.com/coq/coq/pull/12986>`_ of a priority given to + notations which match a larger part of the term to print + (`#12984 <https://github.com/coq/coq/pull/12984>`_, + fixes `#7443 <https://github.com/coq/coq/issues/7443>`_ + and `#10824 <https://github.com/coq/coq/issues/10824>`_, + by Hugo Herbelin). +- **Changed:** + Use of notations for printing now gives preference + to notations which match a larger part of the term to abbreviate + (`#12986 <https://github.com/coq/coq/pull/12986>`_, + by Hugo Herbelin). +- **Removed** + OCaml parser and printer for real constants have been removed. + Real constants are now handled with proven Coq code. + (`#12218 <https://github.com/coq/coq/pull/12218>`_, + by Pierre Roux). +- **Deprecated** + ``Numeral.v`` is deprecated, please use ``Number.v`` instead. + (`#12218 <https://github.com/coq/coq/pull/12218>`_, + by Pierre Roux). +- **Deprecated:** + `Numeral Notation`, please use :cmd:`Number Notation` instead + (`#12979 <https://github.com/coq/coq/pull/12979>`_, + by Pierre Roux). +- **Added:** + :flag:`Printing Float` flag to print primitive floats as hexadecimal + instead of decimal values. This is included in the :flag:`Printing All` flag + (`#11986 <https://github.com/coq/coq/pull/11986>`_, + by Pierre Roux). +- **Added:** + :ref:`Number Notation <number-notations>` and :ref:`String Notation + <string-notations>` commands now + support parameterized inductive and non inductive types + (`#12218 <https://github.com/coq/coq/pull/12218>`_, + fixes `#12035 <https://github.com/coq/coq/issues/12035>`_, + by Pierre Roux, review by Jason Gross and Jim Fehrle for the + reference manual). +- **Added:** + Added support for encoding notations of the form :g:`x ⪯ y ⪯ .. ⪯ z ⪯ t`. + This feature is considered experimental. + (`#12765 <https://github.com/coq/coq/pull/12765>`_, + by Hugo Herbelin). +- **Added:** + The :n:`@binder` entry of :cmd:`Notation` can now be used in + notations expecting a single (non-recursive) binder + (`#13265 <https://github.com/coq/coq/pull/13265>`_, + by Hugo Herbelin, see section :ref:`notations-and-binders` of the + reference manual). +- **Fixed:** + Issues in the presence of notations recursively referring to another + applicative notations, such as missing scope propagation, or failure + to use a notation for printing + (`#12960 <https://github.com/coq/coq/pull/12960>`_, + fixes `#9403 <https://github.com/coq/coq/issues/9403>`_ + and `#10803 <https://github.com/coq/coq/issues/10803>`_, + by Hugo Herbelin). +- **Fixed:** + Capture the names of global references by + binders in the presence of notations for binders + (`#12965 <https://github.com/coq/coq/pull/12965>`_, + fixes `#9569 <https://github.com/coq/coq/issues/9569>`_, + by Hugo Herbelin). +- **Fixed:** + Preventing notations for constructors to involve binders + (`#13092 <https://github.com/coq/coq/pull/13092>`_, + fixes `#13078 <https://github.com/coq/coq/issues/13078>`_, + by Hugo Herbelin). +- **Fixed:** Notations understand universe names without getting + confused by different imported modules between declaration and use + locations (`#13415 <https://github.com/coq/coq/pull/13415>`_, fixes + `#13303 <https://github.com/coq/coq/issues/13303>`_, by Gaëtan + Gilbert). + + .. _813Tactics: + +Tactics +^^^^^^^ + +- **Changed:** + In :tacn:`refine`, new existential variables unified with existing ones are no + longer considered as fresh. The behavior of :tacn:`simple refine` no longer depends on + the orientation of evar-evar unification problems, and new existential variables + are always turned into (unshelved) goals. This can break compatibility in + some cases (`#7825 <https://github.com/coq/coq/pull/7825>`_, by Matthieu + Sozeau, with help from Maxime Dénès, review by Pierre-Marie Pédrot and + Enrico Tassi, fixes `#4095 <https://github.com/coq/coq/issues/4095>`_ and + `#4413 <https://github.com/coq/coq/issues/4413>`_). +- **Changed:** + Giving an empty list of occurrences after :n:`in` in tactics is no + longer permitted. Omitting the :n:`in` gives the same behavior + (`#13237 <https://github.com/coq/coq/pull/13236>`_, + fixes `#13235 <https://github.com/coq/coq/issues/13235>`_, + by Hugo Herbelin). +- **Removed:** + :n:`at @occs_nums` clauses in tactics such as :tacn:`unfold` + no longer allow negative values. A "-" before the + list (for set complement) is still supported. Ex: "at -1 -2" + is no longer supported but "at -1 2" is. + (`#13403 <https://github.com/coq/coq/pull/13403>`_, + by Jim Fehrle). +- **Removed:** + A number of tactics that formerly accepted negative + numbers as parameters now give syntax errors for negative + values. These include {e}constructor, do, timeout, + 9 {e}auto tactics and psatz*. + (`#13417 <https://github.com/coq/coq/pull/13417>`_, + by Jim Fehrle). +- **Removed:** + The deprecated and undocumented `prolog` tactic was removed + (`#12399 <https://github.com/coq/coq/pull/12399>`_, + by Pierre-Marie Pédrot). +- **Removed:** `info` tactic that was deprecated in 8.5. + (`#12423 <https://github.com/coq/coq/pull/12423>`_, by Jim Fehrle). +- **Deprecated:** + Undocumented :n:`eauto @nat_or_var @nat_or_var` syntax in favor of new :tacn:`bfs eauto`. + Also deprecated 2-integer syntax for :tacn:`debug eauto` and :tacn:`info_eauto`. + (Use :tacn:`bfs eauto` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) + (`#13381 <https://github.com/coq/coq/pull/13381>`_, + by Jim Fehrle). +- **Added:** + :tacn:`lia` is extended to deal with boolean operators e.g. `andb` or `Z.leb`. + (As `lia` gets more powerful, this may break proof scripts relying on `lia` failure.) + (`#11906 <https://github.com/coq/coq/pull/11906>`_, by Frédéric Besson). +- **Added:** + :tacn:`apply … in` supports several hypotheses + (`#12246 <https://github.com/coq/coq/pull/12246>`_, + by Hugo Herbelin; grants + `#9816 <https://github.com/coq/coq/pull/9816>`_). +- **Added:** + The :tacn:`zify` tactic can now be extended by redefining the `zify_pre_hook` + tactic. (`#12552 <https://github.com/coq/coq/pull/12552>`_, + by Kazuhiko Sakaguchi). +- **Added:** + The :tacn:`zify` tactic provides support for primitive integers (module :g:`ZifyInt63`). + (`#12648 <https://github.com/coq/coq/pull/12648>`_, by Frédéric Besson). +- **Fixed:** + Avoid exposing an internal name of the form :n:`_tmp` when applying the + :n:`_` introduction pattern which would break a dependency + (`#13337 <https://github.com/coq/coq/pull/13337>`_, + fixes `#13336 <https://github.com/coq/coq/issues/13336>`_, + by Hugo Herbelin). +- **Fixed:** + The case of tactics, such as :tacn:`eapply`, producing existential variables + under binders with an ill-formed instance + (`#13373 <https://github.com/coq/coq/pull/13373>`_, + fixes `#13363 <https://github.com/coq/coq/issues/13363>`_, + by Hugo Herbelin). + +Tactic language +^^^^^^^^^^^^^^^ + +- **Added:** + An if-then-else syntax to Ltac2 + (`#13232 <https://github.com/coq/coq/pull/13232>`_, + fixes `#10110 <https://github.com/coq/coq/issues/10110>`_, + by Pierre-Marie Pédrot). +- **Fixed:** + Printing of the quotation qualifiers when printing :g:`Ltac` functions + (`#13028 <https://github.com/coq/coq/pull/13028>`_, + fixes `#9716 <https://github.com/coq/coq/issues/9716>`_ + and `#13004 <https://github.com/coq/coq/issues/13004>`_, + by Hugo Herbelin). + +SSReflect +^^^^^^^^^ + +- **Added:** + SSReflect intro pattern ltac views ``/[dup]``, ``/[swap]`` and ``/[apply]`` + (`#13317 <https://github.com/coq/coq/pull/13317>`_, + by Cyril Cohen). +- **Fixed:** + Working around a bug of interaction between + and /(ltac:(...)) cf + `#13458 <https://github.com/coq/coq/issues/13458>`_ + (`#13459 <https://github.com/coq/coq/pull/13459>`_, + by Cyril Cohen). + +Commands and options +^^^^^^^^^^^^^^^^^^^^ + +- **Changed:** + Drop prefixes from grammar non-terminal names, + e.g. "constr:global" -> "global", "Prim.name" -> "name". + Visible in the output of :cmd:`Print Grammar` and :cmd:`Print Custom Grammar`. + (`#13096 <https://github.com/coq/coq/pull/13096>`_, + by Jim Fehrle). +- **Changed:** + When declaring arbitrary terms as hints, unsolved + evars are not abstracted implicitly anymore and instead + raise an error + (`#13139 <https://github.com/coq/coq/pull/13139>`_, + by Pierre-Marie Pédrot). +- **Removed:** + In the :cmd:`Extraction Language` command, remove `Ocaml` as a valid value. + Use `OCaml` instead. This was deprecated in Coq 8.8, `#6261 <https://github.com/coq/coq/pull/6261>`_ + (`#13016 <https://github.com/coq/coq/pull/13016>`_, by Jim Fehrle). + + .. _813HintWarning: + +- **Deprecated:** + The default value for hint locality is currently :attr:`local` in a section and + :attr:`global` otherwise, but is scheduled to change in a future release. For the + time being, adding hints outside of sections without specifying an explicit + locality is therefore triggering a deprecation warning. It is recommended to + use :attr:`export` whenever possible + (`#13384 <https://github.com/coq/coq/pull/13384>`_, + by Pierre-Marie Pédrot). +- **Deprecated:** + :cmd:`Grab Existential Variables` and :cmd:`Existential` commands + (`#12516 <https://github.com/coq/coq/pull/12516>`_, + by Maxime Dénès). +- **Added:** + The :attr:`export` locality can now be used for all Hint commands, + including :cmd:`Hint Cut`, :cmd:`Hint Mode`, :cmd:`Hint Transparent` / + :cmd:`Opaque <Hint Opaque>` and + :cmd:`Remove Hints` + (`#13388 <https://github.com/coq/coq/pull/13388>`_, + by Pierre-Marie Pédrot). +- **Added:** + Support for automatic insertion of coercions in :cmd:`Search` + patterns. Additionally, head patterns are now automatically + interpreted as types + (`#13255 <https://github.com/coq/coq/pull/13255>`_, + fixes `#13244 <https://github.com/coq/coq/issues/13244>`_, + by Hugo Herbelin). +- **Added:** + The :cmd:`Proof using` command can now be used without loading the + Ltac plugin (`-noinit` mode) + (`#13339 <https://github.com/coq/coq/pull/13339>`_, + by Théo Zimmermann). +- **Added:** + Clarify in the documentation that :cmd:`Add ML Path` is not exported to compiled files + (`#13345 <https://github.com/coq/coq/pull/13345>`_, + fixes `#13344 <https://github.com/coq/coq/issues/13344>`_, + by Hugo Herbelin). + +Tools +^^^^^ + +- **Changed:** + Option `-native-compiler` of the configure script now impacts the + default value of the `-native-compiler` option of coqc. The + `-native-compiler` option of the configure script supports a new `ondemand` + value, which becomes the default, thus preserving the previous default + behavior. + The stdlib is still precompiled when configuring with `-native-compiler + yes`. It is not precompiled otherwise. + This an implementation of point 2 of + `CEP #48 <https://github.com/coq/ceps/pull/48>`_ + (`#13352 <https://github.com/coq/coq/pull/13352>`_, + by Pierre Roux). +- **Changed:** + Added the ability for coq_makefile to directly set the installation folders, + through the `COQLIBINSTALL` and `COQDOCINSTALL` variables. + See :ref:`coqmakefilelocal`. + (`#12389 <https://github.com/coq/coq/pull/12389>`_, by Martin Bodin, review of Enrico Tassi). +- **Removed:** The option ``-I`` of coqchk was removed (it was + deprecated in Coq 8.8) (`#12613 + <https://github.com/coq/coq/pull/12613>`_, by Gaëtan Gilbert). +- **Fixed:** + ``coqchk`` no longer reports names from inner modules of opaque modules as + axioms (`#12862 <https://github.com/coq/coq/pull/12862>`_, fixes `#12845 + <https://github.com/coq/coq/issues/12845>`_, by Jason Gross). + +CoqIDE +^^^^^^ + +- **Added:** + Support showing diffs for :cmd:`Show Proof` in CoqIDE from the :n:`View` menu. + See :ref:`showing_proof_diffs`. + (`#12874 <https://github.com/coq/coq/pull/12874>`_, + by Jim Fehrle and Enrico Tassi) +- **Added:** + Support for flag :flag:`Printing Goal Names` in View menu + (`#13145 <https://github.com/coq/coq/pull/13145>`_, + by Hugo Herbelin). + +Standard library +^^^^^^^^^^^^^^^^ + +- **Changed:** + In the reals theory changed the epsilon in the definition of the modulus of convergence for CReal from 1/n (n in positive) to 2^z (z in Z) + so that a precision coarser than one is possible. Also added an upper bound to CReal to enable more efficient computations. + (`#12186 <https://github.com/coq/coq/pull/12186>`_, + by Michael Soegtrop). +- **Changed:** + Int63 notations now match up with the rest of the standard library: :g:`a \% + m`, :g:`m == n`, :g:`m < n`, :g:`m <= n`, and :g:`m ≤ n` have been replaced + with :g:`a mod m`, :g:`m =? n`, :g:`m <? n`, :g:`m <=? n`, and :g:`m ≤? n`. + The old notations are still available as deprecated notations. Additionally, + there is now a ``Coq.Numbers.Cyclic.Int63.Int63.Int63Notations`` module that + users can import to get the ``Int63`` notations without unqualifying the + various primitives (`#12479 <https://github.com/coq/coq/pull/12479>`_, fixes + `#12454 <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). +- **Changed:** + PrimFloat notations now match up with the rest of the standard library: :g:`m + == n`, :g:`m < n`, and :g:`m <= n` have been replaced with :g:`m =? n`, :g:`m + <? n`, and :g:`m <=? n`. The old notations are still available as deprecated + notations. Additionally, there is now a + ``Coq.Floats.PrimFloat.PrimFloatNotations`` module that users can import to + get the ``PrimFloat`` notations without unqualifying the various primitives + (`#12556 <https://github.com/coq/coq/pull/12556>`_, fixes `#12454 + <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). +- **Changed:** the sort of cyclic numbers from Type to Set. + For backward compatibility, a dynamic sort was defined in the 3 packages bignums, coqprime and color. + See for example commit 6f62bda in bignums. + (`#12801 <https://github.com/coq/coq/pull/12801>`_, + by Vincent Semeria). +- **Changed:** + ``Require Import Coq.nsatz.NsatzTactic`` now allows using :tacn:`nsatz` + with `Z` and `Q` without having to supply instances or using ``Require Import Coq.nsatz.Nsatz``, which + transitively requires unneeded files declaring axioms used in the reals + (`#12861 <https://github.com/coq/coq/pull/12861>`_, + fixes `#12860 <https://github.com/coq/coq/issues/12860>`_, + by Jason Gross). +- **Deprecated:** + ``prod_curry`` and ``prod_uncurry``, in favor of ``uncurry`` and ``curry`` + (`#12716 <https://github.com/coq/coq/pull/12716>`_, + by Yishuai Li). +- **Added:** + New lemmas about ``repeat`` in ``List`` and ``Permutation``: ``repeat_app``, ``repeat_eq_app``, ``repeat_eq_cons``, ``repeat_eq_elt``, ``Forall_eq_repeat``, ``Permutation_repeat`` + (`#12799 <https://github.com/coq/coq/pull/12799>`_, + by Olivier Laurent). +- **Added:** + Extend some list lemmas to both directions: `app_inj_tail_iff`, `app_inv_head_iff`, `app_inv_tail_iff`. + (`#12094 <https://github.com/coq/coq/pull/12094>`_, + fixes `#12093 <https://github.com/coq/coq/issues/12093>`_, + by Edward Wang). +- **Added:** + ``Decidable`` instance for negation + (`#12420 <https://github.com/coq/coq/pull/12420>`_, + by Yishuai Li). +- **Fixed:** + `Coq.Program.Wf.Fix_F_inv` and `Coq.Program.Wf.Fix_eq` are now axiom-free. They no longer assume proof irrelevance. + (`#13365 <https://github.com/coq/coq/pull/13365>`_, + by Li-yao Xia). + +Infrastructure and dependencies +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +- **Changed:** + When compiled with OCaml >= 4.10.0, Coq will use the new best-fit GC + policy, which should provide some performance benefits. Coq's policy + is optimized for speed, but could increase memory consumption in + some cases. You are welcome to tune it using the ``OCAMLRUNPARAM`` + variable and report back on good settings so we can improve the defaults. + (`#13040 <https://github.com/coq/coq/pull/13040>`_, + fixes `#11277 <https://github.com/coq/coq/issues/11277>`_, + by Emilio Jesus Gallego Arias). +- **Changed:** + Coq now uses the `zarith <https://github.com/ocaml/Zarith>`_ + library, based on GNU's gmp instead of ``num`` which is + deprecated upstream. The custom ``bigint`` module is + no longer provided. + (`#11742 <https://github.com/coq/coq/pull/11742>`_, + `#13007 <https://github.com/coq/coq/pull/13007>`_, + by Emilio Jesus Gallego Arias and Vicent Laporte, with help from + Frédéric Besson). + Version 8.12 ------------ @@ -551,7 +1233,7 @@ Flags, options and attributes ``Private`` (`#11665 <https://github.com/coq/coq/pull/11665>`_, by Théo Zimmermann). - **Added:** - The :cmd:`Hint` commands now accept the :attr:`export` locality as + The :ref:`Hint <creating_hints>` commands now accept the :attr:`export` locality as an attribute, allowing to make import-scoped hints (`#11812 <https://github.com/coq/coq/pull/11812>`_, by Pierre-Marie Pédrot). @@ -1336,6 +2018,25 @@ Changes in 8.12.1 fixes `#12332 <https://github.com/coq/coq/issues/12332>`_, by Théo Zimmermann and Jim Fehrle). +Changes in 8.12.2 +~~~~~~~~~~~~~~~~~ + +**Notations** + +- **Fixed:** + 8.12 regression causing notations mentioning a coercion to be ignored + (`#13436 <https://github.com/coq/coq/pull/13436>`_, + fixes `#13432 <https://github.com/coq/coq/issues/13432>`_, + by Hugo Herbelin). + +**Tactics** + +- **Fixed:** + 8.12 regression: incomplete inference of implicit arguments in :tacn:`exists` + (`#13468 <https://github.com/coq/coq/pull/13468>`_, + fixes `#13456 <https://github.com/coq/coq/issues/13456>`_, + by Hugo Herbelin). + Version 8.11 ------------ @@ -3170,7 +3871,7 @@ Vernacular Commands `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` - New `Set Hint Variables/Constants Opaque/Transparent` commands for setting globally the opacity flag of variables and constants in hint databases, - overwriting the opacity set of the hint database. + overriding the opacity setting of the hint database. - Added generic syntax for "attributes", as in: `#[local] Lemma foo : bar.` - Added the `Numeral Notation` command for registering decimal numeral @@ -4045,7 +4746,7 @@ constraints can now be left floating around and be seen by the user thanks to a new option. The Keyed Unification mode has been improved by Matthieu Sozeau. -The typeclass resolution engine and associated proof-search tactic have +The typeclass resolution engine and associated proof search tactic have been reimplemented on top of the proof-engine monad, providing better integration in tactics, and new options have been introduced to control it, by Matthieu Sozeau with help from Théo Zimmermann. @@ -5140,7 +5841,7 @@ Program - Hints costs are now correctly taken into account (potential source of incompatibilities). - Documented the Hint Cut command that allows control of the - proof-search during typeclass resolution (see reference manual). + proof search during typeclass resolution (see reference manual). API @@ -5776,7 +6477,7 @@ Libraries comes first. By default, the power function now takes two BigN. - Creation of Vector, an independent library for lists indexed by their length. - Vectors' names overwrite lists' one so you should not "Import" the library. + Vectors' names override lists' one so you should not "Import" the library. All old names changed: function names follow the ocaml ones and, for example, Vcons becomes Vector.cons. You can get [..;..;..]-style notations by importing Vector.VectorNotations. @@ -6830,7 +7531,7 @@ Tactics - Tactic "remember" now supports an "in" clause to remember only selected occurrences of a term. -- Tactic "pose proof" supports name overwriting in case of specialization of an +- Tactic "pose proof" supports name overriding in case of specialization of an hypothesis. - Semi-decision tactic "jp" for first-order intuitionistic logic moved to user diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index af5d1e3a00..bce88cebde 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -188,10 +188,8 @@ nitpick_ignore = [ ('token', token) for token in [ 'conversion', 'where', 'oriented_rewriter', - 'hintbases', 'bindings_with_parameters', - 'destruction_arg', - 'clause_dft_concl' + 'destruction_arg' ]] # -- Options for HTML output ---------------------------------------------- @@ -222,7 +220,7 @@ html_context = { ("dev", "https://coq.github.io/doc/master/refman/"), ("stable", "https://coq.inria.fr/distrib/current/refman/"), ("v8.13", "https://coq.github.io/doc/v8.13/refman/"), - ("8.12", "https://coq.inria.fr/distrib/V8.12.1/refman/"), + ("8.12", "https://coq.inria.fr/distrib/V8.12.2/refman/"), ("8.11", "https://coq.inria.fr/distrib/V8.11.2/refman/"), ("8.10", "https://coq.inria.fr/distrib/V8.10.2/refman/"), ("8.9", "https://coq.inria.fr/distrib/V8.9.1/refman/"), diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index e029068630..e86a6f4a67 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -170,7 +170,7 @@ has type :n:`@type`. Axiom R_S_inv : forall x y, R x y <-> S y x. .. exn:: @ident already exists. - :name: @ident already exists. (Axiom) + :name: ‘ident’ already exists. (Axiom) :undocumented: .. warn:: @ident is declared as a local axiom diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index 43bbc8b40d..cf46580bdb 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -27,7 +27,8 @@ More information on co-inductive definitions can be found in This command supports the :attr:`universes(polymorphic)`, :attr:`universes(template)`, :attr:`universes(cumulative)`, - :attr:`private(matching)`, and :attr:`using` attributes. + :attr:`private(matching)`, :attr:`bypass_check(universes)`, + :attr:`bypass_check(positivity)`, and :attr:`using` attributes. .. example:: diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 57771c9036..6da1f90ecb 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -90,8 +90,9 @@ Section :ref:`typing-rules`. computation on :n:`@term`. These commands also support the :attr:`universes(polymorphic)`, - :attr:`program` (see :ref:`program_definition`), - :attr:`canonical` and :attr:`using` attributes. + :attr:`program` (see :ref:`program_definition`), :attr:`canonical`, + :attr:`bypass_check(universes)`, :attr:`bypass_check(guard)`, and + :attr:`using` attributes. If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. @@ -108,7 +109,7 @@ Section :ref:`typing-rules`. .. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. .. exn:: @ident already exists. - :name: @ident already exists. (Definition) + :name: ‘ident’ already exists. (Definition) :undocumented: .. exn:: The term @term has type @type while it is expected to have type @type'. @@ -162,18 +163,20 @@ Chapter :ref:`Tactics`. The basic assertion command is: correct at some time of the interactive development of a proof, use the command :cmd:`Guarded`. - This command accepts the :attr:`using` attribute. + This command accepts the :attr:`bypass_check(universes)`, + :attr:`bypass_check(guard)`, and :attr:`using` attributes. .. exn:: The term @term has type @type which should be Set, Prop or Type. :undocumented: .. exn:: @ident already exists. - :name: @ident already exists. (Theorem) + :name: ‘ident’ already exists. (Theorem) The name you provided is already defined. You have then to choose another name. - .. exn:: Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on. + .. exn:: Nested proofs are discouraged and not allowed by default. This error probably means that you forgot to close the last "Proof." with "Qed." or "Defined.". \ + If you really intended to use nested proofs, you can do so by turning the "Nested Proofs Allowed" flag on. You are asserting a new statement while already being in proof editing mode. This feature, called nested proofs, is disabled by default. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 251b5e4955..4bee7cc1b1 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -8,14 +8,13 @@ Inductive types .. cmd:: Inductive @inductive_definition {* with @inductive_definition } - .. insertprodn inductive_definition cumul_ident_decl + .. insertprodn inductive_definition constructor .. prodn:: - inductive_definition ::= {? > } @cumul_ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } + inductive_definition ::= {? > } @ident {? @cumul_univ_decl } {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } constructors_or_record ::= {? %| } {+| @constructor } | {? @ident } %{ {*; @record_field } {? ; } %} constructor ::= @ident {* @binder } {? @of_type } - cumul_ident_decl ::= @ident {? @cumul_univ_decl } This command defines one or more inductive types and its constructors. Coq generates destructors @@ -32,7 +31,8 @@ Inductive types proposition). This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(template)`, :attr:`universes(cumulative)`, and + :attr:`universes(template)`, :attr:`universes(cumulative)`, + :attr:`bypass_check(positivity)`, :attr:`bypass_check(universes)`, and :attr:`private(matching)` attributes. Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. @@ -50,10 +50,12 @@ Inductive types .. exn:: Non strictly positive occurrence of @ident in @type. - The types of the constructors have to satisfy a *positivity condition* - (see Section :ref:`positivity`). This condition ensures the soundness of - the inductive definition. The positivity checking can be disabled using - the :flag:`Positivity Checking` flag (see :ref:`controlling-typing-flags`). + The types of the constructors have to satisfy a *positivity + condition* (see Section :ref:`positivity`). This condition + ensures the soundness of the inductive definition. + Positivity checking can be disabled using the :flag:`Positivity + Checking` flag or the :attr:`bypass_check(positivity)` attribute (see + :ref:`controlling-typing-flags`). .. exn:: The conclusion of @type is not valid; it must be built from @ident. @@ -391,7 +393,8 @@ constructions. consequently :n:`forall {* @binder }, @type` and its value is equivalent to :n:`fun {* @binder } => @term`. - This command accepts the :attr:`program` attribute. + This command accepts the :attr:`program`, + :attr:`bypass_check(universes)`, and :attr:`bypass_check(guard)` attributes. To be accepted, a :cmd:`Fixpoint` definition has to satisfy syntactical constraints on a special argument called the decreasing argument. They @@ -849,9 +852,7 @@ between universes for inductive types in the Type hierarchy. .. coqtop:: none - Unset Positivity Checking. - Inductive I : Prop := not_I_I (not_I : I -> False) : I. - Set Positivity Checking. + #[bypass_check(positivity)] Inductive I : Prop := not_I_I (not_I : I -> False) : I. .. coqtop:: all @@ -885,9 +886,7 @@ between universes for inductive types in the Type hierarchy. .. coqtop:: none - Unset Positivity Checking. - Inductive Lam := lam (_ : Lam -> Lam). - Set Positivity Checking. + #[bypass_check(positivity)] Inductive Lam := lam (_ : Lam -> Lam). .. coqtop:: all @@ -916,9 +915,7 @@ between universes for inductive types in the Type hierarchy. .. coqtop:: none - Unset Positivity Checking. - Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. - Set Positivity Checking. + #[bypass_check(positivity)] Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. .. coqtop:: all diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 54252689e1..6d96e15202 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -155,7 +155,8 @@ are now available through the dot notation. #. Interactive modules and module types can be nested. #. Interactive modules and module types can't be defined inside of :ref:`sections<section-mechanism>`. Sections can be defined inside of interactive modules and module types. - #. Hints and notations (:cmd:`Hint` and :cmd:`Notation` commands) can also appear inside interactive + #. Hints and notations (the :ref:`Hint <creating_hints>` and :cmd:`Notation` + commands) can also appear inside interactive modules and module types. Note that with module definitions like: :n:`Module @ident__1 : @module_type := @ident__2.` diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index df50dbafe3..75389bb259 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -69,7 +69,8 @@ Sections create local contexts which can be shared across multiple definitions. :undocumented: .. note:: - Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which + Most commands, such as the :ref:`Hint <creating_hints>` commands, + :cmd:`Notation` and option management commands that appear inside a section are canceled when the section is closed. .. cmd:: Let @ident_decl @def_body diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index 2460461ede..d178311b4c 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -79,7 +79,7 @@ Setting properties of a function's arguments `!` the function will be unfolded only if all the arguments marked with `!` - evaulate to constructors. See :ref:`Args_effect_on_unfolding`. + evaluate to constructors. See :ref:`Args_effect_on_unfolding`. :n:`@name {? % @scope }` a *formal parameter* of the function :n:`@reference` (i.e. @@ -89,11 +89,25 @@ Setting properties of a function's arguments The construct :n:`@name {? % @scope }` declares :n:`@name` as non-implicit if `clear implicits` is specified or at least one other name is declared implicit in the same list of :n:`@name`\s. :token:`scope` can be either a scope name or its delimiting key. See :ref:`binding_to_scope`. + .. exn:: To rename arguments the 'rename' flag must be specified. + :undocumented: + + .. exn:: Flag 'rename' expected to rename @name into @name. + :undocumented: + `clear implicits` makes all implicit arguments into explicit arguments + + .. exn:: The 'clear implicits' flag must be omitted if implicit annotations are given. + :undocumented: + `default implicits` automatically determine the implicit arguments of the object. See :ref:`auto_decl_implicit_args`. + + .. exn:: The 'default implicits' flag is incompatible with implicit annotations. + :undocumented: + `rename` rename implicit arguments for the object. See the example :ref:`here <renaming_implicit_arguments>`. `assert` diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index f7ce7f1c6c..aa754ab63d 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -490,10 +490,10 @@ We need some infrastructure for that. Definition id {T} {t : T} (x : phantom t) := x. Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p) - (at level 50, v ident, only parsing). + (at level 50, v name, only parsing). Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p) - (at level 50, v ident, only parsing). + (at level 50, v name, only parsing). Notation "'Error : t : s" := (unify _ t (Some s)) (at level 50, format "''Error' : t : s"). diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 6464f085b8..87a367fc93 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -480,15 +480,15 @@ separately. They succeed only if there is a success for each goal. For example Do loop ~~~~~~~ -.. tacn:: do @int_or_var @ltac_expr3 +.. tacn:: do @nat_or_var @ltac_expr3 :name: do - The do loop repeats a tactic :token:`int_or_var` times: + The do loop repeats a tactic :token:`nat_or_var` times: - :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. This tactic - value ``v`` is applied :token:`int_or_var` times. Supposing :token:`int_or_var` > 1, after the + :n:`@ltac_expr` is evaluated to ``v``, which must be a tactic value. This tactic + value ``v`` is applied :token:`nat_or_var` times. If :token:`nat_or_var` > 1, after the first application of ``v``, ``v`` is applied, at least once, to the generated - subgoals and so on. It fails if the application of ``v`` fails before :token:`int_or_var` + subgoals and so on. It fails if the application of ``v`` fails before :token:`nat_or_var` applications have been completed. :tacn:`do` is an :token:`l3_tactic`. @@ -973,11 +973,11 @@ Timeout We can force a tactic to stop if it has not finished after a certain amount of time: -.. tacn:: timeout @int_or_var @ltac_expr3 +.. tacn:: timeout @nat_or_var @ltac_expr3 :name: timeout :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value - ``v`` is applied normally, except that it is interrupted after :n:`@natural` seconds + ``v`` is applied normally, except that it is interrupted after :n:`@nat_or_var` seconds if it is still running. In this case the outcome is a failure. :tacn:`timeout` is an :token:`l3_tactic`. @@ -1637,9 +1637,10 @@ Testing boolean expressions: guard .. tacn:: guard @int_or_var @comparison @int_or_var :name: guard - .. insertprodn comparison comparison + .. insertprodn int_or_var comparison .. prodn:: + int_or_var ::= {| @integer | @ident } comparison ::= = | < | <= @@ -1761,7 +1762,7 @@ Defining |Ltac| symbols "Ltac intros := idtac" seems like it redefines/hides an existing tactic, but in fact it creates a tactic which can only be called by its qualified name. This is true in - general of tactic notations. The only way to overwrite most + general of tactic notations. The only way to override most primitive tactics, and any user-defined tactic notation, is with another tactic notation. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index a46f4fb894..375129c02d 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1475,7 +1475,7 @@ Other nonterminals that have syntactic classes are listed here. * - :n:`clause` - :token:`ltac2_clause` - - :token:`clause_dft_concl` + - :token:`occurrences` * - :n:`occurrences` - :token:`q_occurrences` diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 26a56005c1..d8c4fb61c2 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -264,17 +264,6 @@ These patterns can be used when the hypothesis is an equality: :n:`@simple_intropattern_closed`. :ref:`Example <intropattern_injection_ex>` -.. flag:: Bracketing Last Introduction Pattern - - For :n:`intros @intropattern_list`, controls how to handle a - conjunctive pattern that doesn't give enough simple patterns to match - all the arguments in the constructor. If set (the default), Coq generates - additional names to match the number of arguments. - Unsetting the flag will put the additional hypotheses in the goal instead, behavior that is more - similar to |SSR|'s intro patterns. - - .. deprecated:: 8.10 - .. _intropattern_cons_note: .. note:: @@ -466,52 +455,82 @@ Examples: .. _occurrencessets: -Occurrence sets and occurrence clauses -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occurrence clauses +~~~~~~~~~~~~~~~~~~ -An occurrence clause is a modifier to some tactics that obeys the -following syntax: +An :gdef:`occurrence` is a subterm of a goal or hypothesis that +matches a pattern provided by a tactic. Occurrence clauses +select a subset of the ocurrences in a goal and/or in +one or more of its hypotheses. - .. prodn:: - occurrence_clause ::= in @goal_occurrences - goal_occurrences ::= {*, @ident {? @at_occurrences } } {? |- {? * {? @at_occurrences } } } - | * |- {? * {? @at_occurrences } } - | * - at_occurrences ::= at @occurrences - occurrences ::= {? - } {* @natural } - -The role of an occurrence clause is to select a set of occurrences of a term -in a goal. In the first case, the :n:`@ident {? at {* num}}` parts indicate -that occurrences have to be selected in the hypotheses named :token:`ident`. -If no numbers are given for hypothesis :token:`ident`, then all the -occurrences of :token:`term` in the hypothesis are selected. If numbers are -given, they refer to occurrences of :token:`term` when the term is printed -using the :flag:`Printing All` flag, counting from left to right. In particular, -occurrences of :token:`term` in implicit arguments -(see :ref:`ImplicitArguments`) or coercions (see :ref:`Coercions`) are -counted. - -If a minus sign is given between ``at`` and the list of occurrences, it -negates the condition so that the clause denotes all the occurrences -except the ones explicitly mentioned after the minus sign. - -As an exception to the left-to-right order, the occurrences in -the return subexpression of a match are considered *before* the -occurrences in the matched term. - -In the second case, the ``*`` on the left of ``|-`` means that all occurrences -of term are selected in every hypothesis. - -In the first and second case, if ``*`` is mentioned on the right of ``|-``, the -occurrences of the conclusion of the goal have to be selected. If some numbers -are given, then only the occurrences denoted by these numbers are selected. If -no numbers are given, all occurrences of :token:`term` in the goal are selected. - -Finally, the last notation is an abbreviation for ``* |- *``. Note also -that ``|-`` is optional in the first case when no ``*`` is given. - -Here are some tactics that understand occurrence clauses: :tacn:`set`, -:tacn:`remember`, :tacn:`induction`, :tacn:`destruct`. + .. insertprodn occurrences concl_occs + + .. prodn:: + occurrences ::= at @occs_nums + | in @goal_occurrences + occs_nums ::= {? - } {+ @nat_or_var } + nat_or_var ::= {| @natural | @ident } + goal_occurrences ::= {+, @hyp_occs } {? %|- {? @concl_occs } } + | * %|- {? @concl_occs } + | %|- {? @concl_occs } + | {? @concl_occs } + hyp_occs ::= @hypident {? at @occs_nums } + hypident ::= @ident + | ( type of @ident ) + | ( value of @ident ) + concl_occs ::= * {? at @occs_nums } + + :n:`@occurrences` + The first form of :token:`occurrences` selects occurrences in + the conclusion of the goal. The second form can select occurrences + in the goal conclusion and in one or more hypotheses. + + :n:`{? - } {+ @nat_or_var }` + Selects the specified occurrences within a single goal or hypothesis. + Occurrences are numbered from left to right starting with 1 when the + goal is printed with the :flag:`Printing All` flag. (In particular, occurrences + in :ref:`implicit arguments <ImplicitArguments>` and + :ref:`coercions <Coercions>` are counted but not shown by default.) + + Specifying `-` includes all occurrences *except* the ones listed. + + :n:`{*, @hyp_occs } {? %|- {? @concl_occs } }` + Selects occurrences in the specified hypotheses and the + specified occurrences in the conclusion. + + :n:`* %|- {? @concl_occs }` + Selects all occurrences in all hypotheses and the + specified occurrences in the conclusion. + + :n:`%|- {? @concl_occs }` + Selects the specified occurrences in the conclusion. + + :n:`@goal_occurrences ::= {? @concl_occs }` + Selects all occurrences in all hypotheses and in the specified occurrences + in the conclusion. + + :n:`@hypident {? at @occs_nums }` + Omiting :token:`occs_nums` selects all occurrences within the hypothesis. + + :n:`@hypident ::= @ident` + Selects the hypothesis named :token:`ident`. + + :n:`( type of @ident )` + Selects the type part of the named hypothesis (e.g. `: nat`). + + :n:`( value of @ident )` + Selects the value part of the named hypothesis (e.g. `:= 1`). + + :n:`@concl_occs ::= * {? at @occs_nums }` + Selects occurrences in the conclusion. '*' by itself selects all occurrences. + :n:`@occs_nums` selects the specified occurrences. + + Use `in *` to select all occurrences in all hypotheses and the conclusion, + which is equivalent to `in * |- *`. Use `* |-` to select all occurrences + in all hypotheses. + +Tactics that use occurrence clauses include :tacn:`set`, +:tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. .. seealso:: @@ -878,38 +897,38 @@ Applying theorems This happens if the conclusion of :token:`ident` does not match any of the non-dependent premises of the type of :token:`term`. - .. tacv:: apply {+, @term} in @ident + .. tacv:: apply {+, @term} in {+, @ident} - This applies each :token:`term` in sequence in :token:`ident`. + This applies each :token:`term` in sequence in each hypothesis :token:`ident`. - .. tacv:: apply {+, @term with @bindings} in @ident + .. tacv:: apply {+, @term with @bindings} in {+, @ident} - This does the same but uses the bindings in each :n:`(@ident := @term)` to - instantiate the parameters of the corresponding type of :token:`term` - (see :ref:`bindings`). + This does the same but uses the bindings to instantiate + parameters of :token:`term` (see :ref:`bindings`). - .. tacv:: eapply {+, @term {? with @bindings } } in @ident + .. tacv:: eapply {+, @term {? with @bindings } } in {+, @ident} This works as :tacn:`apply … in` but turns unresolved bindings into existential variables, if any, instead of failing. - .. tacv:: apply {+, @term {? with @bindings } } in @ident as @simple_intropattern + .. tacv:: apply {+, @term {? with @bindings } } in {+, @ident {? as @simple_intropattern}} :name: apply … in … as - This works as :tacn:`apply … in` then applies the :token:`simple_intropattern` - to the hypothesis :token:`ident`. + This works as :tacn:`apply … in` but applying an associated + :token:`simple_intropattern` to each hypothesis :token:`ident` + that comes with such clause. - .. tacv:: simple apply @term in @ident + .. tacv:: simple apply @term in {+, @ident} This behaves like :tacn:`apply … in` but it reasons modulo conversion only on subterms that contain no variables to instantiate and does not traverse tuples. See :ref:`the corresponding example <simple_apply_ex>`. - .. tacv:: {? simple} apply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} - {? simple} eapply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} + .. tacv:: {? simple} apply {+, @term {? with @bindings}} in {+, @ident {? as @simple_intropattern}} + {? simple} eapply {+, @term {? with @bindings}} in {+, @ident {? as @simple_intropattern}} - This summarizes the different syntactic variants of :n:`apply @term in @ident` - and :n:`eapply @term in @ident`. + This summarizes the different syntactic variants of :n:`apply @term in {+, @ident}` + and :n:`eapply @term in {+, @ident}`. .. tacn:: constructor @natural :name: constructor diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 86d1d25745..e866e4c624 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1136,7 +1136,7 @@ Controlling the locality of commands Some commands support an :attr:`export` attribute. The effect of the attribute is to make the effect of the command available when the module containing it is imported. It is supported in - particular by the :cmd:`Hint`, :cmd:`Set` and :cmd:`Unset` + particular by the :ref:`Hint <creating_hints>`, :cmd:`Set` and :cmd:`Unset` commands. .. _controlling-typing-flags: @@ -1152,6 +1152,12 @@ Controlling Typing Flags anymore but it still affects the reduction of the term. Unchecked fixpoints are printed by :cmd:`Print Assumptions`. +.. attr:: bypass_check(guard{? = {| yes | no } }) + :name: bypass_check(guard) + + Similar to :flag:`Guard Checking`, but on a per-declaration + basis. Disable guard checking locally with ``bypass_check(guard)``. + .. flag:: Positivity Checking This flag can be used to enable/disable the positivity checking of inductive @@ -1159,6 +1165,12 @@ Controlling Typing Flags break the consistency of the system, use at your own risk. Unchecked (co)inductive types are printed by :cmd:`Print Assumptions`. +.. attr:: bypass_check(positivity{? = {| yes | no } }) + :name: bypass_check(positivity) + + Similar to :flag:`Positivity Checking`, but on a per-declaration basis. + Disable positivity checking locally with ``bypass_check(positivity)``. + .. flag:: Universe Checking This flag can be used to enable/disable the checking of universes, providing a @@ -1167,6 +1179,12 @@ Controlling Typing Flags :cmd:`Print Assumptions`. It has the same effect as `-type-in-type` command line argument (see :ref:`command-line-options`). +.. attr:: bypass_check(universes{? = {| yes | no } }) + :name: bypass_check(universes) + + Similar to :flag:`Universe Checking`, but on a per-declaration basis. + Disable universe checking locally with ``bypass_check(universes)``. + .. cmd:: Print Typing Flags Print the status of the three typing flags: guard checking, positivity checking diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index cc4ab76502..472df2bd91 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -4,104 +4,87 @@ Programmable proof search ========================= -.. tacn:: auto - :name: auto +.. tacn:: auto {? @nat_or_var } {? @auto_using } {? @hintbases } - This tactic implements a Prolog-like resolution procedure to solve the + .. insertprodn auto_using hintbases + + .. prodn:: + auto_using ::= using {+, @one_term } + hintbases ::= with * + | with {+ @ident } + + Implements a Prolog-like resolution procedure to solve the current goal. It first tries to solve the goal using the :tacn:`assumption` tactic, then it reduces the goal to an atomic one using :tacn:`intros` and introduces the newly generated hypotheses as hints. Then it looks at - the list of tactics associated to the head symbol of the goal and - tries to apply one of them (starting from the tactics with lower - cost). This process is recursively applied to the generated subgoals. + the list of tactics associated with the head symbol of the goal and + tries to apply one of them. Lower cost tactics are tried before higher-cost + tactics. This process is recursively applied to the generated subgoals. - By default, :tacn:`auto` only uses the hypotheses of the current goal and - the hints of the database named ``core``. + :n:`@nat_or_var` + Specifies the maximum search depth. The default is 5. - .. warning:: + :n:`using {+, @one_term }` - :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to - :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will - fail even if applying manually one of the hints would succeed. + Uses lemmas :n:`{+, @one_term }` in addition to hints. If :n:`@one_term` is an + inductive type, the collection of its constructors are added as hints. - .. tacv:: auto @natural + Note that hints passed through the `using` clause are used in the same + way as if they were passed through a hint database. Consequently, + they use a weaker version of :tacn:`apply` and :n:`auto using @one_term` + may fail where :n:`apply @one_term` succeeds. - Forces the search depth to be :token:`natural`. The maximal search depth - is 5 by default. + .. todo + Given that this can be seen as counter-intuitive, it could be useful + to have an option to use full-blown :tacn:`apply` for lemmas passed + through the `using` clause. Contributions welcome! - .. tacv:: auto with {+ @ident} + :n:`with *` + Use all existing hint databases. Using this variant is highly discouraged + in finished scripts since it is both slower and less robust than explicitly + selecting the required databases. - Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. + :n:`with {+ @ident }` + Use the hint databases :n:`{+ @ident}` in addition to the database ``core``. + Use the fake database `nocore` to omit `core`. - .. note:: + If no `with` clause is given, :tacn:`auto` only uses the hypotheses of the + current goal and the hints of the database named ``core``. - Use the fake database `nocore` if you want to *not* use the `core` - database. + :tacn:`auto` generally either completely solves the goal or + leaves it unchanged. Use :tacn:`solve` `[ auto ]` if you want a failure + when they don't solve the goal. :tacn:`auto` will fail if :tacn:`fail` + or :tacn:`gfail` are invoked directly or indirectly, in which case setting + the :flag:`Ltac Debug` may help you debug the failure. - .. tacv:: auto with * + .. warning:: - Uses all existing hint databases. Using this variant is highly discouraged - in finished scripts since it is both slower and less robust than the variant - where the required databases are explicitly listed. + :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to + :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will + fail even if applying manually one of the hints would succeed. .. seealso:: - :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of + :ref:`thehintsdatabasesforautoandeauto` for the list of pre-defined databases and the way to create or extend a database. - .. tacv:: auto using {+ @qualid__i} {? with {+ @ident } } - - Uses lemmas :n:`@qualid__i` in addition to hints. If :n:`@qualid` is an - inductive type, it is the collection of its constructors which are added - as hints. - - .. note:: - - The hints passed through the `using` clause are used in the same - way as if they were passed through a hint database. Consequently, - they use a weaker version of :tacn:`apply` and :n:`auto using @qualid` - may fail where :n:`apply @qualid` succeeds. - - Given that this can be seen as counter-intuitive, it could be useful - to have an option to use full-blown :tacn:`apply` for lemmas passed - through the `using` clause. Contributions welcome! - - .. tacv:: info_auto + .. tacn:: info_auto {? @nat_or_var } {? @auto_using } {? @hintbases } Behaves like :tacn:`auto` but shows the tactics it uses to solve the goal. This variant is very useful for getting a better understanding of automation, or to know what lemmas/assumptions were used. - .. tacv:: debug auto - :name: debug auto + .. tacn:: debug auto {? @nat_or_var } {? @auto_using } {? @hintbases } Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, including failing paths. - .. tacv:: {? info_}auto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} - - This is the most general form, combining the various options. - -.. tacv:: trivial - :name: trivial - - This tactic is a restriction of :tacn:`auto` that is not recursive - and tries only hints that cost `0`. Typically it solves trivial - equalities like :g:`X=X`. - - .. tacv:: trivial with {+ @ident} - trivial with * - trivial using {+ @qualid} - debug trivial - info_trivial - {? info_}trivial {? using {+ @qualid}} {? with {+ @ident}} - :name: _; _; _; debug trivial; info_trivial; _ - :undocumented: +.. tacn:: trivial {? @auto_using } {? @hintbases } + debug trivial {? @auto_using } {? @hintbases } + info_trivial {? @auto_using } {? @hintbases } -.. note:: - :tacn:`auto` and :tacn:`trivial` either solve completely the goal or - else succeed without changing the goal. Use :g:`solve [ auto ]` and - :g:`solve [ trivial ]` if you would prefer these tactics to fail when - they do not manage to solve the goal. + Like :tacn:`auto`, but is not recursive + and only tries hints with zero cost. Typically used to solve goals + for which a lemma is already available in the specified :n:`hintbases`. .. flag:: Info Auto Debug Auto @@ -111,10 +94,9 @@ Programmable proof search These flags enable printing of informative or debug information for the :tacn:`auto` and :tacn:`trivial` tactics. -.. tacn:: eauto - :name: eauto +.. tacn:: eauto {? @nat_or_var } {? @auto_using } {? @hintbases } - This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try + Generalizes :tacn:`auto`. While :tacn:`auto` does not try resolution hints which would leave existential variables in the goal, :tacn:`eauto` does try them (informally speaking, it internally uses a tactic close to :tacn:`simple eapply` instead of a tactic close to :tacn:`simple apply` @@ -133,12 +115,13 @@ Programmable proof search Goal forall P:nat -> Prop, P 0 -> exists n, P n. eauto. - Note that ``ex_intro`` should be declared as a hint. + `ex_intro` is declared as a hint so the proof succeeds. + .. seealso:: :ref:`thehintsdatabasesforautoandeauto` - .. tacv:: {? info_}eauto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} + .. tacn:: info_eauto {? @nat_or_var } {? @auto_using } {? @hintbases } - The various options for :tacn:`eauto` are the same as for :tacn:`auto`. + The various options for :tacn:`info_eauto` are the same as for :tacn:`info_auto`. :tacn:`eauto` also obeys the following flags: @@ -146,34 +129,55 @@ Programmable proof search Debug Eauto :undocumented: - .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + .. tacn:: debug eauto {? @nat_or_var } {? @auto_using } {? @hintbases } + Behaves like :tacn:`eauto` but shows the tactics it tries to solve the goal, + including failing paths. + + .. tacn:: bfs eauto {? @nat_or_var } {? @auto_using } {? @hintbases } + + Like :tacn:`eauto`, but uses a + `breadth-first search <https://en.wikipedia.org/wiki/Breadth-first_search>`_. -.. tacn:: autounfold with {+ @ident} - :name: autounfold +.. tacn:: autounfold {? @hintbases } {? @occurrences } - This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` + Unfolds constants that were declared through a :cmd:`Hint Unfold` in the given databases. -.. tacv:: autounfold with {+ @ident} in @goal_occurrences + :n:`@occurrences` + Performs the unfolding in the specified occurrences. The :n:`at @occs_nums` + clause of :n:`@occurrences` is not supported. + +.. tacn:: autorewrite {? * } with {+ @ident } {? @occurrences } {? using @ltac_expr } + + `*` + If present, rewrite all occurrences whose side conditions are solved. - Performs the unfolding in the given clause (:token:`goal_occurrences`). + .. todo: This may not always work as described, see #4976 #7672 and + https://github.com/coq/coq/issues/1933#issuecomment-337497938 as + mentioned here: https://github.com/coq/coq/pull/13343#discussion_r527801604 -.. tacv:: autounfold with * + :n:`with {+ @ident }` + Specifies the rewriting rule bases to use. - Uses the unfold hints declared in all the hint databases. + :n:`@occurrences` + Performs rewriting in the specified occurrences. Note: the `at` clause + is currently not supported. -.. tacn:: autorewrite with {+ @ident} - :name: autorewrite + .. exn:: The "at" syntax isn't available yet for the autorewrite tactic. - This tactic carries out rewritings according to the rewriting rule - bases :n:`{+ @ident}`. + Appears when there is an `at` clause on the conclusion. - Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until + :n:`using @ltac_expr` + :token:`ltac_expr` is applied to the main subgoal after each rewriting step. + + Applies rewritings according to the rewriting rule bases :n:`{+ @ident }`. + + For each rule base, applies each rewriting to the main subgoal until it fails. Once all the rules have been processed, if the main subgoal has - progressed (e.g., if it is distinct from the initial main goal) then the rules - of this base are processed again. If the main subgoal has not progressed then - the next base is processed. For the bases, the behavior is exactly similar to + changed then the rules + of this base are processed again. If the main subgoal has not changed then + the next base is processed. For the bases, the behavior is very similar to the processing of the rewriting rules. The rewriting rule bases are built with the :cmd:`Hint Rewrite` @@ -183,31 +187,13 @@ Programmable proof search This tactic may loop if you build non terminating rewriting systems. -.. tacv:: autorewrite with {+ @ident} using @tactic - - Performs, in the same way, all the rewritings of the bases :n:`{+ @ident}` - applying tactic to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @qualid - - Performs all the rewritings in hypothesis :n:`@qualid`. - -.. tacv:: autorewrite with {+ @ident} in @qualid using @tactic - - Performs all the rewritings in hypothesis :n:`@qualid` applying :n:`@tactic` - to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @goal_occurrences - - Performs all the rewriting in the clause :n:`@goal_occurrences`. - .. seealso:: - :ref:`Hint-Rewrite <hintrewrite>` for feeding the database of lemmas used by + :cmd:`Hint Rewrite` for feeding the database of lemmas used by :tacn:`autorewrite` and :tacn:`autorewrite` for examples showing the use of this tactic. + Also see :ref:`strategies4rewriting`. .. tacn:: easy - :name: easy This tactic tries to solve the current goal by a number of standard closing steps. In particular, it tries to close the current goal using the closing tactics @@ -220,45 +206,43 @@ Programmable proof search This tactic solves goals that belong to many common classes; in particular, many cases of unsatisfiable hypotheses, and simple equality goals are usually solved by this tactic. -.. tacv:: now @tactic - :name: now +.. tacn:: now @ltac_expr Run :n:`@tactic` followed by :tacn:`easy`. This is a notation for :n:`@tactic; easy`. -Controlling automation --------------------------- - .. _thehintsdatabasesforautoandeauto: The hints databases for auto and eauto -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-------------------------------------- The hints for :tacn:`auto` and :tacn:`eauto` are stored in databases. Each database -maps head symbols to a list of hints. - -.. cmd:: Print Hint @ident +maps head symbols to a list of hints. Use the :cmd:`Print Hint` command to view +the database. - Use this command - to display the hints associated to the head symbol :n:`@ident` - (see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative - integer, and an optional pattern. The hints with lower cost are tried first. A - hint is tried by :tacn:`auto` when the conclusion of the current goal matches its - pattern or when it has no pattern. +Each hint has a cost that is a nonnegative +integer and an optional pattern. Hints with lower costs are tried first. +:tacn:`auto` tries a hint when the conclusion of the current goal matches its +pattern or when the hint has no pattern. Creating Hint databases -``````````````````````` +----------------------- -One can optionally declare a hint database using the command -:cmd:`Create HintDb`. If a hint is added to an unknown database, it will be -automatically created. +Hint databases can be created with the :cmd:`Create HintDb` command or implicitly +by adding a hint to an unknown database. We recommend you always use :cmd:`Create HintDb` +and then imediately use :cmd:`Hint Constants` and :cmd:`Hint Variables` to make +those settings explicit. -.. cmd:: Create HintDb @ident {? discriminated} +Note that the default transparency +settings differ between these two methods of creation. Databases created with +:cmd:`Create HintDb` have the default setting `Transparent` for both `Variables` +and `Constants`, while implicitly created databases have the `Opaque` setting. - This command creates a new database named :n:`@ident`. The database is +.. cmd:: Create HintDb @ident {? discriminated } + + Creates a new hint database named :n:`@ident`. The database is implemented by a Discrimination Tree (DT) that serves as an index of all the lemmas. The DT can use transparency information to decide if a constant should be indexed or not - (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), making the retrieval more efficient. The legacy implementation (the default one for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` goals), for non-Immediate hints and does not make use of transparency @@ -270,149 +254,144 @@ automatically created. from the order in which they were inserted, making this implementation observationally different from the legacy one. -.. cmd:: Hint @hint_definition : {+ @ident} +.. _creating_hints: + +Creating Hints +-------------- - The general command to add a hint to some databases :n:`{+ @ident}`. + The various `Hint` commands share these elements: - This command supports the :attr:`local`, :attr:`global` and :attr:`export` - locality attributes. When no locality is explictly given, the - command is :attr:`local` inside a section and :attr:`global` otherwise. + :n:`{? : {+ @ident } }` specifies the hint database(s) to add to. + *(Deprecated since version 8.10:* If no :token:`ident`\s + are given, the hint is added to the `core` database.) + + Outside of sections, these commands support the :attr:`local`, :attr:`export` + and :attr:`global` attributes. :attr:`global` is the default. Inside sections, + only the :attr:`local` attribute is supported because hints are local to sections. + :attr:`local` hints are never visible from other modules, even if they - require or import the current module. Inside a section, the :attr:`local` - attribute is useless since hints do not survive anyway to the closure of - sections. + :cmd:`Import` or :cmd:`Require` the current module. - + :attr:`export` are visible from other modules when they import the current - module. Requiring it is not enough. + + :attr:`export` hints are visible from other modules when they :cmd:`Import` the current + module, but not when they only :cmd:`Require` it. This attribute is supported by + all `Hint` commands except for :cmd:`Hint Rewrite`. - + :attr:`global` hints are made available by merely requiring the current - module. + + :attr:`global` hints are visible from other modules when they :cmd:`Import` or + :cmd:`Require` the current module. .. deprecated:: 8.13 - The default value for hint locality is scheduled to change in a future + The default value for hint locality will change in a future release. For the time being, adding hints outside of sections without - specifying an explicit locality is therefore triggering a deprecation - warning. It is recommended to use :attr:`export` whenever possible - - The various possible :production:`hint_definition`\s are given below. - - .. cmdv:: Hint @hint_definition + specifying an explicit locality will trigger a deprecation + warning. We recommend you use :attr:`export` whenever possible. - No database name is given: the hint is registered in the ``core`` database. + The `Hint` commands are: - .. deprecated:: 8.10 + .. cmd:: Hint Resolve {+ {| @qualid | @one_term } } {? @hint_info } {? : {+ @ident } } + Hint Resolve {| -> | <- } {+ @qualid } {? @natural } {? : {+ @ident } } + :name: Hint Resolve; _ - .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident - :name: Hint Resolve + .. insertprodn hint_info one_pattern - This command adds :n:`simple apply @qualid` to the hint list with the head - symbol of the type of :n:`@qualid`. The cost of that hint is the number of - subgoals generated by :n:`simple apply @qualid` or :n:`@natural` if specified. The - associated :n:`@pattern` is inferred from the conclusion of the type of - :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type - of :n:`@qualid` does not start with a product the tactic added in the hint list - is :n:`exact @qualid`. In case this type can however be reduced to a type - starting with a product, the tactic :n:`simple apply @qualid` is also stored in - the hints list. If the inferred type of :n:`@qualid` contains a dependent - quantification on a variable which occurs only in the premisses of the type + .. prodn:: + hint_info ::= %| {? @natural } {? @one_pattern } + one_pattern ::= @one_term + + The first form adds each :n:`@qualid` as a hint with the head symbol of the type of + :n:`@qualid` to the specified hint databases (:n:`@ident`\s). The cost of the hint is the number of + subgoals generated by :tacn:`simple apply` :n:`@qualid` or, if specified, :n:`@natural`. The + associated pattern is inferred from the conclusion of the type of + :n:`@qualid` or, if specified, the given :n:`@one_pattern`. + + If the inferred type + of :n:`@qualid` does not start with a product, :tacn:`exact` :n:`@qualid` is added + to the hint list. If the type can be reduced to a type starting with a product, + :tacn:`simple apply` :n:`@qualid` is also added to the hints list. + + If the inferred type of :n:`@qualid` contains a dependent + quantification on a variable which occurs only in the premises of the type and not in its conclusion, no instance could be inferred for the variable by - unification with the goal. In this case, the hint is added to the hint list - of :tacn:`eauto` instead of the hint list of auto and a warning is printed. A - typical example of a hint that is used only by :tacn:`eauto` is a transitivity + unification with the goal. In this case, the hint is only used by + :tacn:`eauto` / :tacn:`typeclasses eauto`, but not by :tacn:`auto`. A + typical hint that would only be used by :tacn:`eauto` is a transitivity lemma. - .. exn:: @qualid cannot be used as a hint - - The head symbol of the type of :n:`@qualid` is a bound variable - such that this tactic cannot be associated to a constant. - - .. cmdv:: Hint Resolve {+ @qualid} : @ident + :n:`{| -> | <- }` + The second form adds the left-to-right (`->`) or right-ot-left implication (`<-`) + of an equivalence as a hint (informally + the hint will be used as, respectively, :tacn:`apply` :n:`-> @qualid` or + :tacn:`apply` :n:`<- @qualid`, + although as mentioned before, the tactic actually used is a restricted version of + :tacn:`apply`). - Adds each :n:`Hint Resolve @qualid`. + :n:`@one_term` + Permits declaring a hint without declaring a new + constant first, but this is not recommended. - .. cmdv:: Hint Resolve -> @qualid : @ident + .. warn:: Declaring arbitrary terms as hints is fragile; it is recommended to declare a toplevel constant instead + :undocumented: - Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @qualid`, although as mentioned - before, the tactic actually used is a restricted version of - :tacn:`apply`). - - .. cmdv:: Hint Resolve <- @qualid + .. exn:: @qualid cannot be used as a hint - Adds the right-to-left implication of an equivalence as a hint. + The head symbol of the type of :n:`@qualid` is a bound variable + such that this tactic cannot be associated to a constant. - .. cmdv:: Hint Immediate @qualid : @ident - :name: Hint Immediate + .. cmd:: Hint Immediate {+ {| @qualid | @one_term } } {? : {+ @ident } } - This command adds :n:`simple apply @qualid; trivial` to the hint list associated - with the head symbol of the type of :n:`@ident` in the given database. This - tactic will fail if all the subgoals generated by :n:`simple apply @qualid` are + Adds :tacn:`simple apply` :n:`@qualid;` :tacn:`trivial` to the hint list for each :n:`@qualid` associated + with the head symbol of the type of :n:`@ident`. This + tactic will fail if all the subgoals generated by :tacn:`simple apply` :n:`@qualid` are not solved immediately by the :tacn:`trivial` tactic (which only tries tactics - with cost 0).This command is useful for theorems such as the symmetry of - equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited - use in order to avoid useless proof-search. The cost of this tactic (which + with cost 0). This command is useful for theorems such as the symmetry of + equality or :g:`n+1=m+1 -> n=m` that we may want to introduce with limited + use in order to avoid useless proof search. The cost of this tactic (which never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` itself. - .. exn:: @qualid cannot be used as a hint - :undocumented: + .. cmd:: Hint Constructors {+ @qualid } {? : {+ @ident } } - .. cmdv:: Hint Immediate {+ @qualid} : @ident - - Adds each :n:`Hint Immediate @qualid`. - - .. cmdv:: Hint Constructors @qualid : @ident - :name: Hint Constructors - - If :token:`qualid` is an inductive type, this command adds all its constructors as + For each :n:`@qualid` that is an inductive type, adds all its constructors as hints of type ``Resolve``. Then, when the conclusion of current goal has the form :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. .. exn:: @qualid is not an inductive type :undocumented: - .. cmdv:: Hint Constructors {+ @qualid} : @ident - - Extends the previous command for several inductive types. + .. cmd:: Hint Unfold {+ @qualid } {? : {+ @ident } } - .. cmdv:: Hint Unfold @qualid : @ident - :name: Hint Unfold - - This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :token:`qualid`. + For each :n:`@qualid`, adds the tactic :tacn:`unfold` :n:`@qualid` to the + hint list that will only be used when the head constant of the goal is :token:`qualid`. Its cost is 4. - .. cmdv:: Hint Unfold {+ @qualid} - - Extends the previous command for several defined constants. - - .. cmdv:: Hint Transparent {+ @qualid} : @ident - Hint Opaque {+ @qualid} : @ident + .. cmd:: Hint {| Transparent | Opaque } {+ @qualid } {? : {+ @ident } } :name: Hint Transparent; Hint Opaque - This adds transparency hints to the database, making :n:`@qualid` - transparent or opaque constants during resolution. This information is used + Adds transparency hints to the database, making each :n:`@qualid` + a transparent or opaque constant during resolution. This information is used during unification of the goal with any lemma in the database and inside the discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident - Hint Constants {| Transparent | Opaque } : @ident - :name: Hint Variables; Hint Constants + .. cmd:: Hint {| Constants | Variables } {| Transparent | Opaque } {? : {+ @ident } } + :name: Hint Constants; Hint Variables - This sets the transparency flag used during unification of - hints in the database for all constants or all variables, - overwriting the existing settings of opacity. It is advised - to use this just after a :cmd:`Create HintDb` command. + Sets the transparency flag for constants or variables for the specified hint + databases. + These flags affect the unification of hints in the database. + We advise using this just after a :cmd:`Create HintDb` command. - .. cmdv:: Hint Extern @natural {? @pattern} => @tactic : @ident - :name: Hint Extern + .. cmd:: Hint Extern @natural {? @one_pattern } => @ltac_expr {? : {+ @ident } } - This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and - :tacn:`unfold`. For that, we must specify a cost, an optional :n:`@pattern` and a - :n:`@tactic` to execute. + Extends :tacn:`auto` with tactics other than :tacn:`apply` and + :tacn:`unfold`. :n:`@natural` is the cost, :n:`@one_term` is the pattern + to match and :n:`@ltac_expr` is the action to apply. + + .. note:: + + Use a :cmd:`Hint Extern` with no pattern to do + pattern matching on hypotheses using ``match goal with`` + inside the tactic. .. example:: @@ -441,80 +420,131 @@ automatically created. .. coqtop:: all Require Import List. - Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. + Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => + generalize X1, X2; decide equality : eqdec. Goal forall a b:list (nat * nat), {a = b} + {a <> b}. - Info 1 auto with eqdec. + info_auto. - .. cmdv:: Hint Cut @regexp : @ident - :name: Hint Cut + .. cmd:: Hint Cut [ @hints_regexp ] {? : {+ @ident } } - .. warning:: - - These hints currently only apply to typeclass proof search and the - :tacn:`typeclasses eauto` tactic. - - This command can be used to cut the proof-search tree according to a regular - expression matching paths to be cut. The grammar for regular expressions is - the following. Beware, there is no operator precedence during parsing, one can - check with :cmd:`Print HintDb` to verify the current cut expression: + .. DISABLED insertprodn hints_regexp hints_regexp .. prodn:: - regexp ::= @ident (hint or instance identifier) + hints_regexp ::= {+ @qualid } (hint or instance identifier) | _ (any hint) - | @regexp | @regexp (disjunction) - | @regexp @regexp (sequence) - | @regexp * (Kleene star) + | @hints_regexp | @hints_regexp (disjunction) + | @hints_regexp @hints_regexp (sequence) + | @hints_regexp * (Kleene star) | emp (empty) | eps (epsilon) - | ( @regexp ) + | ( @hints_regexp ) + + Used to cut the proof search tree according to a regular + expression that matches the paths to be cut. + - The `emp` regexp does not match any search path while `eps` - matches the empty path. During proof search, the path of - successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have + During proof search, the path of + successive successful hints on a search branch is recorded as a + list of identifiers for the hints (note that :cmd:`Hint Extern`\s do not have an associated identifier). - Before applying any hint :n:`@ident` the current path `p` extended with - :n:`@ident` is matched against the current cut expression `c` associated to - the hint database. If matching succeeds, the hint is *not* applied. The - semantics of :n:`Hint Cut @regexp` is to set the cut expression - to :n:`c | regexp`, the initial cut expression being `emp`. - - .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident - :name: Hint Mode - - This sets an optional mode of use of the identifier :n:`@qualid`. When - proof-search faces a goal that ends in an application of :n:`@qualid` to - arguments :n:`@term ... @term`, the mode tells if the hints associated to - :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, + For each hint :n:`@qualid` in the hint database, the current path `p` + extended with :n:`@qualid` + is matched against the current cut expression `c` associated with the + hint database. If the match succeeds the hint is *not* applied. + + :n:`Hint Cut @hints_regexp` sets the cut expression + to :n:`c | @hints_regexp`. The initial cut expression is `emp`. + + The output of :cmd:`Print HintDb` shows the cut expression. + + .. warning:: + + There is no operator precedence during parsing, one can + check with :cmd:`Print HintDb` to verify the current cut expression. + + .. warning:: + + These hints currently only apply to typeclass proof search and the + :tacn:`typeclasses eauto` tactic. + + .. cmd:: Hint Mode @qualid {+ {| + | ! | - } } {? : {+ @ident } } + + Sets an optional mode of use for the identifier :n:`@qualid`. When + proof search has a goal that ends in an application of :n:`@qualid` to + arguments :n:`@arg ... @arg`, the mode tells if the hints associated with + :n:`@qualid` can be applied or not. A mode specification is a list of ``+``, ``!`` or ``-`` items that specify if an argument of the identifier is to be treated as an input (``+``), if its head only is an input (``!``) or an output (``-``) of the identifier. For a mode to match a list of arguments, input terms and input heads *must not* contain existential variables or be - existential variables respectively, while outputs can be any term. Multiple - modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied. The head of a term + existential variables respectively, while outputs can be any term. + + The head of a term is understood here as the applicative head, or the match or projection scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is especially useful for typeclasses, when one does not want to support default instances and avoid ambiguity in general. Setting a parameter of a class as an - input forces proof-search to be driven by that index of the class, with ``!`` - giving more flexibility by allowing existentials to still appear deeper in the - index but not at its head. + input forces proof search to be driven by that index of the class, with ``!`` + allowing existentials to appear in the index but not at its head. .. note:: - + One can use a :cmd:`Hint Extern` with no pattern to do - pattern matching on hypotheses using ``match goal with`` - inside the tactic. + + Multiple modes can be declared for a single identifier. In that + case only one mode needs to match the arguments for the hints to be applied. + If you want to add hints such as :cmd:`Hint Transparent`, :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass resolution, do not forget to put them in the ``typeclass_instances`` hint database. +.. cmd:: Hint Rewrite {? {| -> | <- } } {+ @one_term } {? using @ltac_expr } {? : {* @ident } } + + :n:`{? using @ltac_expr }` + If specified, :n:`@ltac_expr` is applied to the generated subgoals, except for the + main subgoal. + + :n:`{| -> | <- }` + Arrows specify the orientation; left to right (:n:`->`) or right to left (:n:`<-`). + If no arrow is given, the default orientation is left to right (:n:`->`). + + Adds the terms :n:`{+ @one_term }` (their types must be + equalities) to the rewriting bases :n:`{* @ident }`. + Note that the rewriting bases are distinct from the :tacn:`auto` + hint bases and that :tacn:`auto` does not take them into account. + + .. cmd:: Print Rewrite HintDb @ident + + This command displays all rewrite hints contained in :n:`@ident`. + +.. cmd:: Remove Hints {+ @qualid } {? : {+ @ident } } + + Removes the hints associated with the :n:`{+ @qualid }` in databases + :n:`{+ @ident}`. Note: hints created with :cmd:`Hint Extern` currently + can't be removed. The best workaround for this is to make the hints + non global and carefully select which modules you import. + +.. cmd:: Print Hint {? {| * | @reference } } + + :n:`*` + Display all declared hints. + + :n:`@reference` + Display all hints associated with the head symbol :n:`@reference`. + + Displays tactics from the hints list. The default is to show hints that + apply to the conclusion of the current goal. The other forms with :n:`*` + and :n:`@reference` can be used even if no proof is open. + + Each hint has a cost that is a nonnegative + integer and an optional pattern. The hints with lower cost are tried first. + +.. cmd:: Print HintDb @ident + + This command displays all hints from database :n:`@ident`. + Hint databases defined in the Coq standard library -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-------------------------------------------------- Several hint databases are defined in the Coq standard library. The actual content of a database is the collection of hints declared @@ -555,76 +585,8 @@ At Coq startup, only the core database is nonempty and can be used. You are advised not to put your own hints in the core database, but use one or several databases specific to your development. -.. _removehints: - -.. cmd:: Remove Hints {+ @term} : {+ @ident} - - This command removes the hints associated to terms :n:`{+ @term}` in databases - :n:`{+ @ident}`. - -.. _printhint: - -.. cmd:: Print Hint - - This command displays all hints that apply to the current goal. It - fails if no proof is being edited, while the two variants can be used - at every moment. - -**Variants:** - - -.. cmd:: Print Hint @ident - - This command displays only tactics associated with :n:`@ident` in the hints - list. This is independent of the goal being edited, so this command will not - fail if no goal is being edited. - -.. cmd:: Print Hint * - - This command displays all declared hints. - -.. cmd:: Print HintDb @ident - - This command displays all hints from database :n:`@ident`. - -.. _hintrewrite: - -.. cmd:: Hint Rewrite {+ @term} : {+ @ident} - - This vernacular command adds the terms :n:`{+ @term}` (their types must be - equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation - (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` - hint bases and that :tacn:`auto` does not take them into account. - - This command is synchronous with the section mechanism (see :ref:`section-mechanism`): - when closing a section, all aliases created by ``Hint Rewrite`` in that - section are lost. Conversely, when loading a module, all ``Hint Rewrite`` - declarations at the global level of that module are loaded. - -**Variants:** - -.. cmd:: Hint Rewrite -> {+ @term} : {+ @ident} - - This is strictly equivalent to the command above (we only make explicit the - orientation which otherwise defaults to ->). - -.. cmd:: Hint Rewrite <- {+ @term} : {+ @ident} - - Adds the rewriting rules :n:`{+ @term}` with a right-to-left orientation in - the bases :n:`{+ @ident}`. - -.. cmd:: Hint Rewrite {? {| -> | <- } } {+ @one_term } {? using @ltac_expr } {? : {* @ident } } - - When the rewriting rules :n:`{+ @term}` in :n:`{+ @ident}` will be used, the - tactic ``tactic`` will be applied to the generated subgoals, the main subgoal - excluded. - -.. cmd:: Print Rewrite HintDb @ident - - This command displays all rewrite hints contained in :n:`@ident`. - Hint locality -~~~~~~~~~~~~~ +------------- Hints provided by the ``Hint`` commands are erased when closing a section. Conversely, all hints of a module ``A`` that are not defined inside a @@ -649,7 +611,6 @@ option which accepts three flags allowing for a fine-grained handling of non-imported hints. .. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } - :name: Loose Hint Behavior This option accepts three values, which control the behavior of hints w.r.t. :cmd:`Import`: @@ -668,22 +629,12 @@ non-imported hints. .. _tactics-implicit-automation: Setting implicit automation tactics -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +----------------------------------- -.. cmd:: Proof with @tactic +.. cmd:: Proof with @ltac_expr {? using @section_var_expr } - This command may be used to start a proof. It defines a default tactic - to be used each time a tactic command ``tactic``:sub:`1` is ended by ``...``. - In this case the tactic command typed by the user is equivalent to - ``tactic``:sub:`1` ``;tactic``. + Starts a proof in which :token:`ltac_expr` is applied to the active goals + after each tactic that ends with `...` instead of the usual single period. + ":n:`@tactic...`" is equivalent to ":n:`@tactic; @ltac_expr.`". .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. - - - .. cmdv:: Proof with @tactic using {+ @ident} - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - - .. cmdv:: Proof using {+ @ident} with @tactic - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 5283f60b11..3649202b45 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -146,6 +146,13 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. only in the conclusion of the goal. The clause argument must not contain any ``type of`` nor ``value of``. + .. tacv:: cutrewrite {? {| <- | -> } } (@term__1 = @term__2) {? in @ident } + :name: cutrewrite + + .. deprecated:: 8.5 + + Use :tacn:`replace` instead. + .. tacn:: subst @ident :name: subst @@ -295,21 +302,21 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Performing computations --------------------------- -.. insertprodn red_expr pattern_occ +.. insertprodn red_expr pattern_occs .. prodn:: red_expr ::= red | hnf - | simpl {? @delta_flag } {? @ref_or_pattern_occ } + | simpl {? @delta_flag } {? {| @reference_occs | @pattern_occs } } | cbv {? @strategy_flag } | cbn {? @strategy_flag } | lazy {? @strategy_flag } | compute {? @delta_flag } - | vm_compute {? @ref_or_pattern_occ } - | native_compute {? @ref_or_pattern_occ } - | unfold {+, @unfold_occ } + | vm_compute {? {| @reference_occs | @pattern_occs } } + | native_compute {? {| @reference_occs | @pattern_occs } } + | unfold {+, @reference_occs } | fold {+ @one_term } - | pattern {+, @pattern_occ } + | pattern {+, @pattern_occs } | @ident delta_flag ::= {? - } [ {+ @reference } ] strategy_flag ::= {+ @red_flag } @@ -321,14 +328,8 @@ Performing computations | cofix | zeta | delta {? @delta_flag } - ref_or_pattern_occ ::= @reference {? at @occs_nums } - | @one_term {? at @occs_nums } - occs_nums ::= {+ {| @natural | @ident } } - | - {+ {| @natural | @ident } } - int_or_var ::= @integer - | @ident - unfold_occ ::= @reference {? at @occs_nums } - pattern_occ ::= @one_term {? at @occs_nums } + reference_occs ::= @reference {? at @occs_nums } + pattern_occs ::= @one_term {? at @occs_nums } This set of tactics implements different specialized usages of the tactic :tacn:`change`. @@ -346,17 +347,6 @@ clauses) and are introduced by the keyword `in`. If no goal clause is provided, the default is to perform the conversion only in the conclusion. -The syntax and description of the various goal clauses is the -following: - -+ :n:`in {+ @ident} |-` only in hypotheses :n:`{+ @ident}` -+ :n:`in {+ @ident} |- *` in hypotheses :n:`{+ @ident}` and in the - conclusion -+ :n:`in * |-` in every hypothesis -+ :n:`in *` (equivalent to in :n:`* |- *`) everywhere -+ :n:`in (type of @ident) (value of @ident) ... |-` in type part of - :n:`@ident`, in the value part of :n:`@ident`, etc. - For backward compatibility, the notation :n:`in {+ @ident}` performs the conversion in hypotheses :n:`{+ @ident}`. @@ -532,7 +522,7 @@ the conversion in hypotheses :n:`{+ @ident}`. use the name of the constant the (co)fixpoint comes from instead of the (co)fixpoint definition in recursive calls. - The :tacn:`cbn` tactic is claimed to be a more principled, faster and more + The :tacn:`cbn` tactic was intended to be a more principled, faster and more predictable replacement for :tacn:`simpl`. The :tacn:`cbn` tactic accepts the same flags as :tacn:`cbv` and diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 5cbd2e400e..f454f4313d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -309,7 +309,7 @@ at the time of use of the notation. a notation should only be used for printing. If a notation to be used both for parsing and printing is - overriden, both the parsing and printing are invalided, even if the + overridden, both the parsing and printing are invalided, even if the overriding rule is only parsing. If a given notation string occurs only in ``only printing`` rules, @@ -588,6 +588,8 @@ As an exception, if the right-hand side is just of the form :n:`@@qualid`, this conventionally stops the inheritance of implicit arguments (but not of notation scopes). +.. _notations-and-binders: + Notations and binders ~~~~~~~~~~~~~~~~~~~~~ @@ -603,7 +605,7 @@ Here is the basic example of a notation using a binder: .. coqtop:: in Notation "'sigma' x : A , B" := (sigT (fun x : A => B)) - (at level 200, x ident, A at level 200, right associativity). + (at level 200, x name, A at level 200, right associativity). The binding variables in the right-hand side that occur as a parameter of the notation (here :g:`x`) dynamically bind all the occurrences @@ -616,8 +618,9 @@ application of the notation: Check sigma z : nat, z = 0. -Note the :n:`@syntax_modifier x ident` in the declaration of the -notation. It tells to parse :g:`x` as a single identifier. +Note the :n:`@syntax_modifier x name` in the declaration of the +notation. It tells to parse :g:`x` as a single identifier (or as the +unnamed variable :g:`_`). Binders bound in the notation and parsed as patterns ++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -655,7 +658,7 @@ variable. Here is an example showing the difference: Notation "'subset_bis' ' p , P" := (sig (fun p => P)) (at level 200, p strict pattern). Notation "'subset_bis' p , P " := (sig (fun p => P)) - (at level 200, p ident). + (at level 200, p name). .. coqtop:: all @@ -675,18 +678,19 @@ the following: .. coqdoc:: Notation "{ x : A | P }" := (sig (fun x : A => P)) - (at level 0, x at level 99 as ident). + (at level 0, x at level 99 as name). This is so because the grammar also contains rules starting with :g:`{}` and followed by a term, such as the rule for the notation :g:`{ A } + { B }` for the constant :g:`sumbool` (see :ref:`specification`). -Then, in the rule, ``x ident`` is replaced by ``x at level 99 as ident`` meaning +Then, in the rule, ``x name`` is replaced by ``x at level 99 as name`` meaning that ``x`` is parsed as a term at level 99 (as done in the notation for -:g:`sumbool`), but that this term has actually to be an identifier. +:g:`sumbool`), but that this term has actually to be a name, i.e. an +identifier or :g:`_`. The notation :g:`{ x | P }` is already defined in the standard -library with the ``as ident`` :n:`@syntax_modifier`. We cannot redefine it but +library with the ``as name`` :n:`@syntax_modifier`. We cannot redefine it but one can define an alternative notation, say :g:`{ p such that P }`, using instead ``as pattern``. @@ -702,12 +706,12 @@ Then, the following works: Check {(x,y) such that x+y=0}. To enforce that the pattern should not be used for printing when it -is just an identifier, one could have said +is just a name, one could have said ``p at level 99 as strict pattern``. -Note also that in the absence of a ``as ident``, ``as strict pattern`` or +Note also that in the absence of a ``as name``, ``as strict pattern`` or ``as pattern`` :n:`@syntax_modifier`\s, the default is to consider sub-expressions occurring -in binding position and parsed as terms to be ``as ident``. +in binding position and parsed as terms to be ``as name``. Binders bound in the notation and parsed as general binders +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -768,7 +772,7 @@ binding position. Here is an example: Definition force n (P:nat -> Prop) := forall n', n' >= n -> P n'. Notation "▢_ n P" := (force n (fun n => P)) - (at level 0, n ident, P at level 9, format "▢_ n P"). + (at level 0, n name, P at level 9, format "▢_ n P"). .. coqtop:: all @@ -853,7 +857,8 @@ example showing a notation for a chain of equalities. It relies on an artificial expansion of the intended denotation so as to expose a ``φ(x, .. φ(y,t) ..)`` structure, with the drawback that if ever the beta-redexes are contracted, the notations stops to be used for -printing. +printing. Support for notations defined in this way should be considered +experimental. .. coqtop:: in @@ -946,16 +951,31 @@ position of :g:`x`: (at level 10, f global, a1, an at level 9). In addition to ``global``, one can restrict the syntax of a -sub-expression by using the entry names ``ident`` or ``pattern`` +sub-expression by using the entry names ``ident``, ``name`` or ``pattern`` already seen in :ref:`NotationsWithBinders`, even when the corresponding expression is not used as a binder in the right-hand side. E.g.: + .. todo: these two Set Warnings and the note should be removed when + ident is reactivated with its literal meaning. + +.. coqtop:: none + + Set Warnings "-deprecated-ident-entry". + .. coqtop:: in Notation "'apply_id' f a1 .. an" := (.. (f a1) .. an) (at level 10, f ident, a1, an at level 9). +.. coqtop:: none + + Set Warnings "+deprecated-ident-entry". + +.. note:: As of version 8.13, the entry ``ident`` is a deprecated + alias for ``name``. In the future, it is planned to strictly + parse an identifier (excluding :g:`_`). + .. _custom-entries: Custom entries @@ -1113,6 +1133,31 @@ gives a way to let any arbitrary expression which is not handled by the custom entry ``expr`` be parsed or printed by the main grammar of term up to the insertion of a pair of curly brackets. +Another special situation is when parsing global references or +identifiers. To indicate that a custom entry should parse identifiers, +use the following form: + +.. coqtop:: none + + Reset Initial. + Declare Custom Entry expr. + +.. coqtop:: in + + Notation "x" := x (in custom expr at level 0, x ident). + +Similarly, to indicate that a custom entry should parse global references +(i.e. qualified or non qualified identifiers), use the following form: + +.. coqtop:: none + + Reset Initial. + Declare Custom Entry expr. + +.. coqtop:: in + + Notation "x" := x (in custom expr at level 0, x global). + .. cmd:: Print Custom Grammar @ident :name: Print Custom Grammar @@ -1142,6 +1187,7 @@ Here are the syntax elements used by the various notation commands. | only printing | format @string {? @string } explicit_subentry ::= ident + | name | global | bigint | strict pattern {? at level @natural } @@ -1151,6 +1197,7 @@ Here are the syntax elements used by the various notation commands. | custom @ident {? at @level } {? @binder_interp } | pattern {? at level @natural } binder_interp ::= as ident + | as name | as pattern | as strict pattern level ::= level @natural @@ -1188,6 +1235,27 @@ Here are the syntax elements used by the various notation commands. due to legacy notation in the Coq standard library. It can be turned on with the ``-w disj-pattern-notation`` flag. +.. note:: + + As of version 8.13, the entry ``ident`` is a deprecated alias for + ``name``. In the future, it is planned to strictly parse an + identifier (to the exclusion of :g:`_`). If the intent was to use + ``ident`` as an identifier (excluding :g:`_`), just silence the warning with + :n:`Set Warnings "-deprecated-ident-entry"` and it should automatically + get its intended meaning in version 8.15. + + Similarly, ``as ident`` is a deprecated alias for ``as name``, which + will only accept an identifier in the future. If the + intent was to use ``as ident`` as an identifier + (excluding :g:`_`), just silence the warning with + :n:`Set Warnings "-deprecated-as-ident-kind"`. + + However, this deprecation does not apply to custom entries, where it + already denotes an identifier, as expected. + + .. todo: the note above should be removed at the end of deprecation + phase of ident + .. .. _Scopes: Notation scopes @@ -1642,6 +1710,8 @@ Number notations * :n:`Number.uint -> option @qualid__type` * :n:`Z -> @qualid__type` * :n:`Z -> option @qualid__type` + * :n:`Int63.int -> @qualid__type` + * :n:`Int63.int -> option @qualid__type` * :n:`Number.number -> @qualid__type` * :n:`Number.number -> option @qualid__type` @@ -1654,6 +1724,8 @@ Number notations * :n:`@qualid__type -> option Number.uint` * :n:`@qualid__type -> Z` * :n:`@qualid__type -> option Z` + * :n:`@qualid__type -> Int63.int` + * :n:`@qualid__type -> option Int63.int` * :n:`@qualid__type -> Number.number` * :n:`@qualid__type -> option Number.number` @@ -1669,7 +1741,8 @@ Number notations Note that only fully-reduced ground terms (terms containing only function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + sorts, primitive integers, primitive floats, primitive arrays and type + constants for primitive types) will be considered for printing. .. _number-string-via: @@ -1758,6 +1831,13 @@ Number notations only for integers or non-negative integers, and the given number has a fractional or exponent part or is negative. + .. exn:: int63 are only non-negative numbers. + + :n:`Int63.int` are unsigned integers. + + .. exn:: overflow in int63 literal @bigint + + The constant is too big to fit into an unsigned 63-bit integer :n:`Int63.int`. .. exn:: @qualid__parse should go from Number.int to @type or (option @type). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). @@ -1826,7 +1906,8 @@ String notations Note that only fully-reduced ground terms (terms containing only function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + sorts, primitive integers, primitive floats, primitive arrays and type + constants for primitive types) will be considered for printing. :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` works as for :ref:`number notations above <number-string-via>`. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7201dc6a0e..cbe526be68 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -278,11 +278,13 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Numbers/Cyclic/Abstract/CyclicAxioms.v theories/Numbers/Cyclic/Abstract/NZCyclic.v + theories/Numbers/Cyclic/Abstract/CarryType.v theories/Numbers/Cyclic/Abstract/DoubleType.v theories/Numbers/Cyclic/Int31/Cyclic31.v theories/Numbers/Cyclic/Int31/Ring31.v theories/Numbers/Cyclic/Int31/Int31.v theories/Numbers/Cyclic/Int63/Cyclic63.v + theories/Numbers/Cyclic/Int63/PrimInt63.v theories/Numbers/Cyclic/Int63/Int63.v theories/Numbers/Cyclic/Int63/Ring63.v theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -709,6 +711,7 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq811.v theories/Compat/Coq812.v theories/Compat/Coq813.v + theories/Compat/Coq814.v </dd> <dt> <b>Array</b>: diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 56464851ba..8f642df8fd 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -99,6 +99,11 @@ def make_math_node(latex, docname, nowrap): node['number'] = None return node +# To support any character in tacn, ... names. +# see https://github.com/coq/coq/pull/13564 +def make_id(tag): + return tag.replace(" ", "-") + class CoqObject(ObjectDescription): """A generic Coq object for Sphinx; all Coq objects are subclasses of this. @@ -200,7 +205,7 @@ class CoqObject(ObjectDescription): names_in_subdomain[name] = (self.env.docname, self.objtype, target_id) def _target_id(self, name): - return make_target(self.objtype, nodes.make_id(name)) + return make_target(self.objtype, make_id(name)) def _add_target(self, signode, name): """Register a link target ‘name’, pointing to signode.""" @@ -210,6 +215,16 @@ class CoqObject(ObjectDescription): signode['names'].append(name) signode['first'] = (not self.names) self._record_name(name, targetid, signode) + else: + # todo: make the following a real error or warning + # todo: then maybe the above "if" is not needed + names_in_subdomain = self.subdomain_data() + if name in names_in_subdomain: + try: + print("Duplicate", self.subdomain, "name: ", name) + except UnicodeEncodeError: # in CI + print("*** UnicodeEncodeError") + # self._warn_if_duplicate_name(names_in_subdomain, name, signode) return targetid def _add_index_entry(self, name, target): @@ -322,7 +337,7 @@ class VernacObject(NotationObject): annotation = "Command" def _name_from_signature(self, signature): - m = re.match(r"[a-zA-Z ]+", signature) + m = re.match(r"[a-zA-Z0-9_ ]+", signature) return m.group(0).strip() if m else None class VernacVariantObject(VernacObject): @@ -505,7 +520,7 @@ class ProductionObject(CoqObject): pass def _target_id(self, name): - return 'grammar-token-{}'.format(nodes.make_id(name[1])) + return make_id('grammar-token-{}'.format(name[1])) def _record_name(self, name, targetid, signode): env = self.state.document.settings.env @@ -533,7 +548,7 @@ class ProductionObject(CoqObject): row = nodes.container(classes=['prodn-row']) entry = nodes.container(classes=['prodn-cell-nonterminal']) if lhs != "": - target_name = 'grammar-token-' + nodes.make_id(lhs) + target_name = make_id('grammar-token-' + lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) # putting prodn-target on the target node won't appear in the tex file inline = nodes.inline(classes=['prodn-target']) @@ -862,7 +877,7 @@ class InferenceDirective(Directive): docname = self.state.document.settings.env.docname math_node = make_math_node(latex, docname, nowrap=False) - tid = nodes.make_id(title) + tid = make_id(title) target = nodes.target('', '', ids=['inference-' + tid]) self.state.document.note_explicit_target(target) @@ -1182,7 +1197,7 @@ def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, conte """ #pylint: disable=dangerous-default-value, unused-argument env = inliner.document.settings.env - targetid = nodes.make_id('grammar-token-{}'.format(text)) + targetid = make_id('grammar-token-{}'.format(text)) target = nodes.target('', '', ids=[targetid]) inliner.document.note_explicit_target(target) code = nodes.literal(rawtext, text, role=typ.lower()) @@ -1221,7 +1236,7 @@ def GlossaryDefRole(typ, rawtext, text, lineno, inliner, options={}, content=[]) msg = MSG.format(term, env.doc2path(std[key][0])) inliner.document.reporter.warning(msg, line=lineno) - targetid = nodes.make_id('term-{}'.format(term)) + targetid = make_id('term-{}'.format(term)) std[key] = (env.docname, targetid) target = nodes.target('', '', ids=[targetid], names=[term]) inliner.document.note_explicit_target(target) diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index 3021594183..388efd01d6 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -52,7 +52,7 @@ class CoqTop: self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") if not pexpect.utils.which(self.coqtop_bin): raise ValueError("coqtop binary not found: '{}'".format(self.coqtop_bin)) - self.args = (args or []) + ["-color", "on"] * color + self.args = (args or []) + ["-q"] + ["-color", "on"] * color self.coqtop = None def __enter__(self): diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 6c507e1d57..ba5876ff76 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -181,9 +181,6 @@ as a separate production. (Doesn't work recursively; splicing for both `OPTINREF` - applies the local `OPTINREF` edit to every nonterminal -`EXPAND` - expands LIST0, LIST1, LIST* ... SEP and OPT constructs into -new non-terminals - ### Local edits `DELETE <production>` - removes the specified production from the grammar @@ -201,6 +198,9 @@ that appear in the specified production: The current version handles a single USE_NT or ADD_OPT per EDIT. These symbols may appear in the middle of the production given in the EDIT. +`APPENDALL <symbols>` - inserts <symbols> at the end of every production in +<edited_nt>. + `INSERTALL <symbols>` - inserts <symbols> at the beginning of every production in <edited_nt>. @@ -212,10 +212,12 @@ that appear in the specified production: | WITH <newprod> ``` +`COPYALL <destination>` - creates a new nonterminal `<destination>` and copies +all the productions in the nonterminal to `<destination>`. + `MOVETO <destination> <production>` - moves the production to `<destination>` and, if needed, creates a new production <edited_nt> -> \<destination>. - `MOVEALLBUT <destination>` - moves all the productions in the nonterminal to `<destination>` *except* for the productions following the `MOVEALLBUT` production in the edit script (terminated only by the closing `]`). diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 816acba4c1..75b3260166 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -19,8 +19,22 @@ lglob: [ ] hint: [ +| REPLACE "Resolve" "->" LIST1 global OPT natural +| WITH "Resolve" [ "->" | "<-" ] LIST1 global OPT natural +| DELETE "Resolve" "<-" LIST1 global OPT natural +| REPLACE "Variables" "Transparent" +| WITH [ "Constants" | "Variables" ] [ "Transparent" | "Opaque" ] +| DELETE "Variables" "Opaque" +| DELETE "Constants" "Transparent" +| DELETE "Constants" "Opaque" +| REPLACE "Transparent" LIST1 global +| WITH [ "Transparent" | "Opaque" ] LIST1 global +| DELETE "Opaque" LIST1 global + | REPLACE "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic | WITH "Extern" natural OPT constr_pattern "=>" tactic +| INSERTALL "Hint" +| APPENDALL opt_hintbases ] (* todo: does ARGUMENT EXTEND make the symbol global? It is in both extraargs and extratactics *) @@ -149,6 +163,7 @@ DELETE: [ | ensure_fixannot | test_array_opening | test_array_closing +| test_variance_ident (* SSR *) | ssr_null_entry @@ -267,7 +282,7 @@ binder_constr: [ | REPLACE "if" term200 "is" ssr_dthen ssr_else | WITH "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR | DELETE "if" term200 "isn't" ssr_dthen ssr_else -| DELETE "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR (* todo: restore for SSR *) +| DELETE "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR (* todo: restore as "MOVETO term_if" for SSR *) | MOVETO term_fix "let" "fix" fix_decl "in" term200 | MOVETO term_cofix "let" "cofix" cofix_body "in" term200 | MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 @@ -597,6 +612,11 @@ univ_decl: [ | WITH "@{" LIST0 identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] +cumul_univ_decl: [ +| REPLACE "@{" LIST0 variance_identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] +| WITH "@{" LIST0 variance_identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +] + of_type: [ | DELETENT ] @@ -815,7 +835,10 @@ ltac_expr3: [ | REPLACE "abstract" ltac_expr2 "using" ident | WITH "abstract" ltac_expr2 OPT ( "using" ident ) | l3_tactic -| EDIT "do" ADD_OPT int_or_var ssrmmod ssrdotac ssrclauses TAG SSR +(* | EDIT "do" ADD_OPT nat_or_var ssrmmod ssrdotac ssrclauses TAG SSR *) +| DELETE "do" ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| DELETE "do" ssrortacarg ssrclauses (* SSR plugin *) +| DELETE "do" nat_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) | MOVEALLBUT ltac_builtins | l3_tactic | ltac_expr2 @@ -902,12 +925,13 @@ where: [ ] simple_tactic: [ -| DELETE "intros" -| REPLACE "intros" ne_intropatterns -| WITH "intros" intropatterns -| DELETE "eintros" -| REPLACE "eintros" ne_intropatterns -| WITH "eintros" intropatterns +| REPLACE "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "eauto" OPT nat_or_var auto_using hintbases +| REPLACE "debug" "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "debug" "eauto" OPT nat_or_var auto_using hintbases +| REPLACE "info_eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "info_eauto" OPT nat_or_var auto_using hintbases + | DELETE "autorewrite" "with" LIST1 preident clause | DELETE "autorewrite" "with" LIST1 preident clause "using" tactic | DELETE "autorewrite" "*" "with" LIST1 preident clause @@ -917,13 +941,13 @@ simple_tactic: [ | REPLACE "cofix" ident "with" LIST1 cofixdecl | WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) | DELETE "constructor" -| DELETE "constructor" int_or_var -| REPLACE "constructor" int_or_var "with" bindings -| WITH "constructor" OPT int_or_var OPT ( "with" bindings ) +| DELETE "constructor" nat_or_var +| REPLACE "constructor" nat_or_var "with" bindings +| WITH "constructor" OPT nat_or_var OPT ( "with" bindings ) | DELETE "econstructor" -| DELETE "econstructor" int_or_var -| REPLACE "econstructor" int_or_var "with" bindings -| WITH "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| DELETE "econstructor" nat_or_var +| REPLACE "econstructor" nat_or_var "with" bindings +| WITH "econstructor" OPT ( nat_or_var OPT ( "with" bindings ) ) | DELETE "dependent" "rewrite" orient constr | REPLACE "dependent" "rewrite" orient constr "in" hyp | WITH "dependent" "rewrite" orient constr OPT ( "in" hyp ) @@ -963,6 +987,12 @@ simple_tactic: [ | DELETE "intro" "after" hyp | DELETE "intro" "before" hyp | "intro" OPT ident OPT where +| DELETE "intros" +| REPLACE "intros" ne_intropatterns +| WITH "intros" intropatterns +| DELETE "eintros" +| REPLACE "eintros" ne_intropatterns +| WITH "eintros" intropatterns | DELETE "move" hyp "at" "top" | DELETE "move" hyp "at" "bottom" | DELETE "move" hyp "after" hyp @@ -991,6 +1021,9 @@ simple_tactic: [ | DELETE "unify" constr constr | REPLACE "unify" constr constr "with" preident | WITH "unify" constr constr OPT ( "with" preident ) +| DELETE "cutrewrite" orient constr +| REPLACE "cutrewrite" orient constr "in" hyp +| WITH "cutrewrite" orient constr OPT ( "in" hyp ) | DELETE "destauto" | REPLACE "destauto" "in" hyp | WITH "destauto" OPT ( "in" hyp ) @@ -1042,12 +1075,12 @@ simple_tactic: [ | DELETE "finish_timing" OPT string | REPLACE "finish_timing" "(" string ")" OPT string | WITH "finish_timing" OPT ( "(" string ")" ) OPT string -| REPLACE "hresolve_core" "(" ident ":=" constr ")" "at" int_or_var "in" constr -| WITH "hresolve_core" "(" ident ":=" constr ")" OPT ( "at" int_or_var ) "in" constr +| REPLACE "hresolve_core" "(" ident ":=" constr ")" "at" nat_or_var "in" constr +| WITH "hresolve_core" "(" ident ":=" constr ")" OPT ( "at" nat_or_var ) "in" constr | DELETE "hresolve_core" "(" ident ":=" constr ")" "in" constr -| EDIT "psatz_R" ADD_OPT int_or_var tactic -| EDIT "psatz_Q" ADD_OPT int_or_var tactic -| EDIT "psatz_Z" ADD_OPT int_or_var tactic +| EDIT "psatz_R" ADD_OPT nat_or_var tactic +| EDIT "psatz_Q" ADD_OPT nat_or_var tactic +| EDIT "psatz_Z" ADD_OPT nat_or_var tactic | REPLACE "subst" LIST1 hyp | WITH "subst" LIST0 hyp | DELETE "subst" @@ -1064,11 +1097,11 @@ simple_tactic: [ | DELETE "transparent_abstract" tactic3 | REPLACE "transparent_abstract" tactic3 "using" ident | WITH "transparent_abstract" ltac_expr3 OPT ( "using" ident ) -| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 preident ) -| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident -| DELETE "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident -| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var -| DELETE "typeclasses" "eauto" OPT int_or_var +| "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 preident ) +| DELETE "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" "bfs" OPT nat_or_var +| DELETE "typeclasses" "eauto" OPT nat_or_var (* in Tactic Notation: *) | "setoid_replace" constr "with" constr OPT ( "using" "relation" constr ) OPT ( "in" hyp ) OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) @@ -1136,6 +1169,10 @@ printable: [ | REPLACE [ "Sorted" | ] "Universes" OPT printunivs_subgraph OPT ne_string | WITH OPT "Sorted" "Universes" OPT printunivs_subgraph OPT ne_string | DELETE "Term" smart_global OPT univ_name_list (* readded in commands *) +| REPLACE "Hint" +| WITH "Hint" OPT [ "*" | smart_global ] +| DELETE "Hint" smart_global +| DELETE "Hint" "*" | INSERTALL "Print" ] @@ -1160,6 +1197,8 @@ scheme_kind: [ command: [ | REPLACE "Print" printable | WITH printable +| REPLACE "Hint" hint opt_hintbases +| WITH hint | "SubClass" ident_decl def_body | REPLACE "Ltac" LIST1 ltac_tacdef_body SEP "with" | WITH "Ltac" ltac_tacdef_body LIST0 ( "with" ltac_tacdef_body ) @@ -1239,6 +1278,9 @@ command: [ | REPLACE "Preterm" "of" ident | WITH "Preterm" OPT ( "of" ident ) | DELETE "Preterm" +| REPLACE "Proof" "using" section_var_expr "with" Pltac.tactic +| WITH "Proof" "using" section_subset_expr OPT [ "with" ltac_expr5 ] +| DELETE "Proof" "using" section_var_expr (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Remove" IDENT IDENT LIST1 table_value @@ -1438,8 +1480,8 @@ type_cstr: [ ] inductive_definition: [ -| REPLACE opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations -| WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations +| REPLACE opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations +| WITH opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations ] (* note that constructor -> identref constructor_type *) @@ -1575,9 +1617,12 @@ simple_reserv: [ in_clause: [ | DELETE in_clause' -| REPLACE LIST0 hypident_occ SEP "," "|-" concl_occ -| WITH LIST0 hypident_occ SEP "," OPT ( "|-" concl_occ ) -| DELETE LIST0 hypident_occ SEP "," +| REPLACE LIST1 hypident_occ SEP "," "|-" concl_occ +| WITH LIST1 hypident_occ SEP "," OPT ( "|-" concl_occ ) +| DELETE LIST1 hypident_occ SEP "," +| REPLACE "*" occs +| WITH concl_occ +(* todo: perhaps concl_occ should be "*" | "at" occs_nums *) ] ltac2_in_clause: [ @@ -1788,8 +1833,9 @@ tactic_notation_tactics: [ | "field_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) | "field_simplify_eq" OPT ( "[" LIST1 constr "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr5 (* todo: Not too keen on things like "with_power_flags" in tauto.ml, not easy to follow *) +| "now" ltac_expr5 | "nsatz" OPT ( "with" "radicalmax" ":=" constr "strategy" ":=" constr "parameters" ":=" constr "variables" ":=" constr ) -| "psatz" constr OPT int_or_var +| "psatz" constr OPT nat_or_var | "ring" OPT ( "[" LIST1 constr "]" ) | "ring_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) (* todo: ident was "hyp", worth keeping? *) ] @@ -1939,6 +1985,18 @@ tac2rec_fields: [ | LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 ] +int_or_var: [ +| REPLACE integer +| WITH [ integer | identref ] +| DELETE identref +] + +nat_or_var: [ +| REPLACE natural +| WITH [ natural | identref ] +| DELETE identref +] + ltac2_occs_nums: [ | DELETE LIST1 nat_or_anti (* Ltac2 plugin *) | REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) @@ -2384,6 +2442,33 @@ attribute: [ | DELETE "using" OPT attr_value ] +hypident: [ +(* todo: restore for SSR *) +| DELETE "(" "type" "of" ident ")" (* SSR plugin *) +| DELETE "(" "value" "of" ident ")" (* SSR plugin *) +] + +ref_or_pattern_occ: [ +| DELETE smart_global OPT occs +| DELETE constr OPT occs +| unfold_occ +| pattern_occ +] + +clause_dft_concl: [ +(* omit an OPT since clause_dft_concl is always OPT *) +| REPLACE OPT occs +| WITH occs +] + +occs_nums: [ +| EDIT ADD_OPT "-" LIST1 nat_or_var +] + +variance_identref: [ +| EDIT ADD_OPT variance identref +] + SPLICE: [ | clause | noedit_mode @@ -2523,6 +2608,7 @@ SPLICE: [ | eliminator (* todo: splice or not? *) | quoted_attributes (* todo: splice or not? *) | printable +| hint | only_parsing | record_fields | constructor_type @@ -2536,7 +2622,6 @@ SPLICE: [ | by_arg_tac | by_tactic | quantified_hypothesis -| nat_or_var | in_hyp_list | rename | export_token @@ -2604,9 +2689,18 @@ SPLICE: [ | syn_level | firstorder_rhs | firstorder_using +| hints_path_atom +| ref_or_pattern_occ +| cumul_ident_decl +| variance +| variance_identref ] (* end SPLICE *) RENAME: [ +| occurrences rewrite_occs +] + +RENAME: [ | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) @@ -2650,6 +2744,13 @@ RENAME: [ | ssrclauses ssr_in | ssrcpat ssrblockpat | constr_pattern one_pattern +| hints_path hints_regexp +| clause_dft_concl occurrences +| in_clause goal_occurrences +| unfold_occ reference_occs +| pattern_occ pattern_occs +| hypident_occ hyp_occs +| concl_occ concl_occs ] simple_tactic: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 92a745c863..dd7990368e 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -527,28 +527,28 @@ let rec edit_SELF nt cur_level next_level right_assoc inner prod = prod -let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) +let autoloaded_mlgs = [ (* productions from other mlgs are marked with TAGs *) "parsing/g_constr.mlg"; "parsing/g_prim.mlg"; - "vernac/g_vernac.mlg"; - "vernac/g_proofs.mlg"; - "toplevel/g_toplevel.mlg"; - "plugins/ltac/extraargs.mlg"; - "plugins/ltac/g_obligations.mlg"; + "plugins/btauto/g_btauto.mlg"; + "plugins/cc/g_congruence.mlg"; + "plugins/firstorder/g_ground.mlg"; "plugins/ltac/coretactics.mlg"; + "plugins/ltac/extraargs.mlg"; "plugins/ltac/extratactics.mlg"; - "plugins/ltac/profile_ltac_tactics.mlg"; "plugins/ltac/g_auto.mlg"; "plugins/ltac/g_class.mlg"; - "plugins/ltac/g_rewrite.mlg"; "plugins/ltac/g_eqdecide.mlg"; - "plugins/ltac/g_tactic.mlg"; "plugins/ltac/g_ltac.mlg"; - "plugins/btauto/g_btauto.mlg"; + "plugins/ltac/g_obligations.mlg"; + "plugins/ltac/g_rewrite.mlg"; + "plugins/ltac/g_tactic.mlg"; + "plugins/ltac/profile_ltac_tactics.mlg"; "plugins/rtauto/g_rtauto.mlg"; - "plugins/cc/g_congruence.mlg"; - "plugins/firstorder/g_ground.mlg"; "plugins/syntax/g_number_string.mlg"; + "toplevel/g_toplevel.mlg"; + "vernac/g_proofs.mlg"; + "vernac/g_vernac.mlg"; ] @@ -1020,7 +1020,7 @@ let rec gen_nt_name sym = good_name name (* create a new nt for LIST* or OPT with the specified name *) -let rec maybe_add_nt g insert_after name sym queue = +let maybe_add_nt g insert_after name sym queue = let empty = [Snterm "empty"] in let maybe_unwrap ?(multi=false) sym = match sym with @@ -1094,65 +1094,6 @@ let rec maybe_add_nt g insert_after name sym queue = end; new_nt -(* expand LIST*, OPT and add "empty" *) -(* todo: doesn't handle recursive expansions well, such as syntax_modifier_opt *) -and expand_rule g edited_nt queue = - let rule = NTMap.find edited_nt !g.map in - let insert_after = ref edited_nt in - let rec expand rule = - let rec aux syms res = - match syms with - | [] -> res - | sym0 :: tl -> - let new_sym = match sym0 with - | Sterm _ - | Snterm _ -> - sym0 - | Slist1 sym - | Slist1sep (sym, _) - | Slist0 sym - | Slist0sep (sym, _) - | Sopt sym -> - let name = gen_nt_name sym in - if name <> "" then begin - let new_nt = maybe_add_nt g insert_after name sym0 queue in - Snterm new_nt - end else sym0 - | Sparen slist -> Sparen (expand slist) - | Sprod slistlist -> - let has_empty = List.length (List.hd (List.rev slistlist)) = 0 in - let name = gen_nt_name sym0 in - if name <> "" then begin - let new_nt = maybe_add_nt g insert_after name - (if has_empty then (Sopt (Sprod (List.rev (List.tl (List.rev slistlist))) )) - else sym0) queue - in - Snterm new_nt - end else - Sprod (List.map expand slistlist) - | Sedit _ - | Sedit2 _ -> - sym0 (* these constructors not used here *) - in - aux tl (new_sym :: res) - in - List.rev (aux rule (if edited_nt <> "empty" && ematch rule [] then [Snterm "empty"] else [])) - in - let rule' = List.map expand rule in - g_update_prods g edited_nt rule' - -let expand_lists g = - (* todo: use Queue.of_seq w OCaml 4.07+ *) - let queue = Queue.create () in - List.iter (fun nt -> Queue.add nt queue) !g.order; - try - while true do - let nt = Queue.pop queue in - expand_rule g nt queue - done - with - | Queue.Empty -> () - let apply_merge g edit_map = List.iter (fun b -> let (from_nt, to_nt) = b in @@ -1213,10 +1154,6 @@ let edit_all_prods g op eprods = global_repl g [(Snterm nt)] [(Sopt (Snterm nt))] end) !g.order; true - | "EXPAND" -> - if List.length eprods > 1 || List.length (List.hd eprods) <> 0 then - error "'EXPAND:' expects a single empty production\n"; - expand_lists g; true | _ -> false let edit_single_prod g edit0 prods nt = @@ -1281,6 +1218,11 @@ let apply_edit_file g edits = with Not_found -> prods in let prods' = moveto nt dest_nt oprod prods in aux tl prods' add_nt + | [Snterm "COPYALL"; Snterm dest_nt] :: tl -> + if NTMap.mem dest_nt !g.map then + error "COPYALL target nonterminal `%s` already exists\n" dest_nt; + g_maybe_add g dest_nt prods; + aux tl prods add_nt | [Snterm "MOVEALLBUT"; Snterm dest_nt] :: tl -> List.iter (fun tlprod -> if not (List.mem tlprod prods) then @@ -1300,6 +1242,8 @@ let apply_edit_file g edits = aux tl (remove_prod [] prods nt) add_nt | (Snterm "INSERTALL" :: syms) :: tl -> aux tl (List.map (fun p -> syms @ p) prods) add_nt + | (Snterm "APPENDALL" :: syms) :: tl -> + aux tl (List.map (fun p -> p @ syms) prods) add_nt | (Snterm "PRINT" :: _) :: tl -> pr_prods nt prods; aux tl prods add_nt @@ -1395,56 +1339,6 @@ let nt_subset_in_orig_order g nts = let subset = StringSet.of_list nts in List.filter (fun nt -> StringSet.mem nt subset) !g.order -let print_chunk out g seen fmt title starts ends = - fprintf out "\n\n%s:\n%s\n" title header; - List.iter (fun start -> - let nts = (nt_closure g start ends) in - print_in_order out g fmt (nt_subset_in_orig_order g nts) !seen; - seen := StringSet.union !seen (StringSet.of_list nts)) - starts - -let print_chunks g out fmt () = - let seen = ref StringSet.empty in - print_chunk out g seen fmt "lconstr" ["lconstr"] ["binder_constr"; "tactic_expr5"]; - print_chunk out g seen fmt "Gallina syntax of terms" ["binder_constr"] ["tactic_expr5"]; - print_chunk out g seen fmt "Gallina The Vernacular" ["gallina"] ["tactic_expr5"]; - print_chunk out g seen fmt "intropattern_list_opt" ["intropattern_list"; "or_and_intropattern_loc"] ["operconstr"; "tactic_expr5"]; - print_chunk out g seen fmt "simple_tactic" ["simple_tactic"] - ["tactic_expr5"; "tactic_expr3"; "tactic_expr2"; "tactic_expr1"; "tactic_expr0"]; - - (*print_chunk out g seen fmt "Ltac" ["tactic_expr5"] [];*) - print_chunk out g seen fmt "Ltac" ["tactic_expr5"] ["tactic_expr4"]; - print_chunk out g seen fmt "Ltac 4" ["tactic_expr4"] ["tactic_expr3"; "tactic_expr2"]; - print_chunk out g seen fmt "Ltac 3" ["tactic_expr3"] ["tactic_expr2"]; - print_chunk out g seen fmt "Ltac 2" ["tactic_expr2"] ["tactic_expr1"]; - print_chunk out g seen fmt "Ltac 1" ["tactic_expr1"] ["tactic_expr0"]; - print_chunk out g seen fmt "Ltac 0" ["tactic_expr0"] []; - - - print_chunk out g seen fmt "command" ["command"] []; - print_chunk out g seen fmt "vernac_toplevel" ["vernac_toplevel"] []; - print_chunk out g seen fmt "vernac_control" ["vernac_control"] [] - - (* - let ssr_tops = ["ssr_dthen"; "ssr_else"; "ssr_mpat"; "ssr_rtype"] in - seen := StringSet.union !seen (StringSet.of_list ssr_tops); - - print_chunk out g seen fmt "ssrindex" ["ssrindex"] []; - print_chunk out g seen fmt "command" ["command"] []; - print_chunk out g seen fmt "binder_constr" ["binder_constr"] []; - (*print_chunk out g seen fmt "closed_binder" ["closed_binder"] [];*) - print_chunk out g seen fmt "gallina_ext" ["gallina_ext"] []; - (*print_chunk out g seen fmt "hloc" ["hloc"] [];*) - (*print_chunk out g seen fmt "hypident" ["hypident"] [];*) - print_chunk out g seen fmt "simple_tactic" ["simple_tactic"] []; - print_chunk out g seen fmt "tactic_expr" ["tactic_expr4"; "tactic_expr1"; "tactic_expr0"] []; - fprintf out "\n\nRemainder:\n"; - print_in_order g (List.filter (fun x -> not (StringSet.mem x !seen)) !g.order) StringSet.empty; - *) - - - (*seen := StringSet.diff !seen (StringSet.of_list ssr_tops);*) - (*print_chunk out g seen fmt "vernac_toplevel" ["vernac_toplevel"] [];*) let index_of str list = let rec index_of_r str list index = match list with @@ -1478,89 +1372,6 @@ let get_range g start end_ = let get_rangeset g start end_ = StringSet.of_list (get_range g start end_) -let print_dominated g = - let info nt rangeset exclude = - let reachable = StringSet.of_list (nt_closure g nt exclude) in - let unreachable = StringSet.of_list (nt_closure g (List.hd start_symbols) (nt::exclude)) in - let dominated = StringSet.diff reachable unreachable in - Printf.printf "For %s, 'attribute' is: reachable = %b, unreachable = %b, dominated = %b\n" nt - (StringSet.mem "attribute" reachable) - (StringSet.mem "attribute" unreachable) - (StringSet.mem "attribute" dominated); - Printf.printf " rangeset = %b excluded = %b\n" - (StringSet.mem "attribute" rangeset) - (List.mem "attribute" exclude); - reachable, dominated - in - let pr3 nt rangeset reachable dominated = - let missing = StringSet.diff dominated rangeset in - if not (StringSet.is_empty missing) then begin - Printf.printf "\nMissing in range for '%s':\n" nt; - StringSet.iter (fun nt -> Printf.printf " %s\n" nt) missing - end; - - let unneeded = StringSet.diff rangeset reachable in - if not (StringSet.is_empty unneeded) then begin - Printf.printf "\nUnneeded in range for '%s':\n" nt; - StringSet.iter (fun nt -> Printf.printf " %s\n" nt) unneeded - end; - in - let pr2 nt rangeset exclude = - let reachable, dominated = info nt rangeset exclude in - pr3 nt rangeset reachable dominated - in - let pr nt end_ = pr2 nt (get_rangeset g nt end_) [] in - - let ssr_ltac = ["ssr_first_else"; "ssrmmod"; "ssrdotac"; "ssrortacarg"; - "ssrparentacarg"] in - let ssr_tac = ["ssrintrosarg"; "ssrhintarg"; "ssrtclarg"; "ssrseqarg"; "ssrmovearg"; - "ssrrpat"; "ssrclauses"; "ssrcasearg"; "ssrarg"; "ssrapplyarg"; "ssrexactarg"; - "ssrcongrarg"; "ssrterm"; "ssrrwargs"; "ssrunlockargs"; "ssrfixfwd"; "ssrcofixfwd"; - "ssrfwdid"; "ssrposefwd"; "ssrsetfwd"; "ssrdgens"; "ssrhavefwdwbinders"; "ssrhpats_nobs"; - "ssrhavefwd"; "ssrsufffwd"; "ssrwlogfwd"; "ssrhint"; "ssrclear"; "ssr_idcomma"; - "ssrrwarg"; "ssrintros_ne"; "ssrhint3arg" ] @ ssr_ltac in - let ssr_cmd = ["ssr_modlocs"; "ssr_search_arg"; "ssrhintref"; "ssrhintref_list"; - "ssrviewpos"; "ssrviewposspc"] in - let ltac = ["ltac_expr"; "ltac_expr0"; "ltac_expr1"; "ltac_expr2"; "ltac_expr3"] in - let term = ["term"; "term0"; "term1"; "term10"; "term100"; "term9"; - "pattern"; "pattern0"; "pattern1"; "pattern10"] in - - pr "term" "constr"; - - let ltac_rangeset = List.fold_left StringSet.union StringSet.empty - [(get_rangeset g "ltac_expr" "tactic_atom"); - (get_rangeset g "toplevel_selector" "range_selector"); - (get_rangeset g "ltac_match_term" "match_pattern"); - (get_rangeset g "ltac_match_goal" "match_pattern_opt")] in - pr2 "ltac_expr" ltac_rangeset ("simple_tactic" :: ssr_tac); - - let dec_vern_rangeset = get_rangeset g "decorated_vernac" "opt_coercion" in - let dev_vern_excl = - ["gallina_ext"; "command"; "tactic_mode"; "syntax"; "command_entry"] @ term @ ltac @ ssr_tac in - pr2 "decorated_vernac" dec_vern_rangeset dev_vern_excl; - - let simp_tac_range = get_rangeset g "simple_tactic" "hypident_occ_list_comma" in - let simp_tac_excl = ltac @ ssr_tac in - pr2 "simple_tactic" simp_tac_range simp_tac_excl; - - let cmd_range = get_rangeset g "command" "int_or_id_list_opt" in - let cmd_excl = ssr_tac @ ssr_cmd in - pr2 "command" cmd_range cmd_excl; - - let syn_range = get_rangeset g "syntax" "constr_as_binder_kind" in - let syn_excl = ssr_tac @ ssr_cmd in - pr2 "syntax" syn_range syn_excl; - - let gext_range = get_rangeset g "gallina_ext" "Structure_opt" in - let gext_excl = ssr_tac @ ssr_cmd in - pr2 "gallina_ext" gext_range gext_excl; - - let qry_range = get_rangeset g "query_command" "searchabout_query_list" in - let qry_excl = ssr_tac @ ssr_cmd in - pr2 "query_command" qry_range qry_excl - - (* todo: tactic_mode *) - let check_range_consistency g start end_ = let defined_list = get_range g start end_ in let defined = StringSet.of_list defined_list in @@ -1913,13 +1724,8 @@ let process_rst g file args seen tac_prods cmd_prods = end in -(* let skip_files = ["doc/sphinx/proof-engine/ltac.rst"; "doc/sphinx/proof-engine/ltac2.rst";*) -(* "doc/sphinx/proof-engine/ssreflect-proof-language.rst"]*) -(* in*) - let cmd_exclude_files = [ "doc/sphinx/proof-engine/ssreflect-proof-language.rst"; - "doc/sphinx/proofs/automatic-tactics/auto.rst"; "doc/sphinx/proofs/writing-proofs/rewriting.rst"; "doc/sphinx/proofs/writing-proofs/proof-mode.rst"; "doc/sphinx/proof-engine/tactics.rst"; @@ -2101,7 +1907,6 @@ let process_grammar args = close_out out; finish_with_file (dir "orderedGrammar") args; (* check_singletons g*) -(* print_dominated g*) let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in let args = { args with no_update = false } in (* always update rsts in place for now *) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 03a20d621b..ccf38d2c15 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -342,6 +342,21 @@ closed_binder: [ | [ "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 @@ -875,10 +890,29 @@ univ_decl: [ | "@{" LIST0 identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] ] +variance: [ +| "+" +| "=" +| "*" +] + +variance_identref: [ +| identref +| test_variance_ident variance identref +] + +cumul_univ_decl: [ +| "@{" LIST0 variance_identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] +] + ident_decl: [ | identref OPT univ_decl ] +cumul_ident_decl: [ +| identref OPT cumul_univ_decl +] + finite_token: [ | "Inductive" | "CoInductive" @@ -918,7 +952,7 @@ opt_constructors_or_fields: [ ] inductive_definition: [ -| opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations +| opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations ] constructors_or_record: [ @@ -1420,6 +1454,7 @@ syntax_modifiers: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "binder" @@ -1440,6 +1475,7 @@ at_level_opt: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1479,11 +1515,11 @@ simple_tactic: [ | "right" "with" bindings | "eright" "with" bindings | "constructor" -| "constructor" int_or_var -| "constructor" int_or_var "with" bindings +| "constructor" nat_or_var +| "constructor" nat_or_var "with" bindings | "econstructor" -| "econstructor" int_or_var -| "econstructor" int_or_var "with" bindings +| "econstructor" nat_or_var +| "econstructor" nat_or_var "with" bindings | "specialize" constr_with_bindings | "specialize" constr_with_bindings "as" simple_intropattern | "symmetry" @@ -1547,6 +1583,8 @@ simple_tactic: [ | "simple" "injection" destruction_arg | "dependent" "rewrite" orient constr | "dependent" "rewrite" orient constr "in" hyp +| "cutrewrite" orient constr +| "cutrewrite" orient constr "in" hyp | "decompose" "sum" constr | "decompose" "record" constr | "absurd" constr @@ -1582,9 +1620,9 @@ simple_tactic: [ | "generalize_eqs_vars" hyp | "dependent" "generalize_eqs_vars" hyp | "specialize_eqs" hyp -| "hresolve_core" "(" ident ":=" constr ")" "at" int_or_var "in" constr +| "hresolve_core" "(" ident ":=" constr ")" "at" nat_or_var "in" constr | "hresolve_core" "(" ident ":=" constr ")" "in" constr -| "hget_evar" int_or_var +| "hget_evar" nat_or_var | "destauto" | "destauto" "in" hyp | "transparent_abstract" tactic3 @@ -1617,25 +1655,25 @@ simple_tactic: [ | "trivial" auto_using hintbases | "info_trivial" auto_using hintbases | "debug" "trivial" auto_using hintbases -| "auto" OPT int_or_var auto_using hintbases -| "info_auto" OPT int_or_var auto_using hintbases -| "debug" "auto" OPT int_or_var auto_using hintbases -| "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "new" "auto" OPT int_or_var auto_using hintbases -| "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "dfs" "eauto" OPT int_or_var auto_using hintbases -| "bfs" "eauto" OPT int_or_var auto_using hintbases +| "auto" OPT nat_or_var auto_using hintbases +| "info_auto" OPT nat_or_var auto_using hintbases +| "debug" "auto" OPT nat_or_var auto_using hintbases +| "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "new" "auto" OPT nat_or_var auto_using hintbases +| "debug" "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "info_eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| "dfs" "eauto" OPT nat_or_var auto_using hintbases +| "bfs" "eauto" OPT nat_or_var auto_using hintbases | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" hyp | "autounfold_one" hintbases | "unify" constr constr | "unify" constr constr "with" preident | "convert_concl_no_check" constr -| "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident -| "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident -| "typeclasses" "eauto" "bfs" OPT int_or_var -| "typeclasses" "eauto" OPT int_or_var +| "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident +| "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident +| "typeclasses" "eauto" "bfs" OPT nat_or_var +| "typeclasses" "eauto" OPT nat_or_var | "head_of_constr" ident constr | "not_evar" constr | "is_ground" constr @@ -1734,7 +1772,7 @@ simple_tactic: [ | "restart_timer" OPT string | "finish_timing" OPT string | "finish_timing" "(" string ")" OPT string -| "psatz_Z" int_or_var tactic (* micromega plugin *) +| "psatz_Z" nat_or_var tactic (* micromega plugin *) | "psatz_Z" tactic (* micromega plugin *) | "xlia" tactic (* micromega plugin *) | "xnlia" tactic (* micromega plugin *) @@ -1745,9 +1783,9 @@ simple_tactic: [ | "sos_R" tactic (* micromega plugin *) | "lra_Q" tactic (* micromega plugin *) | "lra_R" tactic (* micromega plugin *) -| "psatz_R" int_or_var tactic (* micromega plugin *) +| "psatz_R" nat_or_var tactic (* micromega plugin *) | "psatz_R" tactic (* micromega plugin *) -| "psatz_Q" int_or_var tactic (* micromega plugin *) +| "psatz_Q" nat_or_var tactic (* micromega plugin *) | "psatz_Q" tactic (* micromega plugin *) | "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) @@ -1912,8 +1950,9 @@ in_clause: [ | in_clause' | "*" occs | "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," +| "|-" concl_occ +| LIST1 hypident_occ SEP "," "|-" concl_occ +| LIST1 hypident_occ SEP "," ] test_lpar_id_colon: [ @@ -2022,8 +2061,8 @@ ltac_expr4: [ ltac_expr3: [ | "try" ltac_expr3 -| "do" int_or_var ltac_expr3 -| "timeout" int_or_var ltac_expr3 +| "do" nat_or_var ltac_expr3 +| "timeout" nat_or_var ltac_expr3 | "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 @@ -2036,7 +2075,7 @@ ltac_expr3: [ | ltac_expr2 | "do" ssrmmod ssrdotac ssrclauses (* SSR plugin *) | "do" ssrortacarg ssrclauses (* SSR plugin *) -| "do" int_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| "do" nat_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) | "abstract" ssrdgens (* SSR plugin *) ] @@ -2491,7 +2530,7 @@ in_hyp_list: [ ] in_hyp_as: [ -| "in" id_or_meta as_ipat +| "in" LIST1 [ id_or_meta as_ipat ] SEP "," | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 0209cf762a..d950b32160 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -436,7 +436,7 @@ univ_decl: [ ] cumul_univ_decl: [ -| "@{" LIST0 ( OPT [ "=" | "+" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +| "@{" LIST0 ( OPT [ "+" | "=" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] univ_constraint: [ @@ -512,6 +512,21 @@ binder: [ | "'" pattern0 ] +one_open_binder: [ +| name +| name ":" term +| one_closed_binder +] + +one_closed_binder: [ +| "(" name ":" term ")" +| "{" name "}" +| "{" name ":" term "}" +| "[" name "]" +| "[" name ":" term "]" +| "'" pattern0 +] + implicit_binders: [ | "{" LIST1 name OPT ( ":" type ) "}" | "[" LIST1 name OPT ( ":" type ) "]" @@ -614,16 +629,16 @@ reduce: [ red_expr: [ | "red" | "hnf" -| "simpl" OPT delta_flag OPT ref_or_pattern_occ +| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] | "cbv" OPT strategy_flag | "cbn" OPT strategy_flag | "lazy" OPT strategy_flag | "compute" OPT delta_flag -| "vm_compute" OPT ref_or_pattern_occ -| "native_compute" OPT ref_or_pattern_occ -| "unfold" LIST1 unfold_occ SEP "," +| "vm_compute" OPT [ reference_occs | pattern_occs ] +| "native_compute" OPT [ reference_occs | pattern_occs ] +| "unfold" LIST1 reference_occs SEP "," | "fold" LIST1 one_term -| "pattern" LIST1 pattern_occ SEP "," +| "pattern" LIST1 pattern_occs SEP "," | ident ] @@ -646,26 +661,11 @@ red_flag: [ | "delta" OPT delta_flag ] -ref_or_pattern_occ: [ -| reference OPT ( "at" occs_nums ) -| one_term OPT ( "at" occs_nums ) -] - -occs_nums: [ -| LIST1 [ natural | ident ] -| "-" LIST1 [ natural | ident ] -] - -int_or_var: [ -| integer -| ident -] - -unfold_occ: [ +reference_occs: [ | reference OPT ( "at" occs_nums ) ] -pattern_occ: [ +pattern_occs: [ | one_term OPT ( "at" occs_nums ) ] @@ -700,7 +700,7 @@ field_def: [ ] inductive_definition: [ -| OPT ">" cumul_ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +| OPT ">" ident OPT cumul_univ_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations ] constructors_or_record: [ @@ -712,10 +712,6 @@ constructor: [ | ident LIST0 binder OPT of_type ] -cumul_ident_decl: [ -| ident OPT cumul_univ_decl -] - filtered_import: [ | qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] ] @@ -896,9 +892,7 @@ command: [ | "Print" "Typing" "Flags" | "Print" "Tables" | "Print" "Options" -| "Print" "Hint" -| "Print" "Hint" reference -| "Print" "Hint" "*" +| "Print" "Hint" OPT [ "*" | reference ] | "Print" "HintDb" ident | "Print" "Scopes" | "Print" "Scope" scope_name @@ -953,7 +947,6 @@ command: [ | "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) | "Proof" -| "Proof" "using" section_var_expr | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] @@ -978,7 +971,6 @@ command: [ | "Guarded" | "Create" "HintDb" ident OPT "discriminated" | "Remove" "Hints" LIST1 qualid OPT ( ":" LIST1 ident ) -| "Hint" hint OPT ( ":" LIST1 ident ) | "Comments" LIST0 [ one_term | string | natural ] | "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info | "Declare" "Scope" scope_name @@ -1025,7 +1017,7 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) +| "Hint" "Cut" "[" hints_regexp "]" OPT ( ":" LIST1 ident ) | "Prenex" "Implicits" LIST1 qualid (* SSR plugin *) | "Print" "Hint" "View" OPT ssrviewpos (* SSR plugin *) | "Hint" "View" OPT ssrviewpos LIST1 ( one_term OPT ( "|" natural ) ) (* SSR plugin *) @@ -1034,7 +1026,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 qualid | "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" [ "bfs" | "dfs" ] ")" ) OPT natural | "Proof" "with" ltac_expr OPT [ "using" section_var_expr ] -| "Proof" "using" section_var_expr "with" ltac_expr +| "Proof" "using" section_var_expr OPT [ "with" ltac_expr ] | "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid @@ -1137,6 +1129,15 @@ command: [ | "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) | "Print" "Ltac2" qualid (* Ltac2 plugin *) +| "Hint" "Resolve" LIST1 [ qualid | one_term ] OPT hint_info OPT ( ":" LIST1 ident ) +| "Hint" "Resolve" [ "->" | "<-" ] LIST1 qualid OPT natural OPT ( ":" LIST1 ident ) +| "Hint" "Immediate" LIST1 [ qualid | one_term ] OPT ( ":" LIST1 ident ) +| "Hint" [ "Constants" | "Variables" ] [ "Transparent" | "Opaque" ] OPT ( ":" LIST1 ident ) +| "Hint" [ "Transparent" | "Opaque" ] LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Mode" qualid LIST1 [ "+" | "!" | "-" ] OPT ( ":" LIST1 ident ) +| "Hint" "Unfold" LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Constructors" LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Extern" natural OPT one_pattern "=>" ltac_expr OPT ( ":" LIST1 ident ) | "Time" sentence | "Redirect" string sentence | "Timeout" natural sentence @@ -1200,23 +1201,6 @@ univ_name_list: [ | "@{" LIST0 name "}" ] -hint: [ -| "Resolve" LIST1 [ qualid | one_term ] OPT hint_info -| "Resolve" "->" LIST1 qualid OPT natural -| "Resolve" "<-" LIST1 qualid OPT natural -| "Immediate" LIST1 [ qualid | one_term ] -| "Variables" "Transparent" -| "Variables" "Opaque" -| "Constants" "Transparent" -| "Constants" "Opaque" -| "Transparent" LIST1 qualid -| "Opaque" LIST1 qualid -| "Mode" qualid LIST1 [ "+" | "!" | "-" ] -| "Unfold" LIST1 qualid -| "Constructors" LIST1 qualid -| "Extern" natural OPT one_pattern "=>" ltac_expr -] - tacdef_body: [ | qualid LIST0 name [ ":=" | "::=" ] ltac_expr ] @@ -1270,28 +1254,37 @@ constr_with_bindings_arg: [ | OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) ] -clause_dft_concl: [ -| "in" in_clause -| OPT ( "at" occs_nums ) +occurrences: [ +| "at" occs_nums +| "in" goal_occurrences ] -in_clause: [ -| "*" OPT ( "at" occs_nums ) -| "*" "|-" OPT concl_occ -| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +occs_nums: [ +| OPT "-" LIST1 nat_or_var +] + +nat_or_var: [ +| [ natural | ident ] ] -hypident_occ: [ +goal_occurrences: [ +| LIST1 hyp_occs SEP "," OPT ( "|-" OPT concl_occs ) +| "*" "|-" OPT concl_occs +| "|-" OPT concl_occs +| OPT concl_occs +] + +hyp_occs: [ | hypident OPT ( "at" occs_nums ) ] hypident: [ | ident -| "(" "type" "of" ident ")" (* SSR plugin *) -| "(" "value" "of" ident ")" (* SSR plugin *) +| "(" "type" "of" ident ")" +| "(" "value" "of" ident ")" ] -concl_occ: [ +concl_occs: [ | "*" OPT ( "at" occs_nums ) ] @@ -1540,15 +1533,15 @@ number_string_via: [ | "via" qualid "mapping" "[" LIST1 [ qualid "=>" qualid | "[" qualid "]" "=>" qualid ] SEP "," "]" ] -hints_path: [ -| "(" hints_path ")" -| hints_path "*" -| "emp" -| "eps" -| hints_path "|" hints_path +hints_regexp: [ | LIST1 qualid | "_" -| hints_path hints_path +| hints_regexp "|" hints_regexp +| hints_regexp hints_regexp +| hints_regexp "*" +| "emp" +| "eps" +| "(" hints_regexp ")" ] class: [ @@ -1574,6 +1567,7 @@ syntax_modifier: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "strict" "pattern" OPT ( "at" "level" natural ) @@ -1586,6 +1580,7 @@ explicit_subentry: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1620,10 +1615,10 @@ simple_tactic: [ | "eleft" OPT ( "with" bindings ) | "right" OPT ( "with" bindings ) | "eright" OPT ( "with" bindings ) -| "constructor" OPT int_or_var OPT ( "with" bindings ) -| "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| "constructor" OPT nat_or_var OPT ( "with" bindings ) +| "econstructor" OPT ( nat_or_var OPT ( "with" bindings ) ) | "specialize" one_term OPT ( "with" bindings ) OPT ( "as" simple_intropattern ) -| "symmetry" OPT ( "in" in_clause ) +| "symmetry" OPT ( "in" goal_occurrences ) | "split" OPT ( "with" bindings ) | "esplit" OPT ( "with" bindings ) | "exists" OPT ( LIST1 bindings SEP "," ) @@ -1641,15 +1636,15 @@ simple_tactic: [ | "clear" "-" LIST1 ident | "clearbody" LIST1 ident | "generalize" "dependent" one_term -| "replace" one_term "with" one_term OPT clause_dft_concl OPT ( "by" ltac_expr3 ) -| "replace" OPT [ "->" | "<-" ] one_term OPT clause_dft_concl +| "replace" one_term "with" one_term OPT occurrences OPT ( "by" ltac_expr3 ) +| "replace" OPT [ "->" | "<-" ] one_term OPT occurrences | "setoid_replace" one_term "with" one_term OPT ( "using" "relation" one_term ) OPT ( "in" ident ) OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) | OPT ( [ natural | "[" ident "]" ] ":" ) "{" | bullet | "}" | "try" ltac_expr3 -| "do" int_or_var ltac_expr3 -| "timeout" int_or_var ltac_expr3 +| "do" nat_or_var ltac_expr3 +| "timeout" nat_or_var ltac_expr3 | "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 @@ -1658,8 +1653,6 @@ simple_tactic: [ | "infoH" ltac_expr3 | "abstract" ltac_expr2 OPT ( "using" ident ) | "only" selector ":" ltac_expr3 -| "do" "[" ssrortacs "]" OPT ssr_in (* SSR plugin *) -| "do" OPT int_or_var ssrmmod [ ltac_expr3 | "[" ssrortacs "]" (* SSR plugin *) ] OPT ssr_in (* SSR plugin *) | "tryif" ltac_expr "then" ltac_expr "else" ltac_expr2 | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" @@ -1692,13 +1685,14 @@ simple_tactic: [ | "einjection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) | "simple" "injection" OPT destruction_arg | "dependent" "rewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) +| "cutrewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) | "decompose" "sum" one_term | "decompose" "record" one_term | "absurd" one_term | "contradiction" OPT ( one_term OPT ( "with" bindings ) ) -| "autorewrite" OPT "*" "with" LIST1 ident OPT clause_dft_concl OPT ( "using" ltac_expr ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" occurrences OPT ( "by" ltac_expr3 ) ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" occurrences "in" ident OPT ( "by" ltac_expr3 ) +| "autorewrite" OPT "*" "with" LIST1 ident OPT occurrences OPT ( "using" ltac_expr ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs OPT ( "by" ltac_expr3 ) ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" rewrite_occs "in" ident OPT ( "by" ltac_expr3 ) | "refine" one_term | "simple" "refine" one_term | "notypeclasses" "refine" one_term @@ -1718,8 +1712,8 @@ simple_tactic: [ | "generalize_eqs_vars" ident | "dependent" "generalize_eqs_vars" ident | "specialize_eqs" ident -| "hresolve_core" "(" ident ":=" one_term ")" OPT ( "at" int_or_var ) "in" one_term -| "hget_evar" int_or_var +| "hresolve_core" "(" ident ":=" one_term ")" OPT ( "at" nat_or_var ) "in" one_term +| "hget_evar" nat_or_var | "destauto" OPT ( "in" ident ) | "transparent_abstract" ltac_expr3 OPT ( "using" ident ) | "constr_eq" one_term one_term @@ -1756,20 +1750,20 @@ simple_tactic: [ | "trivial" OPT auto_using OPT hintbases | "info_trivial" OPT auto_using OPT hintbases | "debug" "trivial" OPT auto_using OPT hintbases -| "auto" OPT int_or_var OPT auto_using OPT hintbases -| "info_auto" OPT int_or_var OPT auto_using OPT hintbases -| "debug" "auto" OPT int_or_var OPT auto_using OPT hintbases -| "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "new" "auto" OPT int_or_var OPT auto_using OPT hintbases -| "debug" "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "info_eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases -| "dfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases -| "bfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases -| "autounfold" OPT hintbases OPT clause_dft_concl +| "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "info_auto" OPT nat_or_var OPT auto_using OPT hintbases +| "debug" "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "new" "auto" OPT nat_or_var OPT auto_using OPT hintbases +| "debug" "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "info_eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "dfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "bfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "autounfold" OPT hintbases OPT occurrences | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) | "convert_concl_no_check" one_term -| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 ident ) +| "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 ident ) | "head_of_constr" ident one_term | "not_evar" one_term | "is_ground" one_term @@ -1779,8 +1773,8 @@ simple_tactic: [ | "rewrite_strat" rewstrategy OPT ( "in" ident ) | "rewrite_db" ident OPT ( "in" ident ) | "substitute" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) -| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) OPT ( "at" occurrences ) OPT ( "in" ident ) -| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) "in" ident "at" occurrences +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) OPT ( "at" rewrite_occs ) OPT ( "in" ident ) +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) "in" ident "at" rewrite_occs | "setoid_symmetry" OPT ( "in" ident ) | "setoid_reflexivity" | "setoid_transitivity" one_term @@ -1803,10 +1797,10 @@ simple_tactic: [ | "pose" one_term OPT as_name | "epose" bindings_with_parameters | "epose" one_term OPT as_name -| "set" bindings_with_parameters OPT clause_dft_concl -| "set" one_term OPT as_name OPT clause_dft_concl -| "eset" bindings_with_parameters OPT clause_dft_concl -| "eset" one_term OPT as_name OPT clause_dft_concl +| "set" bindings_with_parameters OPT occurrences +| "set" one_term OPT as_name OPT occurrences +| "eset" bindings_with_parameters OPT occurrences +| "eset" one_term OPT as_name OPT occurrences | "remember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all | "eremember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all | "assert" "(" ident ":=" term ")" @@ -1824,32 +1818,32 @@ simple_tactic: [ | "enough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) | "eenough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) | "generalize" one_term OPT ( LIST1 one_term ) -| "generalize" one_term OPT ( "at" occs_nums ) OPT as_name LIST0 [ "," pattern_occ OPT as_name ] +| "generalize" one_term OPT ( "at" occs_nums ) OPT as_name LIST0 [ "," pattern_occs OPT as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list -| "rewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) -| "erewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) +| "rewrite" LIST1 oriented_rewriter SEP "," OPT occurrences OPT ( "by" ltac_expr3 ) +| "erewrite" LIST1 oriented_rewriter SEP "," OPT occurrences OPT ( "by" ltac_expr3 ) | "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] [ ident | natural ] OPT as_or_and_ipat OPT [ "with" one_term ] | "simple" "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion_clear" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion" [ ident | natural ] "using" one_term OPT ( "in" LIST1 ident ) -| "red" OPT clause_dft_concl -| "hnf" OPT clause_dft_concl -| "simpl" OPT delta_flag OPT ref_or_pattern_occ OPT clause_dft_concl -| "cbv" OPT strategy_flag OPT clause_dft_concl -| "cbn" OPT strategy_flag OPT clause_dft_concl -| "lazy" OPT strategy_flag OPT clause_dft_concl -| "compute" OPT delta_flag OPT clause_dft_concl -| "vm_compute" OPT ref_or_pattern_occ OPT clause_dft_concl -| "native_compute" OPT ref_or_pattern_occ OPT clause_dft_concl -| "unfold" LIST1 unfold_occ SEP "," OPT clause_dft_concl -| "fold" LIST1 one_term OPT clause_dft_concl -| "pattern" LIST1 pattern_occ SEP "," OPT clause_dft_concl -| "change" conversion OPT clause_dft_concl -| "change_no_check" conversion OPT clause_dft_concl +| "red" OPT occurrences +| "hnf" OPT occurrences +| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] OPT occurrences +| "cbv" OPT strategy_flag OPT occurrences +| "cbn" OPT strategy_flag OPT occurrences +| "lazy" OPT strategy_flag OPT occurrences +| "compute" OPT delta_flag OPT occurrences +| "vm_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences +| "native_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences +| "unfold" LIST1 reference_occs SEP "," OPT occurrences +| "fold" LIST1 one_term OPT occurrences +| "pattern" LIST1 pattern_occs SEP "," OPT occurrences +| "change" conversion OPT occurrences +| "change_no_check" conversion OPT occurrences | "btauto" | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) @@ -1859,7 +1853,7 @@ simple_tactic: [ | "functional" "inversion" [ ident | natural ] OPT qualid (* funind plugin *) | "functional" "induction" term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) | "soft" "functional" "induction" LIST1 one_term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) -| "psatz_Z" OPT int_or_var ltac_expr +| "psatz_Z" OPT nat_or_var ltac_expr | "xlia" ltac_expr (* micromega plugin *) | "xnlia" ltac_expr (* micromega plugin *) | "xnra" ltac_expr (* micromega plugin *) @@ -1869,8 +1863,8 @@ simple_tactic: [ | "sos_R" ltac_expr (* micromega plugin *) | "lra_Q" ltac_expr (* micromega plugin *) | "lra_R" ltac_expr (* micromega plugin *) -| "psatz_R" OPT int_or_var ltac_expr -| "psatz_Q" OPT int_or_var ltac_expr +| "psatz_R" OPT nat_or_var ltac_expr +| "psatz_Q" OPT nat_or_var ltac_expr | "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) | "zify_saturate" (* micromega plugin *) @@ -1941,8 +1935,9 @@ simple_tactic: [ | "field_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) | "field_simplify_eq" OPT ( "[" LIST1 one_term "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr +| "now" ltac_expr | "nsatz" OPT ( "with" "radicalmax" ":=" one_term "strategy" ":=" one_term "parameters" ":=" one_term "variables" ":=" one_term ) -| "psatz" one_term OPT int_or_var +| "psatz" one_term OPT nat_or_var | "ring" OPT ( "[" LIST1 one_term "]" ) | "ring_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) | "match" ltac2_expr5 "with" OPT ltac2_branches "end" @@ -1993,19 +1988,24 @@ induction_clause_list: [ | LIST1 induction_clause SEP "," OPT ( "using" one_term OPT ( "with" bindings ) ) OPT opt_clause ] -induction_clause: [ -| destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause -] - opt_clause: [ -| "in" in_clause +| "in" goal_occurrences | "at" occs_nums ] +induction_clause: [ +| destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause +] + auto_using: [ | "using" LIST1 one_term SEP "," ] +hintbases: [ +| "with" "*" +| "with" LIST1 ident +] + or_and_intropattern: [ | "[" intropattern_or_list_or "]" | "(" LIST0 simple_intropattern SEP "," ")" @@ -2050,6 +2050,10 @@ bindings: [ | LIST1 one_term ] +int_or_var: [ +| [ integer | ident ] +] + comparison: [ | "=" | "<" @@ -2058,11 +2062,6 @@ comparison: [ | ">=" ] -hintbases: [ -| "with" "*" -| "with" LIST1 ident -] - bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] @@ -2431,11 +2430,11 @@ tac2mode: [ ] clause_dft_all: [ -| "in" in_clause +| "in" goal_occurrences ] in_hyp_as: [ -| "in" ident OPT as_ipat +| "in" LIST1 [ ident OPT as_ipat ] SEP "," ] simple_binder: [ @@ -2465,7 +2464,7 @@ func_scheme_def: [ | ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) ] -occurrences: [ +rewrite_occs: [ | LIST1 integer | ident ] diff --git a/dune-project b/dune-project index 1265c993b7..1187c58449 100644 --- a/dune-project +++ b/dune-project @@ -5,7 +5,10 @@ (formatting (enabled_for ocaml)) -(generate_opam_files true) +; Pending on dune 2.8 as to avoid bug with dune subst +; see https://github.com/ocaml/dune/pull/3879 and +; https://github.com/ocaml/dune/pull/3879 +; (generate_opam_files true) (license LGPL-2.1-only) (maintainers "The Coq development team <coqdev@inria.fr>") diff --git a/engine/evar_kinds.ml b/engine/evar_kinds.ml index 71d68f739e..fb41c4491e 100644 --- a/engine/evar_kinds.ml +++ b/engine/evar_kinds.ml @@ -40,6 +40,7 @@ type t = | ImplicitArg of GlobRef.t * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t + | EvarType of Id.t option * Evar.t (* type of an optionally named evar *) | NamedHole of Id.t (* coming from some ?[id] syntax *) | QuestionMark of question_mark | CasesType of bool (* true = a subterm of the type *) diff --git a/engine/evar_kinds.mli b/engine/evar_kinds.mli index ffc57cfd15..b2b39d49be 100644 --- a/engine/evar_kinds.mli +++ b/engine/evar_kinds.mli @@ -39,6 +39,7 @@ type t = | ImplicitArg of GlobRef.t * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t + | EvarType of Id.t option * Evar.t (* type of an optionally named evar *) | NamedHole of Id.t (* coming from some ?[id] syntax *) | QuestionMark of question_mark | CasesType of bool (* true = a subterm of the type *) diff --git a/engine/evd.ml b/engine/evd.ml index 498a9d9825..706e51d4b3 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -983,6 +983,9 @@ let fresh_inductive_instance ?loc ?(rigid=univ_flexible) env evd i = let fresh_constructor_instance ?loc ?(rigid=univ_flexible) env evd c = with_context_set ?loc rigid evd (UnivGen.fresh_constructor_instance env c) +let fresh_array_instance ?loc ?(rigid=univ_flexible) env evd = + with_context_set ?loc rigid evd (UnivGen.fresh_array_instance env) + let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = with_context_set ?loc rigid evd (UnivGen.fresh_global_instance ?loc ?names env gr) @@ -1231,6 +1234,11 @@ let restrict evk filter ?candidates ?src evd = let evd = declare_future_goal evk' evd in (evd, evk') +let update_source evd evk src = + let evar_info = EvMap.find evk evd.undf_evars in + let evar_info' = { evar_info with evar_source = src } in + { evd with undf_evars = EvMap.add evk evar_info' evd.undf_evars } + (**********************************************************) (* Accessing metas *) diff --git a/engine/evd.mli b/engine/evd.mli index 1c5c65924c..a6d55c2615 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -290,6 +290,10 @@ val restrict : Evar.t-> Filter.t -> ?candidates:econstr list -> possibly limiting the instances to a set of candidates (candidates are filtered according to the filter) *) +val update_source : evar_map -> Evar.t -> Evar_kinds.t located -> evar_map +(** To update the source a posteriori, e.g. when an evar type of + another evar has to refer to this other evar, with a mutual dependency *) + val get_aliased_evars : evar_map -> Evar.t Evar.Map.t (** The map of aliased evars *) @@ -694,6 +698,8 @@ val fresh_inductive_instance : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> inductive -> evar_map * pinductive val fresh_constructor_instance : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_array_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> evar_map * Univ.Instance.t val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> GlobRef.t -> evar_map * econstr diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 4c7ed9047d..38ec668884 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -99,7 +99,7 @@ struct let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> - Control.timeout n t () (Exception Tac_Timeout) + Control.timeout n t () let make f = (); fun () -> try f () diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 7df29c6653..7784b38c80 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -74,7 +74,7 @@ module NonLogical : sig (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t - val timeout : int -> 'a t -> 'a t + val timeout : int -> 'a t -> 'a option t (** Construct a monadified side-effect. Exceptions raised by the argument are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index 978088872c..b3061eaa81 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -909,10 +909,11 @@ let tclPROGRESS t = in let test = quick_test || + (CList.same_length initial.comb final.comb && Util.List.for_all2eq begin fun i f -> Progress.goal_equal ~evd:initial.solution ~extended_evd:final.solution (drop_state i) (drop_state f) - end initial.comb final.comb + end initial.comb final.comb) in if not test then tclUNIT res @@ -937,22 +938,12 @@ let tclTIMEOUT n t = Proof.get >>= fun initial -> Proof.current >>= fun envvar -> Proof.lift begin - Logic_monad.NonLogical.catch - begin - let open Logic_monad.NonLogical in - timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> - match r with - | Logic_monad.Nil e -> return (Util.Inr e) - | Logic_monad.Cons (r, _) -> return (Util.Inl r) - end - begin let open Logic_monad.NonLogical in function (e, info) -> - match e with - | Logic_monad.Tac_Timeout -> - return (Util.Inr (Logic_monad.Tac_Timeout, info)) - | Logic_monad.TacticFailure e -> - return (Util.Inr (e, info)) - | e -> Logic_monad.NonLogical.raise (e, info) - end + let open Logic_monad.NonLogical in + timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> + match r with + | None -> return (Util.Inr (Logic_monad.Tac_Timeout, Exninfo.null)) + | Some (Logic_monad.Nil e) -> return (Util.Inr e) + | Some (Logic_monad.Cons (r, _)) -> return (Util.Inl r) end >>= function | Util.Inl (res,s,m,i) -> Proof.set s >> diff --git a/engine/proofview.mli b/engine/proofview.mli index 816b45984b..fe0d7ae51e 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -417,7 +417,7 @@ end val tclCHECKINTERRUPT : unit tactic (** [tclTIMEOUT n t] can have only one success. - In case of timeout if fails with [tclZERO Timeout]. *) + In case of timeout it fails with [tclZERO Tac_Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an diff --git a/engine/termops.ml b/engine/termops.ml index 693945d5ac..66131e1a8f 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -123,6 +123,13 @@ let pr_evar_source env sigma = function str "subterm of pattern-matching return predicate" | Evar_kinds.BinderType (Name id) -> str "type of " ++ Id.print id | Evar_kinds.BinderType Anonymous -> str "type of anonymous binder" + | Evar_kinds.EvarType (ido,evk) -> + let pp = match ido with + | Some id -> str "?" ++ Id.print id + | None -> + try pr_existential_key sigma evk + with (* defined *) Not_found -> str "an internal placeholder" in + str "type of " ++ pp | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let open Globnames in let print_constr = print_kconstr in @@ -670,12 +677,21 @@ let map_constr_with_binders_left_to_right sigma g f l c = if def' == def && t' == t && ty' == ty then c else mkArray(u,t',def',ty') -let map_under_context_with_full_binders sigma g f l n d = - let open EConstr in - let f l c = Unsafe.to_constr (f l (of_constr c)) in - let g d l = g (of_rel_decl d) l in - let d = EConstr.Unsafe.to_constr (EConstr.whd_evar sigma d) in - EConstr.of_constr (Constr.map_under_context_with_full_binders g f l n d) +let rec map_under_context_with_full_binders sigma g f l n d = + if n = 0 then f l d else + match EConstr.kind sigma d with + | LetIn (na,b,t,c) -> + let b' = f l b in + let t' = f l t in + let c' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalDef (na,b,t)) l) (n-1) c in + if b' == b && t' == t && c' == c then d + else EConstr.mkLetIn (na,b',t',c') + | Lambda (na,t,b) -> + let t' = f l t in + let b' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalAssum (na,t)) l) (n-1) b in + if t' == t && b' == b then d + else EConstr.mkLambda (na,t',b') + | _ -> CErrors.anomaly (Pp.str "Ill-formed context") let map_branches_with_full_binders sigma g f l ci bl = let tags = Array.map List.length ci.ci_pp_info.cstr_tags in @@ -768,11 +784,27 @@ let map_constr_with_full_binders_user_view sigma g f = each binder traversal; it is not recursive *) let fold_constr_with_full_binders sigma g f n acc c = - let open EConstr in - let f l acc c = f l acc (of_constr c) in - let g d l = g (of_rel_decl d) l in - let c = Unsafe.to_constr (whd_evar sigma c) in - Constr.fold_with_full_binders g f n acc c + let open EConstr.Vars in + let open Context.Rel.Declaration in + match EConstr.kind sigma c with + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (_,c) -> f n acc c + | Evar (_,l) -> List.fold_left (f n) acc l + | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | Array(_u,t,def,ty) -> f n (f n (Array.fold_left (f n) acc t) def) ty let fold_constr_with_binders sigma g f n acc c = let open EConstr in diff --git a/engine/uState.ml b/engine/uState.ml index 103b552d86..20ea24dd87 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -113,19 +113,18 @@ let constraints uctx = snd uctx.local let context uctx = ContextSet.to_context uctx.local let compute_instance_binders inst ubinders = - let revmap = Id.Map.fold (fun id lvl accu -> LMap.add lvl id accu) ubinders LMap.empty in let map lvl = - try Name (LMap.find lvl revmap) - with Not_found -> Anonymous + try Name (Option.get (LMap.find lvl ubinders).uname) + with Option.IsNone | Not_found -> Anonymous in Array.map map (Instance.to_array inst) let univ_entry ~poly uctx = let open Entries in if poly then - let (binders, _) = uctx.names in + let (_, rbinders) = uctx.names in let uctx = context uctx in - let nas = compute_instance_binders (UContext.instance uctx) binders in + let nas = compute_instance_binders (UContext.instance uctx) rbinders in Polymorphic_entry (nas, uctx) else Monomorphic_entry (context_set uctx) @@ -158,23 +157,8 @@ let of_binders names = in { empty with names = (names, rev_map) } -let invent_name (named,cnt) u = - let rec aux i = - let na = Id.of_string ("u"^(string_of_int i)) in - if Id.Map.mem na named then aux (i+1) - else Id.Map.add na u named, i+1 - in - aux cnt - let universe_binders uctx = - let named, rev = uctx.names in - let named, _ = LSet.fold (fun u named -> - match LMap.find u rev with - | exception Not_found -> (* not sure if possible *) invent_name named u - | { uname = None } -> invent_name named u - | { uname = Some _ } -> named) - (ContextSet.levels uctx.local) (named, 0) - in + let named, _ = uctx.names in named let instantiate_variable l b v = @@ -341,12 +325,16 @@ let constrain_variables diff uctx = in { uctx with local = (univs, local); univ_variables = vars } -let qualid_of_level uctx = +let id_of_level uctx l = + try Some (Option.get (LMap.find l (snd uctx.names)).uname) + with Not_found | Option.IsNone -> + None + +let qualid_of_level uctx l = let map, map_rev = uctx.names in - fun l -> - try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) - with Not_found | Option.IsNone -> - UnivNames.qualid_of_level l + try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) + with Not_found | Option.IsNone -> + UnivNames.qualid_of_level map l let pr_uctx_level uctx l = match qualid_of_level uctx l with @@ -443,9 +431,9 @@ let check_univ_decl ~poly uctx decl = let names = decl.univdecl_instance in let extensible = decl.univdecl_extensible_instance in if poly then - let (binders, _) = uctx.names in + let (_, rbinders) = uctx.names in let uctx = universe_context ~names ~extensible uctx in - let nas = compute_instance_binders (UContext.instance uctx) binders in + let nas = compute_instance_binders (UContext.instance uctx) rbinders in Entries.Polymorphic_entry (nas, uctx) else let () = check_universe_context_set ~names ~extensible uctx in diff --git a/engine/uState.mli b/engine/uState.mli index bd3aac0d8b..9cff988c99 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -79,7 +79,7 @@ val univ_entry : poly:bool -> t -> Entries.universes_entry (** Pick from {!context} or {!context_set} based on [poly]. *) val universe_binders : t -> UnivNames.universe_binders -(** Return names of universes, inventing names if needed *) +(** Return local names of universes. *) (** {5 Constraints handling} *) @@ -209,4 +209,7 @@ val update_sigma_univs : t -> UGraph.t -> t val pr_uctx_level : t -> Univ.Level.t -> Pp.t val qualid_of_level : t -> Univ.Level.t -> Libnames.qualid option +(** Only looks in the local names, not in the nametab. *) +val id_of_level : t -> Univ.Level.t -> Id.t option + val pr_weak : (Univ.Level.t -> Pp.t) -> t -> Pp.t diff --git a/engine/univGen.ml b/engine/univGen.ml index 6f27ccb7dc..278ca6bf34 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -65,6 +65,11 @@ let fresh_constructor_instance env c = let u, ctx = fresh_global_instance env (GlobRef.ConstructRef c) in (c, u), ctx +let fresh_array_instance env = + let auctx = CPrimitives.typ_univs CPrimitives.PT_array in + let u, ctx = fresh_instance_from auctx None in + u, ctx + let fresh_global_instance ?loc ?names env gr = let u, ctx = fresh_global_instance ?loc ?names env gr in mkRef (gr, u), ctx diff --git a/engine/univGen.mli b/engine/univGen.mli index 81bdac17ce..05737411f5 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -42,6 +42,8 @@ val fresh_inductive_instance : env -> inductive -> pinductive in_universe_context_set val fresh_constructor_instance : env -> constructor -> pconstructor in_universe_context_set +val fresh_array_instance : env -> + Instance.t in_universe_context_set val fresh_global_instance : ?loc:Loc.t -> ?names:Univ.Instance.t -> env -> GlobRef.t -> constr in_universe_context_set diff --git a/engine/univNames.ml b/engine/univNames.ml index 2e15558db2..215f27f535 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -12,15 +12,15 @@ open Names open Univ -let qualid_of_level l = +let qualid_of_level ctx l = match Level.name l with | Some qid -> - (try Some (Nametab.shortest_qualid_of_universe qid) + (try Some (Nametab.shortest_qualid_of_universe ctx qid) with Not_found -> None) | None -> None -let pr_with_global_universes l = - match qualid_of_level l with +let pr_with_global_universes ctx l = + match qualid_of_level ctx l with | Some qid -> Libnames.pr_qualid qid | None -> Level.pr l diff --git a/engine/univNames.mli b/engine/univNames.mli index 5f69d199b3..875c043032 100644 --- a/engine/univNames.mli +++ b/engine/univNames.mli @@ -10,9 +10,6 @@ open Univ -val pr_with_global_universes : Level.t -> Pp.t -val qualid_of_level : Level.t -> Libnames.qualid option - (** Local universe name <-> level mapping *) type universe_binders = Univ.Level.t Names.Id.Map.t @@ -20,3 +17,6 @@ type universe_binders = Univ.Level.t Names.Id.Map.t val empty_binders : universe_binders type univ_name_list = Names.lname list + +val pr_with_global_universes : universe_binders -> Level.t -> Pp.t +val qualid_of_level : universe_binders -> Level.t -> Libnames.qualid option diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index b3f06faa1c..b14c325f69 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -13,10 +13,23 @@ open Libnames (** {6 Concrete syntax for terms } *) -(** [constr_expr] is the abstract syntax tree produced by the parser *) -type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.gen_universe_decl +(** Universes *) +type sort_name_expr = + | CSProp | CProp | CSet + | CType of qualid + | CRawType of Univ.Level.t (** Universes like "foo.1" have no qualid form *) + +type univ_level_expr = sort_name_expr Glob_term.glob_sort_gen +type sort_expr = (sort_name_expr * int) list Glob_term.glob_sort_gen + +type instance_expr = univ_level_expr list + +(** Constraints don't have anonymous universes *) +type univ_constraint_expr = sort_name_expr * Univ.constraint_type * sort_name_expr + +type universe_decl_expr = (lident list, univ_constraint_expr list) UState.gen_universe_decl type cumul_univ_decl_expr = - ((lident * Univ.Variance.t option) list, Glob_term.glob_constraint list) UState.gen_universe_decl + ((lident * Univ.Variance.t option) list, univ_constraint_expr list) UState.gen_universe_decl type ident_decl = lident * universe_decl_expr option type cumul_ident_decl = lident * cumul_univ_decl_expr option @@ -64,8 +77,7 @@ type prim_token = | Number of NumTok.Signed.t | String of string -type instance_expr = Glob_term.glob_level list - +(** [constr_expr] is the abstract syntax tree produced by the parser *) type cases_pattern_expr_r = | CPatAlias of cases_pattern_expr * lname | CPatCstr of qualid @@ -114,7 +126,7 @@ and constr_expr_r = | CHole of Evar_kinds.t option * Namegen.intro_pattern_naming_expr * Genarg.raw_generic_argument option | CPatVar of Pattern.patvar | CEvar of Glob_term.existential_name CAst.t * (lident * constr_expr) list - | CSort of Glob_term.glob_sort + | CSort of sort_expr | CCast of constr_expr * constr_expr Glob_term.cast_type | CNotation of notation_with_optional_scope option * notation * constr_notation_substitution | CGeneralization of Glob_term.binding_kind * abstraction_kind option * constr_expr diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index a60dc11b57..f02874253e 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -18,6 +18,25 @@ open Glob_term open Notation open Constrexpr +(***********) +(* Universes *) + +let sort_name_expr_eq c1 c2 = match c1, c2 with + | CSProp, CSProp + | CProp, CProp + | CSet, CSet -> true + | CType q1, CType q2 -> Libnames.qualid_eq q1 q2 + | CRawType u1, CRawType u2 -> Univ.Level.equal u1 u2 + | (CSProp|CProp|CSet|CType _|CRawType _), _ -> false + +let univ_level_expr_eq u1 u2 = + Glob_ops.glob_sort_gen_eq sort_name_expr_eq u1 u2 + +let sort_expr_eq u1 u2 = + Glob_ops.glob_sort_gen_eq + (List.equal (fun (x,m) (y,n) -> sort_name_expr_eq x y && Int.equal m n)) + u1 u2 + (***********************) (* For binders parsing *) @@ -59,13 +78,11 @@ let explicitation_eq ex1 ex2 = match ex1, ex2 with Id.equal id1 id2 | _ -> false -let eq_ast f { CAst.v = x } { CAst.v = y } = f x y - let rec cases_pattern_expr_eq p1 p2 = if CAst.(p1.v == p2.v) then true else match CAst.(p1.v, p2.v) with | CPatAlias(a1,i1), CPatAlias(a2,i2) -> - eq_ast Name.equal i1 i2 && cases_pattern_expr_eq a1 a2 + CAst.eq Name.equal i1 i2 && cases_pattern_expr_eq a1 a2 | CPatCstr(c1,a1,b1), CPatCstr(c2,a2,b2) -> qualid_eq c1 c2 && Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && @@ -108,10 +125,10 @@ let rec constr_expr_eq e1 e2 = else match CAst.(e1.v, e2.v) with | CRef (r1,u1), CRef (r2,u2) -> qualid_eq r1 r2 && eq_universes u1 u2 | CFix(id1,fl1), CFix(id2,fl2) -> - eq_ast Id.equal id1 id2 && + lident_eq id1 id2 && List.equal fix_expr_eq fl1 fl2 | CCoFix(id1,fl1), CCoFix(id2,fl2) -> - eq_ast Id.equal id1 id2 && + lident_eq id1 id2 && List.equal cofix_expr_eq fl1 fl2 | CProdN(bl1,a1), CProdN(bl2,a2) -> List.equal local_binder_eq bl1 bl2 && @@ -120,7 +137,7 @@ let rec constr_expr_eq e1 e2 = List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 | CLetIn(na1,a1,t1,b1), CLetIn(na2,a2,t2,b2) -> - eq_ast Name.equal na1 na2 && + CAst.eq Name.equal na1 na2 && constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 @@ -144,14 +161,14 @@ let rec constr_expr_eq e1 e2 = List.equal case_expr_eq a1 a2 && List.equal branch_expr_eq brl1 brl2 | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> - List.equal (eq_ast Name.equal) n1 n2 && - Option.equal (eq_ast Name.equal) m1 m2 && + List.equal (CAst.eq Name.equal) n1 n2 && + Option.equal (CAst.eq Name.equal) m1 m2 && Option.equal constr_expr_eq e1 e2 && constr_expr_eq t1 t2 && constr_expr_eq b1 b2 | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> constr_expr_eq e1 e2 && - Option.equal (eq_ast Name.equal) n1 n2 && + Option.equal (CAst.eq Name.equal) n1 n2 && Option.equal constr_expr_eq r1 r2 && constr_expr_eq t1 t2 && constr_expr_eq f1 f2 @@ -161,7 +178,7 @@ let rec constr_expr_eq e1 e2 = | CEvar (id1, c1), CEvar (id2, c2) -> Id.equal id1.CAst.v id2.CAst.v && List.equal instance_eq c1 c2 | CSort s1, CSort s2 -> - Glob_ops.glob_sort_eq s1 s2 + sort_expr_eq s1 s2 | CCast(t1,c1), CCast(t2,c2) -> constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(inscope1, n1, s1), CNotation(inscope2, n2, s2) -> @@ -187,12 +204,12 @@ let rec constr_expr_eq e1 e2 = | CGeneralization _ | CDelimiters _ | CArray _), _ -> false and args_eq (a1,e1) (a2,e2) = - Option.equal (eq_ast explicitation_eq) e1 e2 && + Option.equal (CAst.eq explicitation_eq) e1 e2 && constr_expr_eq a1 a2 and case_expr_eq (e1, n1, p1) (e2, n2, p2) = constr_expr_eq e1 e2 && - Option.equal (eq_ast Name.equal) n1 n2 && + Option.equal (CAst.eq Name.equal) n1 n2 && Option.equal cases_pattern_expr_eq p1 p2 and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = @@ -200,35 +217,35 @@ and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = constr_expr_eq e1 e2 and fix_expr_eq (id1,r1,bl1,a1,b1) (id2,r2,bl2,a2,b2) = - (eq_ast Id.equal id1 id2) && + (lident_eq id1 id2) && Option.equal recursion_order_expr_eq r1 r2 && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = - (eq_ast Id.equal id1 id2) && + (lident_eq id1 id2) && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 and recursion_order_expr_eq_r r1 r2 = match r1, r2 with - | CStructRec i1, CStructRec i2 -> eq_ast Id.equal i1 i2 + | CStructRec i1, CStructRec i2 -> lident_eq i1 i2 | CWfRec (i1,e1), CWfRec (i2,e2) -> constr_expr_eq e1 e2 | CMeasureRec (i1, e1, o1), CMeasureRec (i2, e2, o2) -> - Option.equal (eq_ast Id.equal) i1 i2 && + Option.equal lident_eq i1 i2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 | _ -> false -and recursion_order_expr_eq r1 r2 = eq_ast recursion_order_expr_eq_r r1 r2 +and recursion_order_expr_eq r1 r2 = CAst.eq recursion_order_expr_eq_r r1 r2 and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> - eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 + CAst.eq Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> (* Don't care about the [binder_kind] *) - List.equal (eq_ast Name.equal) n1 n2 && constr_expr_eq e1 e2 + List.equal (CAst.eq Name.equal) n1 n2 && constr_expr_eq e1 e2 | _ -> false and constr_notation_substitution_eq (e1, el1, b1, bl1) (e2, el2, b2, bl2) = diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index dfa51918d1..ffa7c8ec10 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -16,6 +16,10 @@ open Constrexpr (** {6 Equalities on [constr_expr] related types} *) +val sort_name_expr_eq : sort_name_expr -> sort_name_expr -> bool +val univ_level_expr_eq : univ_level_expr -> univ_level_expr -> bool +val sort_expr_eq : sort_expr -> sort_expr -> bool + val explicitation_eq : explicitation -> explicitation -> bool (** Equality on [explicitation]. *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index cf88036f73..f3ba884856 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -800,19 +800,21 @@ let extern_args extern env args = let match_coercion_app c = match DAst.get c with | GApp (r, args) -> begin match DAst.get r with - | GRef (r,_) -> Some (c.CAst.loc, r, 0, args) + | GRef (r,_) -> Some (c.CAst.loc, r, args) | _ -> None end | _ -> None let remove_one_coercion inctx c = try match match_coercion_app c with - | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> + | Some (loc,r,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in (match Coercionops.hide_coercion r with - | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> + | Some nparams when + let inctx = inctx || (* coercion to funclass implying being in context *) nparams+1 < nargs in + nparams < nargs && inctx -> (* We skip the coercion *) - let l = List.skipn (n - pars) args in + let l = List.skipn nparams args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Don't flatten App's in case of funclass so that (atomic) notations on [a] work; should be compatible @@ -824,7 +826,7 @@ let remove_one_coercion inctx c = have been made explicit to match *) let a' = if List.is_empty l then a else DAst.make ?loc @@ GApp (a,l) in let inctx = inctx || not (List.is_empty l) in - Some (n-pars+1, inctx, a') + Some (nparams+1, inctx, a') | _ -> None) | _ -> None with Not_found -> @@ -867,7 +869,7 @@ let filter_enough_applied nargs l = | Some nargs -> List.filter (fun (keyrule,pat,n as _rule) -> match n with - | AppBoundedNotation n -> n > nargs + | AppBoundedNotation n -> n >= nargs | AppUnboundedNotation | NotAppNotation -> false) l (* Helper function for safe and optimal printing of primitive tokens *) @@ -884,9 +886,10 @@ let extern_prim_token_delimiter_if_required n key_n scope_n scopes = let extended_glob_local_binder_of_decl loc = function | (p,bk,None,t) -> GLocalAssum (p,bk,t) | (p,bk,Some x, t) -> + assert (bk = Explicit); match DAst.get t with - | GHole (_, IntroAnonymous, None) -> GLocalDef (p,bk,x,None) - | _ -> GLocalDef (p,bk,x,Some t) + | GHole (_, IntroAnonymous, None) -> GLocalDef (p,x,None) + | _ -> GLocalDef (p,x,Some t) let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) @@ -921,22 +924,44 @@ let extern_float f scopes = (**********************************************************************) (* mapping glob_constr to constr_expr *) -let extern_glob_sort = function +type extern_env = Id.Set.t * UnivNames.universe_binders +let extern_env env sigma = vars_of_env env, Evd.universe_binders sigma +let empty_extern_env = Id.Set.empty, Id.Map.empty + +let extern_glob_sort_name uvars = function + | GSProp -> CSProp + | GProp -> CProp + | GSet -> CSet + | GLocalUniv u -> CType (qualid_of_lident u) + | GRawUniv u -> CRawType u + | GUniv u -> begin match UnivNames.qualid_of_level uvars u with + | Some qid -> CType qid + | None -> CRawType u + end + +let extern_glob_sort uvars = + map_glob_sort_gen (List.map (on_fst (extern_glob_sort_name uvars))) + +(** wrapper to handle print_universes: don't forget small univs *) +let extern_glob_sort uvars = function (* In case we print a glob_constr w/o having passed through detyping *) - | UNamed [(GSProp,0) | (GProp,0) | (GSet,0)] as u -> u + | UNamed [(GSProp,0) | (GProp,0) | (GSet,0)] as u -> extern_glob_sort uvars u | UNamed _ when not !print_universes -> UAnonymous {rigid=true} - | UNamed _ | UAnonymous _ as u -> u + | UNamed _ | UAnonymous _ as u -> extern_glob_sort uvars u -let extern_universes = function - | Some _ as l when !print_universes -> l +let extern_instance uvars = function + | Some l when !print_universes -> + Some (List.map (map_glob_sort_gen (extern_glob_sort_name uvars)) l) | _ -> None -let extern_ref vars ref us = +let extern_ref (vars,uvars) ref us = extern_global (select_stronger_impargs (implicits_of_global ref)) - (extern_reference vars ref) (extern_universes us) + (extern_reference vars ref) (extern_instance uvars us) let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) +let add_vname (vars,uvars) na = add_vname vars na, uvars + let rec extern inctx ?impargs scopes vars r = match remove_one_coercion inctx (flatten_application r) with | Some (nargs,inctx,r') -> @@ -993,7 +1018,7 @@ let rec extern inctx ?impargs scopes vars r = (* Otherwise... *) extern_applied_ref inctx (select_stronger_impargs (implicits_of_global ref)) - (ref,extern_reference ?loc vars ref) (extern_universes us) args) + (ref,extern_reference ?loc (fst vars) ref) (extern_instance (snd vars) us) args) | _ -> let args = List.map (fun c -> (sub_extern true scopes vars c,None)) args in let head = sub_extern false scopes vars f in @@ -1013,7 +1038,8 @@ let rec extern inctx ?impargs scopes vars r = | GCases (sty,rtntypopt,tml,eqns) -> let vars' = List.fold_right (Name.fold_right Id.Set.add) - (cases_predicate_names tml) vars in + (cases_predicate_names tml) (fst vars) in + let vars' = vars', snd vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> let na' = match na, DAst.get tm with @@ -1033,7 +1059,7 @@ let rec extern inctx ?impargs scopes vars r = Option.map (fun {CAst.loc;v=(ind,nal)} -> let args = List.map (fun x -> DAst.make @@ PatVar x) nal in let fullargs = add_cpatt_for_params ind args in - extern_ind_pattern_in_scope scopes vars ind fullargs + extern_ind_pattern_in_scope scopes (fst vars) ind fullargs ) x)) tml in @@ -1056,7 +1082,7 @@ let rec extern inctx ?impargs scopes vars r = sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) | GRec (fk,idv,blv,tyv,bv) -> - let vars' = Array.fold_right Id.Set.add idv vars in + let vars' = on_fst (Array.fold_right Id.Set.add idv) vars in (match fk with | GFix (nv,n) -> let listdecl = @@ -1064,8 +1090,8 @@ let rec extern inctx ?impargs scopes vars r = let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let bl = List.map (extended_glob_local_binder_of_decl ?loc) bl in let (assums,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in - let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in + let vars0 = on_fst (List.fold_right (Name.fold_right Id.Set.add) ids) vars in + let vars1 = on_fst (List.fold_right (Name.fold_right Id.Set.add) ids) vars' in let n = match nv.(i) with | None -> None @@ -1080,14 +1106,14 @@ let rec extern inctx ?impargs scopes vars r = Array.mapi (fun i fi -> let bl = List.map (extended_glob_local_binder_of_decl ?loc) blv.(i) in let (_,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in - let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in + let vars0 = on_fst (List.fold_right (Name.fold_right Id.Set.add) ids) vars in + let vars1 = on_fst (List.fold_right (Name.fold_right Id.Set.add) ids) vars' in ((CAst.make fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern true scopes vars1 bv.(i))) idv in CCoFix (CAst.(make ?loc idv.(n)),Array.to_list listdecl)) - | GSort s -> CSort (extern_glob_sort s) + | GSort s -> CSort (extern_glob_sort (snd vars) s) | GHole (e,naming,_) -> CHole (Some e, naming, None) (* TODO: extern tactics. *) @@ -1103,7 +1129,7 @@ let rec extern inctx ?impargs scopes vars r = | GFloat f -> extern_float f (snd scopes) | GArray(u,t,def,ty) -> - CArray(extern_universes u,Array.map (extern inctx scopes vars) t, extern inctx scopes vars def, extern_typ scopes vars ty) + CArray(extern_instance (snd vars) u,Array.map (extern inctx scopes vars) t, extern inctx scopes vars def, extern_typ scopes vars ty) in insert_entry_coercion coercion (CAst.make ?loc c) @@ -1125,7 +1151,7 @@ and factorize_prod ?impargs scopes vars na bk t c = let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = extern_typ scopes vars b in - let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes (fst vars)) disjpat) in let binder = CLocalPattern p in (match b.v with | CProdN (bl,b) -> CProdN (binder::bl,b) @@ -1166,7 +1192,7 @@ and factorize_lambda inctx scopes vars na bk t c = let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = sub_extern inctx scopes vars b in - let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes (fst vars)) disjpat) in let binder = CLocalPattern p in (match b.v with | CLambdaN (bl,b) -> CLambdaN (binder::bl,b) @@ -1192,9 +1218,9 @@ and extern_local_binder scopes vars = function [] -> ([],[],[]) | b :: l -> match DAst.get b with - | GLocalDef (na,bk,bd,ty) -> + | GLocalDef (na,bd,ty) -> let (assums,ids,l) = - extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in + extern_local_binder scopes (on_fst (Name.fold_right Id.Set.add na) vars) l in (assums,na::ids, CLocalDef(CAst.make na, extern false scopes vars bd, Option.map (extern_typ scopes vars) ty) :: l) @@ -1202,7 +1228,7 @@ and extern_local_binder scopes vars = function | GLocalAssum (na,bk,ty) -> let implicit_type = is_reserved_type na ty in let ty = extern_typ scopes vars ty in - (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with + (match extern_local_binder scopes (on_fst (Name.fold_right Id.Set.add na) vars) l with (assums,ids,CLocalAssum(nal,k,ty')::l) when (constr_expr_eq ty ty' || implicit_type && constr_expr_eq ty' hole) && match na with Name id -> not (occur_var_constr_expr id ty') @@ -1217,7 +1243,7 @@ and extern_local_binder scopes vars = function | GLocalPattern ((p,_),_,bk,ty) -> let ty = if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in - let p = mkCPatOr (List.map (extern_cases_pattern vars) p) in + let p = mkCPatOr (List.map (extern_cases_pattern (fst vars)) p) in let (assums,ids,l) = extern_local_binder scopes vars l in let p = match ty with | None -> p @@ -1225,7 +1251,7 @@ and extern_local_binder scopes vars = function (assums,ids, CLocalPattern p :: l) and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = - let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in + let pll = List.map (List.map (extern_cases_pattern_in_scope scopes (fst vars))) pll in make ?loc (pll,extern inctx scopes vars c) and extern_notations inctx scopes vars nargs t = @@ -1275,6 +1301,7 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = end | AppBoundedNotation _ -> raise No_match in (* Try matching ... *) + let vars, uvars = vars in let terms,termlists,binders,binderlists = match_notation_constr ~print_univ:(!print_universes) t ~vars pat in (* Try availability of interpretation ... *) @@ -1298,35 +1325,43 @@ and extern_notation inctx (custom,scopes as allscopes) vars t rules = let l = List.map (fun ((vars,c),(subentry,(scopt,scl))) -> extern (* assuming no overloading: *) true - (subentry,(scopt,scl@scopes')) vars c) - terms in + (subentry,(scopt,scl@scopes')) (vars,uvars) c) + terms + in let ll = List.map (fun ((vars,l),(subentry,(scopt,scl))) -> - List.map (extern true (subentry,(scopt,scl@scopes')) vars) l) - termlists in + List.map (extern true (subentry,(scopt,scl@scopes')) (vars,uvars)) l) + termlists + in let bl = List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> - (mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)), - Explicit) - binders in + (mkCPatOr (List.map + (extern_cases_pattern_in_scope + (subentry,(scopt,scl@scopes')) vars) + bl)), + Explicit) + binders + in let bll = List.map (fun ((vars,bl),(subentry,(scopt,scl))) -> - pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) - binderlists in + pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) (vars,uvars) bl)) + binderlists + in let c = make_notation loc specific_ntn (l,ll,bl,bll) in let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in - let args = extern_args (extern true) vars args in + let args = extern_args (extern true) (vars,uvars) args in CAst.make ?loc @@ extern_applied_notation inctx nallargs argsimpls c args) | SynDefRule kn -> let l = List.map (fun ((vars,c),(subentry,(scopt,scl))) -> - extern true (subentry,(scopt,scl@snd scopes)) vars c) - terms in + extern true (subentry,(scopt,scl@snd scopes)) (vars,uvars) c) + terms + in let cf = Nametab.shortest_qualid_of_syndef ?loc vars kn in let a = CRef (cf,None) in let args = fill_arg_scopes args argsscopes allscopes in - let args = extern_args (extern true) vars args in + let args = extern_args (extern true) (vars,uvars) args in let c = CAst.make ?loc @@ extern_applied_syntactic_definition inctx nallargs argsimpls (a,cf) l args in if isCRef_no_univ c.CAst.v && entry_has_global custom then c else match availability_of_entry_coercion custom InConstrEntrySomeLevel with @@ -1346,7 +1381,7 @@ let extern_glob_type ?impargs vars c = let extern_constr ?lax ?(inctx=false) ?scope env sigma t = let r = Detyping.detype Detyping.Later ?lax false Id.Set.empty env sigma t in - let vars = vars_of_env env in + let vars = extern_env env sigma in extern inctx (InConstrEntrySomeLevel,(scope,[])) vars r let extern_constr_in_scope ?lax ?inctx scope env sigma t = @@ -1362,16 +1397,16 @@ let extern_type ?lax ?(goal_concl_style=false) env sigma ?impargs t = (* consideration; see namegen.ml for further details *) let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype Detyping.Later ?lax goal_concl_style avoid env sigma t in - extern_glob_type ?impargs (vars_of_env env) r + extern_glob_type ?impargs (extern_env env sigma) r -let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) +let extern_sort sigma s = extern_glob_sort (Evd.universe_binders sigma) (detype_sort sigma s) let extern_closed_glob ?lax ?(goal_concl_style=false) ?(inctx=false) ?scope env sigma t = let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t in - let vars = vars_of_env env in + let vars = extern_env env sigma in extern inctx (InConstrEntrySomeLevel,(scope,[])) vars r (******************************************************************) @@ -1489,10 +1524,13 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with GArray (None, Array.map glob_of t, glob_of def, glob_of ty) let extern_constr_pattern env sigma pat = - extern true (InConstrEntrySomeLevel,(None,[])) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) + extern true (InConstrEntrySomeLevel,(None,[])) + (* XXX no vars? *) + (Id.Set.empty, Evd.universe_binders sigma) + (glob_of_pat Id.Set.empty env sigma pat) let extern_rel_context where env sigma sign = let a = detype_rel_context Detyping.Later where Id.Set.empty (names_of_rel_context env,env) sigma sign in - let vars = vars_of_env env in + let vars = extern_env env sigma in let a = List.map (extended_glob_local_binder_of_decl) a in pi3 (extern_local_binder (InConstrEntrySomeLevel,(None,[])) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index f85e49d2df..298b52f0be 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -23,9 +23,12 @@ open Ltac_pretype (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) +type extern_env = Id.Set.t * UnivNames.universe_binders +val extern_env : env -> Evd.evar_map -> extern_env + val extern_cases_pattern : Id.Set.t -> 'a cases_pattern_g -> cases_pattern_expr -val extern_glob_constr : Id.Set.t -> 'a glob_constr_g -> constr_expr -val extern_glob_type : ?impargs:Glob_term.binding_kind list -> Id.Set.t -> 'a glob_constr_g -> constr_expr +val extern_glob_constr : extern_env -> 'a glob_constr_g -> constr_expr +val extern_glob_type : ?impargs:Glob_term.binding_kind list -> extern_env -> 'a glob_constr_g -> constr_expr val extern_constr_pattern : names_context -> Evd.evar_map -> constr_pattern -> constr_expr val extern_closed_glob : ?lax:bool -> ?goal_concl_style:bool -> ?inctx:bool -> ?scope:scope_name -> @@ -43,7 +46,7 @@ val extern_constr_in_scope : ?lax:bool -> ?inctx:bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr val extern_reference : ?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid val extern_type : ?lax:bool -> ?goal_concl_style:bool -> env -> Evd.evar_map -> ?impargs:Glob_term.binding_kind list -> types -> constr_expr -val extern_sort : Evd.evar_map -> Sorts.t -> glob_sort +val extern_sort : Evd.evar_map -> Sorts.t -> sort_expr val extern_rel_context : constr option -> env -> Evd.evar_map -> rel_context -> local_binder_expr list @@ -96,3 +99,6 @@ val toggle_scope_printing : val toggle_notation_printing : ?scope:Notation_term.scope_name -> notation:Constrexpr.notation -> activate:bool -> unit + +(** Probably shouldn't be used *) +val empty_extern_env : extern_env diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8bd77abc4a..70a4ea35e9 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -90,18 +90,6 @@ let for_grammar f x = a (**********************************************************************) -(* Locating reference, possibly via an abbreviation *) - -let locate_reference qid = - Smartlocate.global_of_extended_global (Nametab.locate_extended qid) - -let is_global id = - try - let _ = locate_reference (qualid_of_ident id) in true - with Not_found -> - false - -(**********************************************************************) (* Internalization errors *) type internalization_error = @@ -112,8 +100,7 @@ type internalization_error = | NonLinearPattern of Id.t | BadPatternsNumber of int * int | NotAProjection of qualid - | NotAProjectionOf of qualid * qualid - | ProjectionsOfDifferentRecords of qualid * qualid + | ProjectionsOfDifferentRecords of Recordops.struc_typ * Recordops.struc_typ exception InternalizationError of internalization_error @@ -139,13 +126,16 @@ 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 + Nametab.shortest_qualid_of_global Id.Set.empty inductive + let explain_field_not_a_projection field_id = pr_qualid field_id ++ str ": Not a projection" -let explain_field_not_a_projection_of field_id inductive_id = - pr_qualid field_id ++ str ": Not a projection of inductive " ++ pr_qualid inductive_id - -let explain_projections_of_diff_records inductive1_id inductive2_id = +let explain_projections_of_diff_records record1 record2 = + let inductive1_id = inductive_of_record record1 in + let inductive2_id = inductive_of_record record2 in str "This record contains fields of both " ++ pr_qualid inductive1_id ++ str " and " ++ pr_qualid inductive2_id @@ -158,8 +148,6 @@ let explain_internalization_error e = | NonLinearPattern id -> explain_non_linear_pattern id | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 | NotAProjection field_id -> explain_field_not_a_projection field_id - | NotAProjectionOf (field_id, inductive_id) -> - explain_field_not_a_projection_of field_id inductive_id | ProjectionsOfDifferentRecords (inductive1_id, inductive2_id) -> explain_projections_of_diff_records inductive1_id inductive2_id in pp ++ str "." @@ -254,9 +242,12 @@ let contract_curly_brackets_pat ntn (l,ll) = (* side effect; don't inline *) (InConstrEntry,!ntn'),(l,ll) +type local_univs = { bound : Univ.Level.t Id.Map.t; unb_univs : bool } + type intern_env = { - ids: Names.Id.Set.t; + ids: Id.Set.t; unb: bool; + local_univs: local_univs; tmp_scope: Notation_term.tmp_scope_name option; scopes: Notation_term.scope_name list; impls: internalization_env; @@ -274,9 +265,9 @@ type pattern_intern_env = { (* Remembering the parsing scope of variables in notations *) let make_current_scope tmp scopes = match tmp, scopes with -| Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes -| Some tmp_scope, scopes -> tmp_scope :: scopes -| None, scopes -> scopes + | Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes + | Some tmp_scope, scopes -> tmp_scope :: scopes + | None, scopes -> scopes let pr_scope_stack = function | [] -> str "the empty scope stack" @@ -569,10 +560,10 @@ let intern_assumption intern ntnvars env nal bk ty = let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function | GLocalAssum (na,bk,t) -> (na,bk,None,t) - | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) - | GLocalDef (na,bk,c,None) -> + | GLocalDef (na,c,Some t) -> (na,Explicit,Some c,t) + | GLocalDef (na,c,None) -> let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,IntroAnonymous,None) in - (na,bk,Some c,t) + (na,Explicit,Some c,t) | GLocalPattern (_,_,_,_) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed here") ) @@ -584,7 +575,7 @@ let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = let ty = Option.map (intern (set_type_scope (restart_prod_binders env))) ty in let impls = impls_term_list 1 term in (push_name_env ntnvars impls env locna, - (na,Explicit,term,ty)) + (na,term,ty)) let intern_cases_pattern_as_binder intern test_kind ntnvars env bk (CAst.{v=p;loc} as pv) = let p,t = match p with @@ -615,8 +606,8 @@ let intern_local_binder_aux intern ntnvars (env,bl) = function let bl' = List.map (fun {loc;v=(na,c,t)} -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef( {loc; v=na} as locna,def,ty) -> - let env,(na,bk,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in - env, (DAst.make ?loc @@ GLocalDef (na,bk,def,ty)) :: bl + let env,(na,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in + env, (DAst.make ?loc @@ GLocalDef (na,def,ty)) :: bl | CLocalPattern p -> let env, ((disjpat,il),id),na,bk,t = intern_cases_pattern_as_binder intern test_kind_tolerant ntnvars env Explicit p in (env, (DAst.make ?loc:p.CAst.loc @@ GLocalPattern((disjpat,List.map (fun x -> x.v) il),id,bk,t)) :: bl) @@ -659,7 +650,7 @@ let rec expand_binders ?loc mk bl c = | [] -> c | b :: bl -> match DAst.get b with - | GLocalDef (n, bk, b, oty) -> + | GLocalDef (n, b, oty) -> expand_binders ?loc mk bl (DAst.make ?loc @@ GLetIn (n, b, oty, c)) | GLocalAssum (n, bk, t) -> expand_binders ?loc mk bl (mk ?loc (n,bk,t) c) @@ -733,9 +724,9 @@ let set_type ty1 ty2 = user_err ?loc:t2.CAst.loc Pp.(str "Unexpected type constraint in notation already providing a type constraint.") let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) na ty = - match na with - | Anonymous -> (renaming,env), None, Anonymous, Explicit, set_type ty None - | Name id -> + match na with + | Anonymous -> (renaming,env), None, Anonymous, Explicit, set_type ty None + | Name id -> let store,get = set_temporary_memory () in let test_kind = test_kind_tolerant in try @@ -775,10 +766,10 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam (renaming',env), None, Name id', Explicit, set_type ty None type binder_action = -| AddLetIn of lname * constr_expr * constr_expr option -| AddTermIter of (constr_expr * subscopes) Names.Id.Map.t -| AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) -| AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) + | AddLetIn of lname * constr_expr * constr_expr option + | AddTermIter of (constr_expr * subscopes) Names.Id.Map.t + | AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) + | AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) let dmap_with_loc f n = CAst.map_with_loc (fun ?loc c -> f ?loc (DAst.get_thunk c)) n @@ -803,8 +794,8 @@ let terms_of_binders bl = let loc = bnd.loc in begin match DAst.get bnd with | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None)) :: extract_variables l - | GLocalDef (Name id,_,_,_) -> extract_variables l - | GLocalDef (Anonymous,_,_,_) + | GLocalDef (Name id,_,_) -> extract_variables l + | GLocalDef (Anonymous,_,_) | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") | GLocalPattern (([u],_),_,_,_) -> term_of_pat u :: extract_variables l | GLocalPattern ((_,_),_,_,_) -> error_cannot_coerce_disjunctive_pattern_term ?loc () @@ -856,7 +847,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = | AddTermIter nterms::rest,terminator,iter -> aux (nterms,None,Some (rest,terminator,iter)) (renaming,env) iter | AddLetIn (na,c,t)::rest,terminator,iter -> - let env,(na,_,c,t) = intern_letin_binder intern ntnvars (adjust_env env iter) (na,c,t) in + let env,(na,c,t) = intern_letin_binder intern ntnvars (adjust_env env iter) (na,c,t) in DAst.make ?loc (GLetIn (na,c,t,aux_letin env (rest,terminator,iter))) in aux_letin env (Option.get iteropt) | NVar id -> subst_var subst' (renaming, env) id @@ -976,6 +967,9 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = into a substitution for interpretation and based on binding/constr distinction *) +let cases_pattern_of_id {loc;v=id} = + CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + let cases_pattern_of_name {loc;v=na} = let atom = match na with Name id -> Some (qualid_of_ident ?loc id) | Anonymous -> None in CAst.make ?loc (CPatAtom atom) @@ -991,16 +985,20 @@ let split_by_type ids subst = | NtnTypeConstr -> let terms,terms' = bind id scl terms terms' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder NtnBinderParsedAsConstr (AsIdentOrPattern | AsStrictPattern) -> + | NtnTypeBinder NtnBinderParsedAsConstr (AsNameOrPattern | AsStrictPattern) -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in let binders' = Id.Map.add id ((coerce_to_cases_pattern_expr a,Explicit),(false,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') | NtnTypeBinder NtnBinderParsedAsConstr AsIdent -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id ((cases_pattern_of_id (coerce_to_id a),Explicit),(true,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr AsName -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in let binders' = Id.Map.add id ((cases_pattern_of_name (coerce_to_name a),Explicit),(true,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnParsedAsBinder as x) -> - let onlyident = (x = NtnParsedAsIdent) in + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnParsedAsBinder as x) -> + let onlyident = (x = NtnParsedAsIdent || x = NtnParsedAsName) in let binders,binders' = bind id (onlyident,scl) binders binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') | NtnTypeConstrList -> @@ -1053,35 +1051,35 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None | Some [] -> DAst.make ?loc @@ GVar id -| Some _ -> - user_err ?loc (str "Variable " ++ Id.print id ++ - str " cannot have a universe instance") + | None | Some [] -> DAst.make ?loc @@ GVar id + | Some _ -> + user_err ?loc (str "Variable " ++ Id.print id ++ + str " cannot have a universe instance") let intern_var env (ltacvars,ntnvars) namedctx loc id us = (* Is [id] a notation variable *) if Id.Map.mem id ntnvars then begin if not (Id.Map.mem id env.impls) then set_var_scope ?loc id true (env.tmp_scope,env.scopes) ntnvars; - gvar (loc,id) us, [], [] + gvar (loc,id) us end else (* Is [id] registered with implicit arguments *) try - let ty,impls,argsc,uid = Id.Map.find id env.impls in + let ty,_,_,uid = Id.Map.find id env.impls in let tys = string_of_ty ty in Dumpglob.dump_reference ?loc "<>" uid tys; - gvar (loc,id) us, make_implicits_list impls, argsc + gvar (loc,id) us with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) if Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars then - gvar (loc,id) us, [], [] + gvar (loc,id) us else if Id.equal id ldots_var (* Is [id] the special variable for recursive notations? *) then if Id.Map.is_empty ntnvars then error_ldots_var ?loc - else gvar (loc,id) us, [], [] + else gvar (loc,id) us else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) user_err ?loc ~hdr:"intern_var" @@ -1093,32 +1091,73 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) let ref = GlobRef.VarRef id in - let impls = implicits_of_global ref in - let scopes = find_arguments_scope ref in Dumpglob.dump_secvar ?loc id; (* this raises Not_found when not a section variable *) (* Someday we should stop relying on Dumglob raising exceptions *) - DAst.make ?loc @@ GRef (ref, us), impls, scopes + DAst.make ?loc @@ GRef (ref, us) with e when CErrors.noncritical e -> (* [id] a goal variable *) - gvar (loc,id) us, [], [] + gvar (loc,id) us + +(**********************************************************************) +(* Locating reference, possibly via an abbreviation *) + +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) + +let is_global id = + try + let _ = locate_reference (qualid_of_ident id) in true + with Not_found -> + false -let find_appl_head_data c = +let dump_extended_global loc = function + | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob ?loc ref + | SynDef sp -> Dumpglob.add_glob_kn ?loc sp + +let intern_extended_global_of_qualid qid = + let r = Nametab.locate_extended qid in dump_extended_global qid.CAst.loc r; r + +let intern_reference qid = + let r = + try intern_extended_global_of_qualid qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + in + Smartlocate.global_of_extended_global r + +let intern_projection qid = + try + let gr = Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) in + (gr, Recordops.find_projection gr) + with Not_found -> + Loc.raise ?loc:qid.loc (InternalizationError (NotAProjection qid)) + +(**********************************************************************) +(* Interpreting references *) + +let find_appl_head_data env (_,ntnvars) c = match DAst.get c with + | GVar id when not (Id.Map.mem id ntnvars) -> + (try + let _,impls,argsc,_ = Id.Map.find id env.impls in + make_implicits_list impls, argsc + with Not_found -> [], []) | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, impls, scopes + impls, scopes | GApp (r, l) -> begin match DAst.get r with | GRef (ref,_) -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, (if n = 0 then [] else List.map (drop_first_implicits n) impls), - List.skipn_at_least n scopes - | _ -> c,[],[] + (if n = 0 then [] else List.map (drop_first_implicits n) impls), + List.skipn_at_least n scopes + | _ -> [],[] end - | _ -> c,[],[] + | _ -> [],[] let error_not_enough_arguments ?loc = user_err ?loc (str "Abbreviation is not applied enough.") @@ -1132,27 +1171,37 @@ let check_no_explicitation l = | (_, Some {loc}) :: _ -> user_err ?loc (str"Unexpected explicitation of the argument of an abbreviation.") -let dump_extended_global loc = function - | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob ?loc ref - | SynDef sp -> Dumpglob.add_glob_kn ?loc sp - -let intern_extended_global_of_qualid qid = - let r = Nametab.locate_extended qid in dump_extended_global qid.CAst.loc r; r - -let intern_reference qid = - let r = - try intern_extended_global_of_qualid qid - with Not_found as exn -> - let _, info = Exninfo.capture exn in - Nametab.error_global_not_found ~info qid - in - Smartlocate.global_of_extended_global r - let glob_sort_of_level (level: glob_level) : glob_sort = match level with | UAnonymous {rigid} -> UAnonymous {rigid} | UNamed id -> UNamed [id,0] +let intern_sort_name ~local_univs = function + | CSProp -> GSProp + | CProp -> GProp + | CSet -> GSet + | CRawType u -> GRawUniv u + | CType qid -> + let is_id = qualid_is_ident qid in + let local = if not is_id then None + else Id.Map.find_opt (qualid_basename qid) local_univs.bound + in + match local with + | Some u -> GUniv u + | None -> + try GUniv (Univ.Level.make (Nametab.locate_universe qid)) + with Not_found -> + if is_id && local_univs.unb_univs + then GLocalUniv (CAst.make ?loc:qid.loc (qualid_basename qid)) + else + CErrors.user_err Pp.(str "Undeclared universe " ++ pr_qualid qid ++ str".") + +let intern_sort ~local_univs s = + map_glob_sort_gen (List.map (on_fst (intern_sort_name ~local_univs))) s + +let intern_instance ~local_univs us = + Option.map (List.map (map_glob_sort_gen (intern_sort_name ~local_univs))) us + (* Is it a global reference or a syntactic definition? *) let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let loc = qid.loc in @@ -1194,6 +1243,37 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = in c, None, args2 +let intern_qualid_for_pattern test_global intern_not qid pats = + match intern_extended_global_of_qualid qid with + | TrueGlobal g -> + test_global g; + (g, false, Some [], pats) + | SynDef kn -> + let filter (vars,a) = + match a with + | NRef g -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + test_global g; + let () = assert (List.is_empty vars) in + Some (g, Some [], pats) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) + test_global g; + let () = assert (List.is_empty vars) in + Some (g, None, pats) + | NApp (NRef g,args) -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + test_global g; + let nvars = List.length vars in + if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; + let pats1,pats2 = List.chop nvars pats in + let subst = split_by_type_pat vars (pats1,[]) in + let args = List.map (intern_not subst) args in + Some (g, Some args, pats2) + | _ -> None in + match Syntax_def.search_filtered_syntactic_definition filter kn with + | Some (g, pats1, pats2) -> (g, true, pats1, pats2) + | None -> raise Not_found + let warn_nonprimitive_projection = CWarnings.create ~name:"nonprimitive-projection-syntax" ~category:"syntax" ~default:CWarnings.Disabled Pp.(fun f -> pr_qualid f ++ str " used as a primitive projection but is not one.") @@ -1218,38 +1298,39 @@ let check_applied_projection isproj realref qid = let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us args qid = let loc = qid.CAst.loc in + let us = intern_instance ~local_univs:env.local_univs us in if qualid_is_ident qid then - try - let res = intern_var env lvar namedctx loc (qualid_basename qid) us in - check_applied_projection isproj None qid; - res, args - with Not_found -> - try - let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in - check_applied_projection isproj realref qid; - find_appl_head_data r, args2 - with Not_found as exn -> - (* Extra allowance for non globalizing functions *) - if !interning_grammar || env.unb then - (* check_applied_projection ?? *) - (gvar (loc,qualid_basename qid) us, [], []), args - else - let _, info = Exninfo.capture exn in - Nametab.error_global_not_found ~info qid + try + let res = intern_var env lvar namedctx loc (qualid_basename qid) us in + check_applied_projection isproj None qid; + res, args + with Not_found -> + try + let res, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + check_applied_projection isproj realref qid; + res, args2 + with Not_found as exn -> + (* Extra allowance for non globalizing functions *) + if !interning_grammar || env.unb then + (* check_applied_projection ?? *) + gvar (loc,qualid_basename qid) us, args + else + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid else - let r,realref,args2 = - try intern_qualid qid intern env ntnvars us args - with Not_found as exn -> + try + let res, realref, args2 = intern_qualid qid intern env ntnvars us args in + check_applied_projection isproj realref qid; + res, args2 + with Not_found as exn -> let _, info = Exninfo.capture exn in Nametab.error_global_not_found ~info qid - in - check_applied_projection isproj realref qid; - find_appl_head_data r, args2 let interp_reference vars r = - let (r,_,_),_ = + let r,_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) - {ids = Id.Set.empty; unb = false ; + {ids = Id.Set.empty; unb = false; + local_univs = { bound=Id.Map.empty; unb_univs = false };(* <- doesn't matter here *) tmp_scope = None; scopes = []; impls = empty_internalization_env; binder_block_names = None} Environ.empty_named_context_val @@ -1259,17 +1340,18 @@ let interp_reference vars r = (**********************************************************************) (** {5 Cases } *) -(** Private internalization patterns *) +(** Intermediate type common to the patterns of the "in" and of the + "with" clause of "match" *) + type 'a raw_cases_pattern_expr_r = | RCPatAlias of 'a raw_cases_pattern_expr * lname - | RCPatCstr of GlobRef.t - * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list - (** [RCPatCstr (loc, c, l1, l2)] represents [((@ c l1) l2)] *) + | RCPatCstr of GlobRef.t * 'a raw_cases_pattern_expr list | RCPatAtom of (lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option | RCPatOr of 'a raw_cases_pattern_expr list and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t (** {6 Elementary bricks } *) + let apply_scope_env env = function | [] -> {env with tmp_scope = None}, [] | sc::scl -> {env with tmp_scope = sc}, scl @@ -1282,22 +1364,19 @@ let rec simple_adjust_scopes n scopes = | [] -> None :: simple_adjust_scopes (n-1) [] | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes -let find_remaining_scopes pl1 pl2 ref = - let impls_st = implicits_of_global ref in - let len_pl1 = List.length pl1 in - let len_pl2 = List.length pl2 in - let impl_list = if Int.equal len_pl1 0 - then select_impargs_size len_pl2 impls_st - else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in - let allscs = find_arguments_scope ref in - let scope_list = List.skipn_at_least len_pl1 allscs in - let rec aux = function - |[],l -> l - |_,[] -> [] - |h::t,_::tt when is_status_implicit h -> aux (t,tt) - |_::t,h::tt -> h :: aux (t,tt) - in ((try List.firstn len_pl1 allscs with Failure _ -> simple_adjust_scopes len_pl1 allscs), - simple_adjust_scopes len_pl2 (aux (impl_list,scope_list))) +let rec adjust_to_up l l' default = + match l, l' with + | l, [] -> [] + | [], l -> l + | true::l, l' -> default :: adjust_to_up l l' default + | false::l, y::l' -> y :: adjust_to_up l l' default + +let rec adjust_to_down l l' default = + match l, l' with + | [], l -> [] + | true::l, l' -> adjust_to_down l l' default + | false::l, [] -> default :: adjust_to_down l [] default + | false::l, y::l' -> y :: adjust_to_down l l' default (* @return the first variable that occurs twice in a pattern @@ -1340,85 +1419,16 @@ let check_or_pat_variables loc ids idsl = Id.print (List.hd ids'').v ++ strbrk " is not bound in all patterns).") | [] -> () -(** Use only when params were NOT asked to the user. - @return if letin are included *) -let check_constructor_length env loc cstr len_pl pl0 = - let n = len_pl + List.length pl0 in - if Int.equal n (Inductiveops.constructor_nallargs env cstr) then false else - (Int.equal n (Inductiveops.constructor_nalldecls env cstr) || - (error_wrong_numarg_constructor ?loc env cstr - (Inductiveops.constructor_nrealargs env cstr))) - -open Declarations - -(* Similar to Cases.adjust_local_defs but on RCPat *) -let insert_local_defs_in_pattern (ind,j) l = - let (mib,mip) = Global.lookup_inductive ind in - if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then - (* Optimisation *) l - else - let (ctx, _) = mip.mind_nf_lc.(j-1) in - let decls = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in - let rec aux decls args = - match decls, args with - | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args - | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) - | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args - | _ -> assert false in - aux decls l - -let add_local_defs_and_check_length loc env g pl args = - let open GlobRef in - match g with - | ConstructRef cstr -> - (* We consider that no variables corresponding to local binders - have been given in the "explicit" arguments, which come from a - "@C args" notation or from a custom user notation *) - let pl' = insert_local_defs_in_pattern cstr pl in - let maxargs = Inductiveops.constructor_nalldecls env cstr in - if List.length pl' + List.length args > maxargs then - error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); - (* Two possibilities: either the args are given with explicit - variables for local definitions, then we give the explicit args - extended with local defs, so that there is nothing more to be - added later on; or the args are not enough to have all arguments, - which a priori means local defs to add in the [args] part, so we - postpone the insertion of local defs in the explicit args *) - (* Note: further checks done later by check_constructor_length *) - if List.length pl' + List.length args = maxargs then pl' else pl - | _ -> pl - -let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = - let impl_list = if Int.equal len_pl1 0 - then select_impargs_size (List.length pl2) impls_st - else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in - let remaining_args = List.fold_left (fun i x -> if is_status_implicit x then i else succ i) in - let rec aux i = function - |[],l -> let args_len = List.length l + List.length impl_list + len_pl1 in - ((if Int.equal args_len nargs then false - else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) - ,l) - |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp - then let (b,out) = aux i (q,[]) in (b,(DAst.make @@ RCPatAtom None)::out) - else fail (remaining_args (len_pl1+i) il) - |imp::q,(hh::tt as l) -> if is_status_implicit imp - then let (b,out) = aux i (q,l) in (b,(DAst.make @@ RCPatAtom None)::out) - else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) - in aux 0 (impl_list,pl2) - -let add_implicits_check_constructor_length env loc c len_pl1 pl2 = - let nargs = Inductiveops.constructor_nallargs env c in - let nargs' = Inductiveops.constructor_nalldecls env c in - let impls_st = implicits_of_global (GlobRef.ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) - nargs nargs' impls_st len_pl1 pl2 - -let add_implicits_check_ind_length env loc c len_pl1 pl2 = - let nallargs = inductive_nallargs env c in - let nalldecls = inductive_nalldecls env c in - let impls_st = implicits_of_global (GlobRef.IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) - nallargs nalldecls impls_st len_pl1 pl2 +let check_has_letin ?loc g expanded nargs nimps tags = + let expected_ndecls = List.length tags - nimps in + let expected_nassums = List.count (fun x -> not x) tags - nimps in + if nargs = expected_nassums then false + else if nargs = expected_ndecls then true else + let env = Global.env() in + match g with + | GlobRef.ConstructRef cstr -> error_wrong_numarg_constructor ?loc env ~cstr ~expanded ~nargs ~expected_nassums ~expected_ndecls + | GlobRef.IndRef ind -> error_wrong_numarg_inductive ?loc env ~ind ~expanded ~nargs ~expected_nassums ~expected_ndecls + | _ -> assert false (** Do not raise NotEnoughArguments thanks to preconditions*) let chop_params_pattern loc ind args with_letin = @@ -1432,9 +1442,9 @@ let chop_params_pattern loc ind args with_letin = | PatVar _ | PatCstr(_,_,_) -> error_parameter_not_implicit ?loc:c.CAst.loc) params; args -let find_constructor loc add_params ref = +let find_constructor_head ?loc ref = let open GlobRef in - let (ind,_ as cstr) = match ref with + match ref with | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in @@ -1442,17 +1452,12 @@ let find_constructor loc add_params ref = | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in user_err ?loc ~hdr:"find_constructor" error - in - cstr, match add_params with - | Some nb_args -> - let env = Global.env () in - let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls env cstr) - then Inductiveops.inductive_nparamdecls env ind - else Inductiveops.inductive_nparams env ind - in - List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) - | None -> [] + +let find_inductive_head ?loc ref = + let open GlobRef in + match ref with + | IndRef ind -> ind + | _ -> error_bad_inductive_type ?loc () let find_pattern_variable qid = if qualid_is_ident qid then qualid_basename qid @@ -1467,10 +1472,6 @@ let check_duplicate ?loc fields = user_err ?loc (str "This record defines several times the field " ++ pr_qualid r ++ str ".") -let inductive_of_record loc record = - let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in - Nametab.shortest_qualid_of_global ?loc Id.Set.empty inductive - (** [sort_fields ~complete loc fields completer] expects a list [fields] of field assignments [f = e1; g = e2; ...], where [f, g] are fields of a record and [e1] are "values" (either terms, when @@ -1488,16 +1489,7 @@ let sort_fields ~complete loc fields completer = match fields with | [] -> None | (first_field_ref, _):: _ -> - let (first_field_glob_ref, record) = - try - let gr = locate_reference first_field_ref in - Dumpglob.add_glob ?loc:first_field_ref.CAst.loc gr; - (gr, Recordops.find_projection gr) - with Not_found as exn -> - let _, info = Exninfo.capture exn in - let info = Option.cata (Loc.add_loc info) info loc in - Exninfo.iraise (InternalizationError(NotAProjection first_field_ref), info) - in + let (first_field_glob_ref, record) = intern_projection first_field_ref in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in (* the reference constructor of the record *) @@ -1516,25 +1508,14 @@ let sort_fields ~complete loc fields completer = let rec index_fields fields remaining_projs acc = match fields with | (field_ref, field_value) :: fields -> - let field_glob_ref = try locate_reference field_ref - with Not_found -> - user_err ?loc:field_ref.CAst.loc ~hdr:"intern" - (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in + let field_glob_ref,this_field_record = intern_projection field_ref in let remaining_projs, (field_index, _, regular) = let the_proj = function | (idx, Some glob_id, _) -> GlobRef.equal field_glob_ref (GlobRef.ConstRef glob_id) | (idx, None, _) -> false in try CList.extract_first the_proj remaining_projs with Not_found -> - let floc = field_ref.CAst.loc in - let this_field_record = - try Recordops.find_projection field_glob_ref - with Not_found -> - let inductive_ref = inductive_of_record floc record in - Loc.raise ?loc:floc (InternalizationError(NotAProjectionOf (field_ref, inductive_ref))) in - let ind1 = inductive_of_record floc record in - let ind2 = inductive_of_record floc this_field_record in - Loc.raise ?loc (InternalizationError(ProjectionsOfDifferentRecords (ind1, ind2))) + Loc.raise ?loc (InternalizationError(ProjectionsOfDifferentRecords (record, this_field_record))) in if not regular && complete then (* "regular" is false when the field is defined @@ -1587,8 +1568,8 @@ let merge_aliases aliases {loc;v=na} = { alias_ids; alias_map; } let alias_of als = match als.alias_ids with -| [] -> Anonymous -| {v=id} :: _ -> Name id + | [] -> Anonymous + | {v=id} :: _ -> Name id (** {6 Expanding notations } @@ -1614,29 +1595,33 @@ let product_of_cases_patterns aliases idspl = let rec subst_pat_iterator y t = DAst.(map (function | RCPatAtom id as p -> begin match id with Some ({v=x},_) when Id.equal x y -> DAst.get t | _ -> p end - | RCPatCstr (id,l1,l2) -> - RCPatCstr (id,List.map (subst_pat_iterator y t) l1, - List.map (subst_pat_iterator y t) l2) + | RCPatCstr (id,l) -> + RCPatCstr (id,List.map (subst_pat_iterator y t) l) | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) -| _ -> false + | { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) + | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) -| _ -> false + | { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) + | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref ~depr:false ~key:["Asymmetric";"Patterns"] ~value:false +type global_reference_test = { + for_ind : bool; + test_kind : ?loc:Loc.t -> GlobRef.t -> unit +} + let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) - let ensure_kind test_kind ?loc g = + let ensure_kind {test_kind} ?loc g = try test_kind ?loc g with Not_found -> error_invalid_pattern_notation ?loc () @@ -1644,60 +1629,47 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) - | GHole (_,_,_) -> RCPatAtom (None) - | GRef (g,_) -> RCPatCstr (g,[],[]) + | GHole (_,_,_) -> RCPatAtom None + | GRef (g,_) -> RCPatCstr (g, []) | GApp (r, l) -> begin match DAst.get r with | GRef (g,_) -> let allscs = find_arguments_scope g in - let allscs = simple_adjust_scopes (List.length l) allscs in (* TO CHECK *) - RCPatCstr (g, List.map2 (fun sc a -> rcp_of_glob (sc,snd scopes) a) allscs l,[]) + let allscs = simple_adjust_scopes (List.length l) allscs in + RCPatCstr (g, List.map2 (fun sc a -> rcp_of_glob (sc,snd scopes) a) allscs l) | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") end | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in - let rec drop_syndef test_kind ?loc scopes qid pats = + let make_pars ?loc g = + let env = Global.env () in + let n = match g with + | GlobRef.ConstructRef (ind,_) -> Inductiveops.inductive_nparams env ind + | _ -> 0 in + List.make n (DAst.make ?loc @@ RCPatAtom None) + in + let rec drop_syndef {test_kind} ?loc scopes qid add_par_if_no_ntn_with_par no_impl pats = try - if qualid_is_ident qid && Option.cata (Id.Set.mem (qualid_basename qid)) false env.pat_ids then + if qualid_is_ident qid && Option.cata (Id.Set.mem (qualid_basename qid)) false env.pat_ids && List.is_empty pats then raise Not_found; - match Nametab.locate_extended qid with - | SynDef sp -> - let filter (vars,a) = - try match a with - | NRef g -> - (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind ?loc g; - let () = assert (List.is_empty vars) in - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g, [], List.map2 (in_pat_sc scopes) argscs pats) - | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) - test_kind ?loc g; - let () = assert (List.is_empty vars) in - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g, List.map2 (in_pat_sc scopes) argscs pats, []) - | NApp (NRef g,args) -> - (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind ?loc g; - let nvars = List.length vars in - if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; - let pats1,pats2 = List.chop nvars pats in - let subst = split_by_type_pat vars (pats1,[]) in - let idspl1 = List.map (in_not test_kind_inner qid.loc scopes subst []) args in - let (_,argscs) = find_remaining_scopes pats1 pats2 g in - Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) - | _ -> raise Not_found - with Not_found -> None in - Syntax_def.search_filtered_syntactic_definition filter sp - | TrueGlobal g -> - test_kind ?loc g; - Dumpglob.add_glob ?loc:qid.loc g; - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g,[],List.map2 (in_pat_sc scopes) argscs pats) + let intern_not subst pat = in_not test_kind_inner qid.loc scopes subst [] pat in + let g, expanded, ntnpats, pats = intern_qualid_for_pattern (test_kind ?loc) intern_not qid pats in + match ntnpats with + | None -> + (* deactivate implicit *) + let ntnpats = if add_par_if_no_ntn_with_par then make_pars ?loc g else [] in + Some (g, in_patargs ?loc scopes g expanded true ntnpats pats) + | Some ntnpats -> + let ntnpats = if add_par_if_no_ntn_with_par && ntnpats = [] then make_pars ?loc g else ntnpats in + Some (g, in_patargs ?loc scopes g expanded no_impl ntnpats pats) with Not_found -> None - and in_pat test_kind scopes pt = + and in_pat ({for_ind} as test_kind) scopes pt = let open CAst in let loc = pt.loc in + (* The two policies implied by asymmetric pattern mode *) + let add_par_if_no_ntn_with_par = get_asymmetric_patterns () && not for_ind in + let no_impl = get_asymmetric_patterns () && not for_ind in match pt.v with | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat test_kind scopes p, id) | CPatRecord l -> @@ -1706,36 +1678,22 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = begin match sorted_fields with | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> - let pl = - let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in - List.rev_append pars pl - in - let (_,argscs) = find_remaining_scopes [] pl head in - let pats = List.map2 (in_pat_sc scopes) argscs pl in - DAst.make ?loc @@ RCPatCstr(head, pats, []) + let pars = make_pars ?loc head in + let pats = in_patargs ?loc scopes head true true pars pl in + DAst.make ?loc @@ RCPatCstr(head, pats) end | CPatCstr (head, None, pl) -> begin - match drop_syndef test_kind ?loc scopes head pl with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) + match drop_syndef test_kind ?loc scopes head add_par_if_no_ntn_with_par no_impl pl with + | Some (g,pl) -> DAst.make ?loc @@ RCPatCstr(g, pl) + | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) end | CPatCstr (qid, Some expl_pl, pl) -> - let g = - try Nametab.locate qid - with Not_found as exn -> - let _, info = Exninfo.capture exn in - let info = Option.cata (Loc.add_loc info) info loc in - Exninfo.iraise (InternalizationError (NotAConstructor qid), info) - in - if expl_pl == [] then - (* Convention: (@r) deactivates all further implicit arguments and scopes *) - DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat test_kind_inner scopes) pl, []) - else - (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) - (* but not scopes in expl_pl *) - let (argscs1,_) = find_remaining_scopes expl_pl pl g in - DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat test_kind_inner scopes) pl, []) + begin + match drop_syndef test_kind ?loc scopes qid false true (expl_pl@pl) with + | Some (g,pl) -> DAst.make ?loc @@ RCPatCstr (g, pl) + | None -> Loc.raise ?loc (InternalizationError (NotAConstructor qid)) + end | CPatNotation (_,(InConstrEntry,"- _"),([a],[]),[]) when is_non_zero_pat a -> let p = match a.CAst.v with CPatPrim (Number (_, p)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind test_kind_inner) (Number (SMinus,p)) scopes in @@ -1751,20 +1709,20 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = | CPatDelimiters (key, e) -> in_pat test_kind (None,find_delimiters_scope ?loc key::snd scopes) e | CPatPrim p -> - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc test_kind_inner p scopes in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc test_kind_inner.test_kind p scopes in rcp_of_glob scopes pat | CPatAtom (Some id) -> begin - match drop_syndef test_kind ?loc scopes id [] with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) - | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) + match drop_syndef test_kind ?loc scopes id add_par_if_no_ntn_with_par no_impl [] with + | Some (g, pl) -> DAst.make ?loc @@ RCPatCstr (g, pl) + | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) end | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat test_kind scopes) pl) | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns - are supported only in local binders and only at top level. + are supported only in local binders and only at for_ind level. The only reason they are in the [cases_pattern_expr] type is that the parser needs to factor the "c : t" notation with user defined notations. In the long term, we will try to @@ -1774,7 +1732,46 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = duplicating the levels of the [pattern] rule. *) CErrors.user_err ?loc (Pp.strbrk "Casts are not supported in this pattern.") and in_pat_sc scopes x = in_pat test_kind_inner (x,snd scopes) - and in_not (test_kind:?loc:Loc.t->'a->'b) loc scopes (subst,substlist as fullsubst) args = function + and in_patargs ?loc scopes + gr (* head of the pattern *) + expanded (* tell if comes from a notation (for error reporting) *) + no_impl (* tell if implicit are not expected (for asymmetric patterns, or @, or {| |} *) + ntnpats (* prefix of patterns obtained by expansion of notations or parameter insertion *) + pats (* user given patterns *) + = + let default = DAst.make ?loc @@ RCPatAtom None in + let npats = List.length pats in + let n = List.length ntnpats in + let ntnpats_with_letin, tags = + let tags = match gr with + | GlobRef.ConstructRef cstr -> constructor_alltags (Global.env()) cstr + | GlobRef.IndRef ind -> inductive_alltags (Global.env()) ind + | _ -> assert false in + let ntnpats_with_letin = adjust_to_up tags ntnpats default in + ntnpats_with_letin, List.skipn (List.length ntnpats_with_letin) tags in + let imps = + let imps = + if no_impl then [] else + let impls_st = implicits_of_global gr in + if Int.equal n 0 then select_impargs_size npats impls_st + else List.skipn_at_least n (select_stronger_impargs impls_st) in + adjust_to_down tags imps None in + let subscopes = adjust_to_down tags (List.skipn_at_least n (find_arguments_scope gr)) None in + let has_letin = check_has_letin ?loc gr expanded npats (List.count is_status_implicit imps) tags in + let rec aux imps subscopes tags pats = + match imps, subscopes, tags, pats with + | _, _, true::tags, p::pats when has_letin -> + in_pat_sc scopes None p :: aux imps subscopes tags pats + | _, _, true::tags, _ -> + default :: aux imps subscopes tags pats + | imp::imps, sc::subscopes, false::tags, _ when is_status_implicit imp -> + default :: aux imps subscopes tags pats + | imp::imps, sc::subscopes, false::tags, p::pats -> + in_pat_sc scopes sc p :: aux imps subscopes tags pats + | _, _, [], [] -> [] + | _ -> assert false in + ntnpats_with_letin @ aux imps subscopes tags pats + and in_not test_kind loc scopes (subst,substlist as fullsubst) args = function | NVar id -> let () = assert (List.is_empty args) in begin @@ -1789,22 +1786,15 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = end | NRef g -> ensure_kind test_kind ?loc g; - let (_,argscs) = find_remaining_scopes [] args g in - DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) - | NApp (NRef g,pl) -> + DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true false [] args) + | NApp (NRef g,ntnpl) -> ensure_kind test_kind ?loc g; - let (argscs1,argscs2) = find_remaining_scopes pl args g in - let pl = List.map2 (fun x -> in_not test_kind_inner loc (x,snd scopes) fullsubst []) argscs1 pl in - let pl = add_local_defs_and_check_length loc genv g pl args in - let args = List.map2 (fun x -> in_pat test_kind_inner (x,snd scopes)) argscs2 args in - let pat = - if List.length pl = 0 then - (* Convention: if notation is @f, encoded as NApp(Nref g,[]), then - implicit arguments are not inherited *) - RCPatCstr (g, pl @ args, []) - else - RCPatCstr (g, pl, args) in - DAst.make ?loc @@ pat + let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in + let no_impl = + (* Convention: if notation is @f, encoded as NApp(Nref g,[]), then + implicit arguments are not inherited *) + ntnpl = [] in + DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true no_impl ntnpl args) | NList (x,y,iter,terminator,revert) -> if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); @@ -1837,23 +1827,14 @@ let rec intern_pat genv ntnvars aliases pat = | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in intern_pat genv ntnvars aliases' p - | RCPatCstr (head, expl_pl, pl) -> - if get_asymmetric_patterns () then - let len = if List.is_empty expl_pl then Some (List.length pl) else None in - let c,idslpl1 = find_constructor loc len head in - let with_letin = - check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl) - else - let c,idslpl1 = find_constructor loc None head in - let with_letin, pl2 = - add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) + | RCPatCstr (head, pl) -> + let c = find_constructor_head ?loc head in + intern_cstr_with_all_args loc c true [] pl | RCPatAtom (Some ({loc;v=id},scopes)) -> let aliases = merge_aliases aliases (make ?loc @@ Name id) in set_var_scope ?loc id false scopes ntnvars; (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) (* TO CHECK: aura-t-on id? *) - | RCPatAtom (None) -> + | RCPatAtom None -> let { alias_ids = ids; alias_map = asubst; } = aliases in (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatOr pl -> @@ -1865,8 +1846,9 @@ let rec intern_pat genv ntnvars aliases pat = (ids,List.flatten pl') let intern_cases_pattern test_kind genv ntnvars env aliases pat = + let test = {for_ind=false;test_kind} in intern_pat genv ntnvars aliases - (drop_notations_pattern (test_kind,test_kind) genv env pat) + (drop_notations_pattern (test,test) genv env pat) let _ = intern_cases_pattern_fwd := @@ -1886,21 +1868,21 @@ let intern_ind_pattern genv ntnvars env pat = raise Not_found in let no_not = try - drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat + let test_top = {for_ind=true;test_kind=test_kind_top} in + let test_inner = {for_ind=false;test_kind=test_kind_inner} in + drop_notations_pattern (test_top,test_inner) genv env pat with InternalizationError (NotAConstructor _) as exn -> let _, info = Exninfo.capture exn in error_bad_inductive_type ~info () in let loc = no_not.CAst.loc in match DAst.get no_not with - | RCPatCstr (head, expl_pl, pl) -> - let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc ()) head in - let with_letin, pl2 = add_implicits_check_ind_length genv loc c - (List.length expl_pl) pl in - let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in - (with_letin, + | RCPatCstr (head, pl) -> + let ind = find_inductive_head ?loc head in + let idslpl = List.map (intern_pat genv ntnvars empty_alias) pl in + (true, match product_of_cases_patterns empty_alias idslpl with - | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) + | ids,[asubst,pl] -> (ind,ids,asubst,chop_params_pattern loc ind pl true) | _ -> error_bad_inductive_type ?loc ()) | x -> error_bad_inductive_type ?loc () @@ -1961,17 +1943,22 @@ let extract_explicit_arg imps args = (Id.Map.add id (loc, a) eargs, rargs) in aux args +let extract_regular_arguments args = + List.map_filter (function + | (a,Some pos) -> user_err ?loc:pos.loc (str "Unexpected explicit argument.") + | (a,None) -> Some a) args + (**********************************************************************) (* Main loop *) let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> - let (c,imp,subscopes),_ = + let c,_ = intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) lvar us [] ref in - apply_impargs c env imp subscopes [] loc + apply_impargs env loc c [] | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in @@ -2070,8 +2057,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CNotation (_,(InConstrEntry,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in - let x, impl, scopes = find_appl_head_data c in - apply_impargs x env impl scopes [] loc + apply_impargs env loc c [] | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c | CPrim p -> @@ -2080,12 +2066,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern {env with tmp_scope = None; scopes = find_delimiters_scope ?loc key :: env.scopes} e | CAppExpl ((isproj,ref,us), args) -> - let (f,_,args_scopes),args = + let f,args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref in check_not_notation_variable f ntnvars; + let _,args_scopes = find_appl_head_data env lvar f in (* Rem: GApp(_,f,[]) stands for @f *) if args = [] then DAst.make ?loc @@ GApp (f,[]) else smart_gapp f loc (intern_args env args_scopes (List.map fst args)) @@ -2097,22 +2084,21 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in - let (c,impargs,args_scopes),args = - match f.CAst.v with + (match f.CAst.v with | CRef (ref,us) -> - intern_applied_reference ~isproj intern env - (Environ.named_context_val globalenv) lvar us args ref + let f, args = intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref in + apply_impargs env loc f args | CNotation (_,ntn,ntnargs) -> assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ntnargs in - find_appl_head_data c, args + apply_impargs env loc c args | _ -> - assert (Option.is_empty isproj); - let f = intern_no_implicit env f in - let f, _, args_scopes = find_appl_head_data f in - (f,[],args_scopes), args - in - apply_impargs c env impargs args_scopes args loc + assert (Option.is_empty isproj); + let f = intern_no_implicit env f in + let _, args_scopes = find_appl_head_data env lvar f in + let args = extract_regular_arguments args in + smart_gapp f loc (intern_args env args_scopes args)) | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in @@ -2262,12 +2248,12 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* end *) | CSort s -> DAst.make ?loc @@ - GSort s + GSort (intern_sort ~local_univs:env.local_univs s) | CCast (c1, c2) -> DAst.make ?loc @@ GCast (intern env c1, map_cast_type (intern_type (slide_binders env)) c2) | CArray(u,t,def,ty) -> - DAst.make ?loc @@ GArray(u, Array.map (intern env) t, intern env def, intern env ty) + DAst.make ?loc @@ GArray(intern_instance ~local_univs:env.local_univs u, Array.map (intern env) t, intern env def, intern env ty) ) and intern_type env = intern (set_type_scope env) @@ -2407,10 +2393,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern_args env subscopes rargs in aux 1 l subscopes eargs rargs - and apply_impargs c env imp subscopes l loc = - let imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) l)) imp in - let l = intern_impargs c env imp subscopes l in - smart_gapp c loc l + and apply_impargs env loc c args = + let impl, subscopes = find_appl_head_data env lvar c in + let imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) args)) impl in + let args = intern_impargs c env imp subscopes args in + smart_gapp c loc args and smart_gapp f loc = function | [] -> f @@ -2439,6 +2426,8 @@ let extract_ids env = (Termops.ids_of_rel_context (Environ.rel_context env)) Id.Set.empty +let bound_univs sigma = Evd.universe_binders sigma + let scope_of_type_kind env sigma = function | IsType -> Notation.current_type_scope_name () | OfType typ -> compute_type_scope env sigma typ @@ -2461,8 +2450,9 @@ let intern_gen kind env sigma let tmp_scope = scope_of_type_kind env sigma kind in let k = allowed_binder_kind_of_type_kind kind in internalize env {ids = extract_ids env; unb = false; - tmp_scope = tmp_scope; scopes = []; - impls; binder_block_names = Some (k,Id.Map.domain impls)} + local_univs = { bound = bound_univs sigma; unb_univs = true }; + tmp_scope = tmp_scope; scopes = []; + impls; binder_block_names = Some (k,Id.Map.domain impls)} pattern_mode (ltacvars, Id.Map.empty) c let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c @@ -2551,7 +2541,9 @@ let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) let impls = empty_internalization_env in let k = allowed_binder_kind_of_type_kind kind in internalize env - {ids; unb = false; tmp_scope; scopes = []; impls; + {ids; unb = false; + local_univs = { bound = bound_univs sigma; unb_univs = true }; + tmp_scope; scopes = []; impls; binder_block_names = Some (k,Id.Set.empty)} pattern_mode (ltacvars, vl) c @@ -2561,8 +2553,11 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in let c = internalize env - {ids; unb = false; tmp_scope = None; scopes = []; impls; binder_block_names = None} - false (empty_ltac_sign, vl) a in + {ids; unb = false; + local_univs = { bound = Id.Map.empty; unb_univs = false }; + tmp_scope = None; scopes = []; impls; binder_block_names = None} + false (empty_ltac_sign, vl) a + in (* Splits variables into those that are binding, bound, or both *) (* Translate and check that [c] has all its free variables bound in [vars] *) let a, reversible = notation_constr_of_glob_constr nenv c in @@ -2589,7 +2584,7 @@ let interp_binder_evars env sigma na t = let my_intern_constr env lvar acc c = internalize env acc false lvar c -let intern_context env impl_env binders = +let intern_context env ~bound_univs impl_env binders = let lvar = (empty_ltac_sign, Id.Map.empty) in let ids = (* We assume all ids around are parts of the prefix of the current @@ -2600,6 +2595,7 @@ let intern_context env impl_env binders = let (env, bl) = intern_local_binder_aux (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in (env, bl)) ({ids; unb = false; + local_univs = { bound = bound_univs; unb_univs = true }; tmp_scope = None; scopes = []; impls = impl_env; binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) @@ -2636,17 +2632,21 @@ let interp_glob_context_evars ?(program_mode=false) env sigma bl = sigma, ((env, par), List.rev impls) let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env sigma params = - let int_env,bl = intern_context env impl_env params in + let int_env,bl = intern_context env ~bound_univs:(bound_univs sigma) impl_env params in let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) (** Local universe and constraint declarations. *) +let interp_known_level evd u = + let u = intern_sort_name ~local_univs:{bound = bound_univs evd; unb_univs=false} u in + Pretyping.known_glob_level evd u + let interp_univ_constraints env evd cstrs = let interp (evd,cstrs) (u, d, u') = - let ul = Pretyping.interp_known_glob_level evd u in - let u'l = Pretyping.interp_known_glob_level evd u' in + let ul = interp_known_level evd u in + let u'l = interp_known_level evd u' in let cstr = (ul,d,u'l) in let cstrs' = Univ.Constraint.add cstr cstrs in try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 0de6c3e89d..f92a54e23f 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -88,7 +88,8 @@ val intern_gen : typing_constraint -> env -> evar_map -> val intern_pattern : env -> cases_pattern_expr -> lident list * (Id.t Id.Map.t * cases_pattern) list -val intern_context : env -> internalization_env -> local_binder_expr list -> internalization_env * glob_decl list +val intern_context : env -> bound_univs:UnivNames.universe_binders -> + internalization_env -> local_binder_expr list -> internalization_env * glob_decl list (** {6 Composing internalization with type inference (pretyping) } *) @@ -198,6 +199,8 @@ val check_duplicate : ?loc:Loc.t -> (qualid * constr_expr) list -> unit (** Check that a list of record field definitions doesn't contain duplicates. *) +val interp_known_level : Evd.evar_map -> sort_name_expr -> Univ.Level.t + (** Local universe and constraint declarations. *) val interp_univ_decl : Environ.env -> universe_decl_expr -> Evd.evar_map * UState.universe_decl diff --git a/interp/notation.ml b/interp/notation.ml index b5951a9c59..f2d113954b 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -62,10 +62,11 @@ let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 let notation_binder_source_eq s1 s2 = match s1, s2 with | NtnParsedAsIdent, NtnParsedAsIdent -> true +| NtnParsedAsName, NtnParsedAsName -> true | NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 | NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 | NtnParsedAsBinder, NtnParsedAsBinder -> true -| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _ | NtnParsedAsBinder), _ -> false +| (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _ | NtnParsedAsBinder), _ -> false let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeConstr, NtnTypeConstr -> true @@ -639,7 +640,7 @@ let constr_of_globref allow_constant env sigma = function | GlobRef.IndRef c -> let sigma,c = Evd.fresh_inductive_instance env sigma c in sigma,mkIndU c - | GlobRef.ConstRef c when allow_constant -> + | GlobRef.ConstRef c when allow_constant || Environ.is_primitive_type env c -> let sigma,c = Evd.fresh_constant_instance env sigma c in sigma,mkConstU c | _ -> raise NotAValidPrimToken @@ -691,6 +692,13 @@ let rec constr_of_glob allow_constant to_post post env sigma g = match DAst.get sigma,mkApp (c, Array.of_list cl) end | Glob_term.GInt i -> sigma, mkInt i + | Glob_term.GFloat f -> sigma, mkFloat f + | Glob_term.GArray (_,t,def,ty) -> + let sigma, u' = Evd.fresh_array_instance env sigma in + let sigma, def' = constr_of_glob allow_constant to_post post env sigma def in + let sigma, t' = Array.fold_left_map (constr_of_glob allow_constant to_post post env) sigma t in + let sigma, ty' = constr_of_glob allow_constant to_post post env sigma ty in + sigma, mkArray (u',t',def',ty') | Glob_term.GSort gs -> let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family gs) in sigma,mkSort c @@ -711,6 +719,12 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.IndRef ind, None)) | Var id -> DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) | Int i -> DAst.make ?loc (Glob_term.GInt i) + | Float f -> DAst.make ?loc (Glob_term.GFloat f) + | Array (u,t,def,ty) -> + let def' = glob_of_constr token_kind ?loc env sigma def + and t' = Array.map (glob_of_constr token_kind ?loc env sigma) t + and ty' = glob_of_constr token_kind ?loc env sigma ty in + DAst.make ?loc (Glob_term.GArray (None,t',def',ty')) | Sort Sorts.SProp -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GSProp, 0])) | Sort Sorts.Prop -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GProp, 0])) | Sort Sorts.Set -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GSet, 0])) @@ -781,13 +795,7 @@ end let z_two = Z.of_int 2 (** Conversion from bigint to int63 *) -let rec int63_of_pos_bigint i = - if Z.(equal i zero) then Uint63.of_int 0 - else - let quo, remi = Z.div_rem i z_two in - if Z.(equal remi one) then Uint63.add (Uint63.of_int 1) - (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) - else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) +let int63_of_pos_bigint i = Uint63.of_int64 (Z.to_int64 i) module Numbers = struct (** * Number notation *) @@ -1040,7 +1048,7 @@ let interp_int63 ?loc n = let bigint_of_int63 c = match Constr.kind c with - | Int i -> Z.of_string (Uint63.to_string i) + | Int i -> Z.of_int64 (Uint63.to_int64 i) | _ -> raise NotAValidPrimToken let interp o ?loc n = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index f51d3bfdfb..0e7f085bde 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -863,7 +863,7 @@ let rec push_context_binders vars = function let vars = match DAst.get b with | GLocalAssum (na,_,_) -> Termops.add_vname vars na | GLocalPattern ((disjpat,ids),p,bk,t) -> List.fold_right Id.Set.add ids vars - | GLocalDef (na,_,_,_) -> Termops.add_vname vars na in + | GLocalDef (na,_,_) -> Termops.add_vname vars na in push_context_binders vars bl let is_term_meta id metas = @@ -881,7 +881,7 @@ let is_onlybinding_meta id metas = let is_onlybinding_pattern_like_meta isvar id metas = try match Id.List.assoc id metas with | _,NtnTypeBinder (NtnBinderParsedAsConstr - (AsIdentOrPattern | AsStrictPattern)) -> true + (AsNameOrPattern | AsStrictPattern)) -> true | _,NtnTypeBinder (NtnParsedAsPattern strict) -> not (strict && isvar) | _,NtnTypeBinder NtnParsedAsBinder -> not isvar | _ -> false @@ -1014,9 +1014,9 @@ let unify_binder_upto alp b b' = | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> let alp, na = unify_name_upto alp na na' in alp, DAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') - | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> + | GLocalDef (na,c,t), GLocalDef (na',c',t') -> let alp, na = unify_name_upto alp na na' in - alp, DAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + alp, DAst.make ?loc @@ GLocalDef (na, unify_term alp c c', unify_opt_term alp t t') | GLocalPattern ((disjpat,ids),id,bk,t), GLocalPattern ((disjpat',_),_,bk',t') when List.length disjpat = List.length disjpat' -> let alp, p = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') @@ -1061,7 +1061,7 @@ let rec unify_terms_binders alp cl bl' = | [], [] -> [] | c :: cl, b' :: bl' -> begin match DAst.get b' with - | GLocalDef ( _, _, _, t) -> unify_terms_binders alp cl bl' + | GLocalDef (_, _, t) -> unify_terms_binders alp cl bl' | _ -> unify_term_binder alp c b' :: unify_terms_binders alp cl bl' end | _ -> raise No_match @@ -1249,7 +1249,7 @@ let match_binderlist match_fun alp metas sigma rest x y iter termin revert = with No_match -> match DAst.get rest with | GLetIn (na,c,t,rest') when glue_inner_letin_with_decls -> - let b = DAst.make ?loc:rest.CAst.loc @@ GLocalDef (na,Explicit (*?*), c,t) in + let b = DAst.make ?loc:rest.CAst.loc @@ GLocalDef (na,c,t) in (* collect let-in *) (try aux true sigma (b::bl) rest' with OnlyTrailingLetIns @@ -1533,7 +1533,7 @@ let match_notation_constr ~print_univ c ~vars (metas,pat) = let v = glob_constr_of_cases_pattern (Global.env()) pat in (((vars,v),scl)::terms',termlists',binders',binderlists') | _ -> raise No_match) - | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnParsedAsBinder) -> + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsName | NtnParsedAsPattern _ | NtnParsedAsBinder) -> (terms',termlists',(Id.List.assoc x binders,scl)::binders',binderlists') | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists',binders',binderlists') diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 29db23cc54..c541a19bfd 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -67,7 +67,8 @@ type extended_subscopes = Constrexpr.notation_entry_level * subscopes type constr_as_binder_kind = | AsIdent - | AsIdentOrPattern + | AsName + | AsNameOrPattern | AsStrictPattern type notation_binder_source = @@ -76,6 +77,8 @@ type notation_binder_source = | NtnParsedAsPattern of bool (* This accepts only ident *) | NtnParsedAsIdent + (* This accepts only name *) + | NtnParsedAsName (* This accepts ident, or pattern, or both *) | NtnBinderParsedAsConstr of constr_as_binder_kind (* This accepts ident, _, and quoted pattern *) diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 70be55f843..a953ca8898 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -37,6 +37,9 @@ let wit_pre_ident : string uniform_genarg_type = let wit_int_or_var = make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" +let wit_nat_or_var = + make0 ~dyn:(val_tag (topwit wit_nat)) "nat_or_var" + let wit_ident = make0 "ident" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index bd34af5543..0a8fdf53b1 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -35,6 +35,8 @@ val wit_pre_ident : string uniform_genarg_type val wit_int_or_var : (int or_var, int or_var, int) genarg_type +val wit_nat_or_var : (int or_var, int or_var, int) genarg_type + val wit_ident : Id.t uniform_genarg_type val wit_hyp : (lident, lident, Id.t) genarg_type diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 8990743de2..6255250218 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -716,8 +716,8 @@ value coq_interprete coq_extra_args = Long_val(sp[2]); sp += 3; } else { - /* The recursif argument is an accumulator */ - mlsize_t num_args, i; + /* The recursive argument is an accumulator */ + mlsize_t num_args, sz, i; value block; /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ Alloc_small(accu, rec_pos + 3, Closure_tag); @@ -732,11 +732,22 @@ value coq_interprete accu = block; /* Construction of the accumulator */ num_args = coq_extra_args - rec_pos; - Alloc_small(block, 3 + num_args, Closure_tag); + sz = 3 + num_args; + if (sz <= Max_young_wosize) { + Alloc_small(block, sz, Closure_tag); + Field(block, 2) = accu; + for (i = 3; i < sz; ++i) + Field(block, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + block = caml_alloc_shr(sz, Closure_tag); + caml_initialize(&Field(block, 2), accu); + for (i = 3; i < sz; ++i) + caml_initialize(&Field(block, i), *sp++); + } Code_val(block) = accumulate; Field(block, 1) = Val_int(2); - Field(block, 2) = accu; - for (i = 0; i < num_args; i++) Field(block, i + 3) = *sp++; accu = block; pc = (code_t)(sp[0]); coq_env = sp[1]; @@ -1130,13 +1141,25 @@ value coq_interprete /* Special operations for reduction of open term */ Instruct(ACCUMULATE) { - mlsize_t i, size; + mlsize_t i, size, sz; print_instr("ACCUMULATE"); size = Wosize_val(coq_env); - Alloc_small(accu, size + coq_extra_args + 1, Closure_tag); - for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); - for(i = size; i <= coq_extra_args + size; i++) - Field(accu, i) = *sp++; + sz = size + coq_extra_args + 1; + if (sz <= Max_young_wosize) { + Alloc_small(accu, sz, Closure_tag); + for (i = 0; i < size; ++i) + Field(accu, i) = Field(coq_env, i); + for (i = size; i < sz; ++i) + Field(accu, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + accu = caml_alloc_shr(sz, Closure_tag); + for (i = 0; i < size; ++i) + caml_initialize(&Field(accu, i), Field(coq_env, i)); + for (i = size; i < sz; ++i) + caml_initialize(&Field(accu, i), *sp++); + } pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -1240,13 +1263,24 @@ value coq_interprete Instruct(MAKEACCU) { - int i; + mlsize_t i, sz; print_instr("MAKEACCU"); - Alloc_small(accu, coq_extra_args + 4, Closure_tag); + sz = coq_extra_args + 4; + if (sz <= Max_young_wosize) { + Alloc_small(accu, sz, Closure_tag); + Field(accu, 2) = Field(coq_atom_tbl, *pc); + for (i = 3; i < sz; ++i) + Field(accu, i) = *sp++; + } else { + // too large for Alloc_small, so use caml_alloc_shr instead + // it never triggers a GC, so no need for Setup_for_gc + accu = caml_alloc_shr(sz, Closure_tag); + caml_initialize(&Field(accu, 2), Field(coq_atom_tbl, *pc)); + for (i = 3; i < sz; ++i) + caml_initialize(&Field(accu, i), *sp++); + } Code_val(accu) = accumulate; Field(accu, 1) = Val_int(2); - Field(accu, 2) = Field(coq_atom_tbl, *pc); - for (i = 2; i < coq_extra_args + 3; i++) Field(accu, i + 1) = *sp++; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d92bbe87eb..13568957c2 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -20,7 +20,7 @@ # define DECLARE_NULLOP(name) \ value uint63_##name() { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam0(); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(*cb); \ @@ -28,7 +28,7 @@ value uint63_##name() { \ # define DECLARE_UNOP(name) \ value uint63_##name##_ml(value x) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam1(x); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback(*cb, x)); \ @@ -53,7 +53,7 @@ value uint63_##name##_ml(value x) { \ # define DECLARE_BINOP(name) \ value uint63_##name##_ml(value x, value y) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam2(x, y); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback2(*cb, x, y)); \ @@ -79,7 +79,7 @@ value uint63_##name##_ml(value x, value y) { \ # define DECLARE_TEROP(name) \ value uint63_##name##_ml(value x, value y, value z) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam3(x, y, z); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback3(*cb, x, y, z)); \ diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 17feeb9b5a..d2256720c4 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -263,7 +263,7 @@ let assoc_defined id env = match Environ.lookup_named id env with * before the term is computed. *) -(* Norm means the term is fully normalized and cannot create a redex +(* Ntrl means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) @@ -271,10 +271,10 @@ let assoc_defined id env = match Environ.lookup_named id env with create a redex when substituted Red is used for terms that might be reduced *) -type red_state = Norm | Cstr | Whnf | Red +type red_state = Ntrl | Cstr | Whnf | Red let neutr = function - | Whnf|Norm -> Whnf + | Whnf|Ntrl -> Whnf | Red|Cstr -> Red type optrel = Unknown | KnownR | KnownI @@ -293,13 +293,13 @@ module Mark : sig val neutr : t -> t - val set_norm : t -> t + val set_ntrl : t -> t end = struct type t = int let[@inline] of_state = function - | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + | Ntrl -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 let[@inline] of_relevance = function | Unknown -> 0 @@ -315,15 +315,15 @@ end = struct | _ -> assert false let[@inline] red_state x = match x land 0b1100 with - | 0b0000 -> Norm + | 0b0000 -> Ntrl | 0b0100 -> Cstr | 0b1000 -> Whnf | 0b1100 -> Red | _ -> assert false - let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + let[@inline] neutr x = x lor 0b1000 (* Whnf|Ntrl -> Whnf | Red|Cstr -> Red *) - let[@inline] set_norm x = x land 0b0011 + let[@inline] set_ntrl x = x land 0b0011 end let mark = Mark.mark @@ -358,10 +358,10 @@ and fterm = and finvert = Univ.Instance.t * fconstr array let fterm_of v = v.term -let set_norm v = v.mark <- Mark.set_norm v.mark -let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false +let set_ntrl v = v.mark <- Mark.set_ntrl v.mark +let is_val v = match Mark.red_state v.mark with Ntrl -> true | Cstr | Whnf | Red -> false -let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_atom c = {mark=mark Ntrl Unknown;term=FAtom c} let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose @@ -448,7 +448,7 @@ let rec lft_fconstr n ft = let r = Mark.relevance ft.mark in match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _|FFloat _) -> ft - | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FRel i -> {mark=mark Ntrl r;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} @@ -466,7 +466,7 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} + | Inr(k,None) -> {mark=mark Ntrl Unknown; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} @@ -488,7 +488,7 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Ntrl | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -514,8 +514,8 @@ let mk_clos e t = | Rel i -> clos_rel e i | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } - | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Meta _ | Sort _ -> {mark = mark Ntrl KnownR; term = FAtom t } + | Ind kn -> {mark = mark Ntrl KnownR; term = FInd kn } | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } | Int i -> {mark = mark Cstr Unknown; term = FInt i} | Float f -> {mark = mark Cstr Unknown; term = FFloat f} @@ -734,11 +734,11 @@ let strip_update_shift_app_red head stk = strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -759,6 +759,10 @@ let get_nth_arg head n stk = | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk +let rec subs_consn v i n s = + if Int.equal i n then s + else subs_consn v (i + 1) n (subs_cons v.(i) s) + (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e = function @@ -770,14 +774,13 @@ let rec get_args n tys f e = function get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in - if n == na then (Inl (subs_cons(l,e)),s) + if n == na then (Inl (subs_consn l 0 na e), s) else if n < na then (* more arguments *) - let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in - (Inl (subs_cons(args,e)), Zapp eargs :: s) + (Inl (subs_consn l 0 n e), Zapp eargs :: s) else (* more lambdas *) let etys = List.skipn na tys in - get_args (n-na) etys f (subs_cons(l,e)) s + get_args (n-na) etys f (subs_consn l 0 na e) s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (Inr {mark=mark Cstr Unknown;term=FLambda(n,tys,f,e)}, stk) @@ -787,7 +790,7 @@ let rec eta_expand_stack = function | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Ntrl Unknown; term= FRel 1}|]] (* Get the arguments of a native operator *) let rec skip_native_args rargs nargs = @@ -931,7 +934,11 @@ let contract_fix_vect fix = env, Array.length bds) | _ -> assert false in - (subs_cons(Array.init nfix make_body, env), thisbody) + let rec mk_subs env i = + if Int.equal i nfix then env + else mk_subs (subs_cons (make_body i) env) (i + 1) + in + (mk_subs env 0, thisbody) let unfold_projection info p = if red_projection info.i_flags p @@ -968,7 +975,7 @@ module FNativeEntries = | FArray (_u,t,_ty) -> t | _ -> raise Not_found - let dummy = {mark = mark Norm KnownR; term = FRel 0} + let dummy = {mark = mark Ntrl KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty let defined_int = ref false @@ -978,7 +985,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_int63 with | Some c -> defined_int := true; - fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + fint := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false let defined_float = ref false @@ -988,7 +995,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_float64 with | Some c -> defined_float := true; - ffloat := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + ffloat := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_float := false let defined_bool = ref false @@ -1039,7 +1046,7 @@ module FNativeEntries = fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) }; let (icmp, _) = cEq in - fcmp := { mark = mark Norm KnownR; term = FInd (Univ.in_punivs icmp) } + fcmp := { mark = mark Ntrl KnownR; term = FInd (Univ.in_punivs icmp) } | None -> defined_cmp := false let defined_f_cmp = ref false @@ -1327,19 +1334,19 @@ let rec knr info tab m stk = let rargs, a, nargs, stk = get_native_args1 op c stk in kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) else - (* Similarly to fix, partially applied primitives are not Norm! *) + (* Similarly to fix, partially applied primitives are not Ntrl! *) (m, stk) - | Undef _ | OpaqueDef _ -> (set_norm m; (m,stk))) + | Undef _ | OpaqueDef _ -> (set_ntrl m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info tab (RelKey k) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in @@ -1367,7 +1374,7 @@ let rec knr info tab m stk = knit info tab fxe fxbd (args@stk') | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] as s)) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> - knit info tab (subs_cons([|v|],e)) bd stk + knit info tab (subs_cons v e) bd stk | FEvar(ev,env) -> (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk @@ -1417,7 +1424,7 @@ and case_inversion info tab ci (univs,args) v = let env = info_env info in let ind = ci.ci_ind in let params, indices = Array.chop ci.ci_npar args in - let psubst = subs_cons (params, subs_id 0) in + let psubst = subs_consn params 0 ci.ci_npar (subs_id 0) in let mib = Environ.lookup_mind (fst ind) env in let mip = mib.mind_packets.(snd ind) in (* indtyping enforces 1 ctor with no letins in the context *) @@ -1523,9 +1530,9 @@ let norm_val info tab v = with_stats (lazy (kl info tab v)) let whd_stack infos tab m stk = match Mark.red_state m.mark with -| Whnf | Norm -> +| Whnf | Ntrl -> (** No need to perform [kni] nor to unlock updates because - every head subterm of [m] is [Whnf] or [Norm] *) + every head subterm of [m] is [Whnf] or [Ntrl] *) knh infos m stk | Red | Cstr -> let k = kni infos tab m stk in diff --git a/kernel/constr.ml b/kernel/constr.ml index 3157ec9f57..bbaf95c9df 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -624,30 +624,6 @@ let map_branches_with_binders g f l ci bl = let map_return_predicate_with_binders g f l ci p = map_under_context_with_binders g f l (List.length ci.ci_pp_info.ind_tags) p -let rec map_under_context_with_full_binders g f l n d = - if n = 0 then f l d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f l b in - let t' = f l t in - let c' = map_under_context_with_full_binders g f (g (Context.Rel.Declaration.LocalDef (na,b,t)) l) (n-1) c in - if b' == b && t' == t && c' == c then d - else mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f l t in - let b' = map_under_context_with_full_binders g f (g (Context.Rel.Declaration.LocalAssum (na,t)) l) (n-1) b in - if t' == t && b' == b then d - else mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches_with_full_binders g f l ci bl = - let tags = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context_with_full_binders g f l) tags bl in - if Array.for_all2 (==) bl' bl then bl else bl' - -let map_return_predicate_with_full_binders g f l ci p = - map_under_context_with_full_binders g f l (List.length ci.ci_pp_info.ind_tags) p - let map_invert f = function | NoInvert -> NoInvert | CaseInvert {univs;args;} as orig -> @@ -886,29 +862,6 @@ let liftn n k c = let lift n = liftn n 1 -let fold_with_full_binders g f n acc c = - let open Context.Rel.Declaration in - match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ -> acc - | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c - | App (c,l) -> Array.fold_left (f n) (f n acc c) l - | Proj (_,c) -> f n acc c - | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | Array(_u,t,def,ty) -> f n (f n (Array.fold_left (f n) acc t) def) ty - - type 'univs instance_compare_fn = (GlobRef.t * int) option -> 'univs -> 'univs -> bool diff --git a/kernel/constr.mli b/kernel/constr.mli index 62f2555a7e..ed63ac507c 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -478,25 +478,6 @@ val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr -(** [map_under_context_with_full_binders g f n l c] is similar to - [map_under_context_with_binders] except that [g] takes also a full - binder as argument and that only the number of binders (and not - their signature) is required *) - -val map_under_context_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr - -(** [map_branches_with_full_binders g f l br] is equivalent to - [map_branches_with_binders] but using - [map_under_context_with_full_binders] *) - -val map_branches_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array - -(** [map_return_predicate_with_full_binders g f l p] is equivalent to - [map_return_predicate_with_binders] but using - [map_under_context_with_full_binders] *) - -val map_return_predicate_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr - (** {6 Functionals working on the immediate subterm of a construction } *) (** [fold f acc c] folds [f] on the immediate subterms of [c] @@ -505,10 +486,6 @@ val map_return_predicate_with_full_binders : ((constr, constr) Context.Rel.Decla val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a -val fold_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> - 'a -> 'b -> constr -> 'b - val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a (** [map f c] maps [f] on the immediate subterms of [c]; it is diff --git a/kernel/environ.ml b/kernel/environ.ml index 69edb1498c..6f2aeab203 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -479,6 +479,9 @@ let set_typing_flags c env = let env = set_type_in_type (not c.check_universes) env in env +let update_typing_flags ?typing_flags env = + Option.cata (fun flags -> set_typing_flags flags env) env typing_flags + let set_cumulative_sprop b env = set_typing_flags {env.env_typing_flags with cumulative_sprop=b} env @@ -568,11 +571,26 @@ let is_primitive env c = | Declarations.Primitive _ -> true | _ -> false +let is_int63_type env c = + match env.retroknowledge.Retroknowledge.retro_int63 with + | None -> false + | Some c' -> Constant.CanOrd.equal c c' + +let is_float64_type env c = + match env.retroknowledge.Retroknowledge.retro_float64 with + | None -> false + | Some c' -> Constant.CanOrd.equal c c' + let is_array_type env c = match env.retroknowledge.Retroknowledge.retro_array with | None -> false | Some c' -> Constant.CanOrd.equal c c' +let is_primitive_type env c = + (* dummy match to force an update if we add a primitive type, seperated clauses to satisfy ocaml 4.05 *) + let _ = function CPrimitives.(PTE(PT_int63)) -> () | CPrimitives.(PTE(PT_float64)) -> () | CPrimitives.(PTE(PT_array)) -> () in + is_int63_type env c || is_float64_type env c || is_array_type env c + let polymorphic_constant cst env = Declareops.constant_is_polymorphic (lookup_constant cst env) diff --git a/kernel/environ.mli b/kernel/environ.mli index 6a8ddce835..dfd9173d10 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -250,6 +250,10 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option val is_primitive : env -> Constant.t -> bool val is_array_type : env -> Constant.t -> bool +val is_int63_type : env -> Constant.t -> bool +val is_float64_type : env -> Constant.t -> bool +val is_primitive_type : env -> Constant.t -> bool + (** {6 Primitive projections} *) @@ -351,6 +355,9 @@ val set_type_in_type : bool -> env -> env val set_allow_sprop : bool -> env -> env val sprop_allowed : env -> bool +(** [update_typing_flags ?typing_flags] may update env with optional typing flags *) +val update_typing_flags : ?typing_flags:typing_flags -> env -> env + val universes_of_global : env -> GlobRef.t -> AUContext.t (** {6 Sets of referred section variables } diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 3e8502b988..afd8e3ef67 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -60,127 +60,188 @@ let rec is_lift_id = function (* Substitutions *) (*********************) -(* (bounded) explicit substitutions of type 'a *) -type 'a subs = - | ESID of int (* ESID(n) = %n END bounded identity *) - | CONS of 'a array * 'a subs - (* CONS([|t1..tn|],S) = - (S.t1...tn) parallel substitution - beware of the order *) - | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) - (* with n vars *) - | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) - -(* operations of subs: collapses constructors when possible. - * Needn't be recursive if we always use these functions - *) - -let subs_id i = ESID i - -let subs_cons(x,s) = if Int.equal (Array.length x) 0 then s else CONS(x,s) - -let subs_liftn n = function - | ESID p -> ESID (p+n) (* bounded identity lifted extends by p *) - | LIFT (p,lenv) -> LIFT (p+n, lenv) - | lenv -> LIFT (n,lenv) - -let subs_lift a = subs_liftn 1 a -let subs_liftn n a = if Int.equal n 0 then a else subs_liftn n a - -let subs_shft = function - | (0, s) -> s - | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) - | (n, s) -> SHIFT (n,s) -let subs_shft s = if Int.equal (fst s) 0 then snd s else subs_shft s - -let subs_shift_cons = function - (0, s, t) -> CONS(t,s) -| (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1)) -| (k, s, t) -> CONS(t,SHIFT(k, s));; - -(* Tests whether a substitution is equal to the identity *) -let rec is_subs_id = function - ESID _ -> true - | LIFT(_,s) -> is_subs_id s - | SHIFT(0,s) -> is_subs_id s - | CONS(x,s) -> Int.equal (Array.length x) 0 && is_subs_id s - | _ -> false - -(* Expands de Bruijn k in the explicit substitution subs - * lams accumulates de shifts to perform when retrieving the i-th value - * the rules used are the following: - * - * [id]k --> k - * [S.t]1 --> t - * [S.t]k --> [S](k-1) if k > 1 - * [^n o S] k --> [^n]([S]k) - * [(%n S)] k --> k if k <= n - * [(%n S)] k --> [^n]([S](k-n)) - * - * the result is (Inr (k+lams,p)) when the variable is just relocated - * where p is None if the variable points inside subs and Some(k) if the - * variable points k bindings beyond subs. - *) -let rec exp_rel lams k subs = - match subs with - | CONS (def,_) when k <= Array.length def - -> Inl(lams,def.(Array.length def - k)) - | CONS (v,l) -> exp_rel lams (k - Array.length v) l - | LIFT (n,_) when k<=n -> Inr(lams+k,None) - | LIFT (n,l) -> exp_rel (n+lams) (k-n) l - | SHIFT (n,s) -> exp_rel (n+lams) k s - | ESID n when k<=n -> Inr(lams+k,None) - | ESID n -> Inr(lams+k,Some (k-n)) - -let expand_rel k subs = exp_rel 0 k subs - -let rec subs_map f = function -| ESID _ as s -> s -| CONS (x, s) -> CONS (Array.map f x, subs_map f s) -| SHIFT (n, s) -> SHIFT (n, subs_map f s) -| LIFT (n, s) -> LIFT (n, subs_map f s) - -let rec lift_subst mk_cl s1 s2 = match s1 with -| ELID -> subs_map (fun c -> mk_cl ELID c) s2 -| ELSHFT(s, k) -> subs_shft(k, lift_subst mk_cl s s2) -| ELLFT (k, s) -> - match s2 with - | CONS(x,s') -> - CONS(CArray.Fun1.map mk_cl s1 x, lift_subst mk_cl s1 s') - | ESID n -> lift_subst mk_cl s (ESID (n + k)) - | SHIFT(k',s') -> - if k<k' - then subs_shft(k, lift_subst mk_cl s (subs_shft(k'-k, s'))) - else subs_shft(k', lift_subst mk_cl (el_liftn (k-k') s) s') - | LIFT(k',s') -> - if k<k' - then subs_liftn k (lift_subst mk_cl s (subs_liftn (k'-k) s')) - else subs_liftn k' (lift_subst mk_cl (el_liftn (k-k') s) s') - -let rec comp mk_cl s1 s2 = - match (s1, s2) with - | _, ESID _ -> s1 - | ESID _, _ -> s2 - | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) - | _, CONS(x,s') -> - CONS(Array.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') - | CONS(x,s), SHIFT(k,s') -> - let lg = Array.length x in - if k == lg then comp mk_cl s s' - else if k > lg then comp mk_cl s (SHIFT(k-lg, s')) - else comp mk_cl (CONS(Array.sub x 0 (lg-k), s)) s' - | CONS(x,s), LIFT(k,s') -> - let lg = Array.length x in - if k == lg then CONS(x, comp mk_cl s s') - else if k > lg then CONS(x, comp mk_cl s (LIFT(k-lg, s'))) - else - CONS(Array.sub x (lg-k) k, - comp mk_cl (CONS(Array.sub x 0 (lg-k),s)) s') - | LIFT(k,s), SHIFT(k',s') -> - if k<k' - then subs_shft(k, comp mk_cl s (subs_shft(k'-k, s'))) - else subs_shft(k', comp mk_cl (subs_liftn (k-k') s) s') - | LIFT(k,s), LIFT(k',s') -> - if k<k' - then subs_liftn k (comp mk_cl s (subs_liftn (k'-k) s')) - else subs_liftn k' (comp mk_cl (subs_liftn (k-k') s) s') +(* Variant of skewed lists enriched w.r.t. a monoid. See the Range module. + + In addition to the indexed data, every node contains a monoid element, in our + case, integers. It corresponds to the number of partial shifts to apply when + reaching this subtree. The total shift is obtained by summing all the partial + shifts encountered in the tree traversal. For efficiency, we also cache the + sum of partial shifts of the whole subtree as the last argument of the [Node] + constructor. + + A more intuitive but inefficient representation of this data structure would + be a list of terms interspeded with shifts, as in + + type 'a subst = NIL | CONS of 'a or_var * 'a subst | SHIFT of 'a subst + + On this inefficient representation, the typing rules would be: + + · ⊢ NIL : · + Γ ⊢ σ : Δ and Γ ⊢ t : A{σ} implies Γ ⊢ CONS (t, σ) : Δ, A + Γ ⊢ σ : Δ implies Γ, A ⊢ SHIFT σ : Δ + + The efficient representation is isomorphic to this naive variant, except that + shifts are grouped together, and we use skewed lists instead of lists. + +*) + +type shf = int +let cmp n m = n + m +let idn = 0 + +type 'a or_var = Arg of 'a | Var of int + +type 'a tree = +| Leaf of shf * 'a or_var +| Node of shf * 'a or_var * 'a tree * 'a tree * shf +(* + Invariants: + - All trees are complete. + - Define get_shift inductively as [get_shift (Leaf (w, _)) := w] and + [get_shift (Node (w, _, t1, t2, _)) := w + t1 + t2] then for every tree + of the form Node (_, _, t1, t2, sub), we must have + sub = get_shift t1 + get_shift t2. + + In the naive semantics: + + Leaf (w, x) := SHIFT^w (CONS (x, NIL)) + Node (w, x, t1, t2, _) := SHIFT^w (CONS (x, t1 @ t2)) + +*) + +type 'a subs = Nil of shf * int | Cons of int * 'a tree * 'a subs +(* + In the naive semantics mentioned above, we have the following. + + Nil (w, n) stands for SHIFT^w (ID n) where ID n is a compact form of identity + substitution, defined inductively as + + ID 0 := NIL + ID (S n) := CONS (Var 1, SHIFT (ID n)) + + Cons (h, t, s) stands for (t @ s) and h is the total number of values in the + tree t. In particular, it is always of the form 2^n - 1 for some n. +*) + +(* Returns the number of shifts contained in the whole tree. *) +let eval = function +| Leaf (w, _) -> w +| Node (w1, _, _, _, w2) -> cmp w1 w2 + +let leaf x = Leaf (idn, x) +let node x t1 t2 = Node (idn, x, t1, t2, cmp (eval t1) (eval t2)) + +let rec tree_get h w t i = match t with +| Leaf (w', x) -> + let w = cmp w w' in + if i = 0 then w, Inl x else assert false +| Node (w', x, t1, t2, _) -> + let w = cmp w w' in + if i = 0 then w, Inl x + else + let h = h / 2 in + if i <= h then tree_get h w t1 (i - 1) + else tree_get h (cmp w (eval t1)) t2 (i - h - 1) + +let rec get w l i = match l with +| Nil (w', n) -> + let w = cmp w w' in + if i < n then w, Inl (Var (i + 1)) + else n + w, Inr (i - n) (* FIXME: double check *) +| Cons (h, t, rem) -> + if i < h then tree_get h w t i else get (cmp (eval t) w) rem (i - h) + +let get l i = get idn l i + +let tree_write w = function +| Leaf (w', x) -> Leaf (cmp w w', x) +| Node (w', x, t1, t2, wt) -> Node (cmp w w', x, t1, t2, wt) + +let write w l = match l with +| Nil (w', n) -> Nil (cmp w w', n) +| Cons (h, t, rem) -> Cons (h, tree_write w t, rem) + +let cons x l = match l with +| Cons (h1, t1, Cons (h2, t2, rem)) -> + if Int.equal h1 h2 then Cons (1 + h1 + h2, node x t1 t2, rem) + else Cons (1, leaf x, l) +| _ -> Cons (1, leaf x, l) + +let expand_rel n s = + let k, v = get s (n - 1) in + match v with + | Inl (Arg v) -> Inl (k, v) + | Inl (Var i) -> Inr (k + i, None) + | Inr i -> Inr (k + i + 1, Some (i + 1)) + +let is_subs_id = function +| Nil (w, _) -> Int.equal w 0 +| Cons (_, _, _) -> false + +let subs_cons v s = cons (Arg v) s + +let rec push_vars i s = + if Int.equal i 0 then s + else push_vars (pred i) (cons (Var i) s) + +let subs_liftn n s = + if Int.equal n 0 then s + else match s with + | Nil (0, m) -> Nil (0, m + n) (* Preserve identity substitutions *) + | Nil _ | Cons _ -> + let s = write n s in + push_vars n s + +let subs_lift s = match s with +| Nil (0, m) -> Nil (0, m + 1) (* Preserve identity substitutions *) +| Nil _ | Cons _ -> + cons (Var 1) (write 1 s) + +let subs_id n = Nil (0, n) + +let subs_shft (n, s) = write n s + +(* pop is the n-ary tailrec variant of a function whose typing rules would be + given as follows. Assume Γ ⊢ e : Δ, A, then + - Γ := Ξ, A, Ω for some Ξ and Ω with |Ω| := fst (pop e) + - Ξ ⊢ snd (pop e) : Δ +*) +let rec pop n i e = + if Int.equal n 0 then i, e + else match e with + | ELID -> i, e + | ELLFT (k, e) -> + if k <= n then pop (n - k) i e + else i, ELLFT (k - n, e) + | ELSHFT (e, k) -> pop n (i + k) e + +let apply mk e = function +| Var i -> Var (reloc_rel i e) +| Arg v -> Arg (mk e v) + +let rec tree_map mk e = function +| Leaf (w, x) -> + let (n, e) = pop w 0 e in + Leaf (w + n, apply mk e x), e +| Node (w, x, t1, t2, _) -> + let (n, e) = pop w 0 e in + let x = apply mk e x in + let t1, e = tree_map mk e t1 in + let t2, e = tree_map mk e t2 in + Node (w + n, x, t1, t2, cmp (eval t1) (eval t2)), e + +let rec lift_id e n = match e with +| ELID -> Nil (0, n) +| ELSHFT (e, k) -> write k (lift_id e n) +| ELLFT (k, e) -> + if k <= n then subs_liftn k (lift_id e (n - k)) + else assert false + +let rec lift_subst mk e s = match s with +| Nil (w, m) -> + let (n, e) = pop w 0 e in + write (w + n) (lift_id e m) +| Cons (h, t, rem) -> + let t, e = tree_map mk e t in + let rem = lift_subst mk e rem in + Cons (h, t, rem) diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 4239e42adc..8ff29ab07a 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -11,28 +11,38 @@ (** Explicit substitutions *) (** {6 Explicit substitutions } *) -(** Explicit substitutions of type ['a]. - - ESID(n) = %n END bounded identity - - CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution - (beware of the order: indice 1 is substituted by tn) - - SHIFT(n,S) = (^n o S) terms in S are relocated with n vars - - LIFT(n,S) = (%n S) stands for ((^n o S).n...1) - (corresponds to S crossing n binders) *) -type 'a subs = private - | ESID of int - | CONS of 'a array * 'a subs - | SHIFT of int * 'a subs - | LIFT of int * 'a subs +(** Explicit substitutions for some type of terms ['a]. + + Assuming terms enjoy a notion of typability Γ ⊢ t : A, where Γ is a + telescope and A a type, substitutions can be typed as Γ ⊢ σ : Δ, where + as a first approximation σ is a list of terms u₁; ...; uₙ s.t. + Δ := (x₁ : A₁), ..., (xₙ : Aₙ) and Γ ⊢ uᵢ : Aᵢ{u₁...uᵢ₋₁} for all 1 ≤ i ≤ n. + + Substitutions can be applied to terms as follows, and furthermore + if Γ ⊢ σ : Δ and Δ ⊢ t : A, then Γ ⊢ t{σ} : A{σ}. + + We make the typing rules explicit below, but we omit the explicit De Bruijn + fidgetting and leave relocations implicit in terms and types. + +*) +type 'a subs (** Derived constructors granting basic invariants *) + +(** Assuming |Γ| = n, Γ ⊢ subs_id n : Γ *) val subs_id : int -> 'a subs -val subs_cons: 'a array * 'a subs -> 'a subs + +(** Assuming Γ ⊢ σ : Δ and Γ ⊢ t : A{σ}, then Γ ⊢ subs_cons t σ : Δ, A *) +val subs_cons: 'a -> 'a subs -> 'a subs + +(** Assuming Γ ⊢ σ : Δ and |Ξ| = n, then Γ, Ξ ⊢ subs_shft (n, σ) : Δ *) val subs_shft: int * 'a subs -> 'a subs + +(** Unary variant of {!subst_liftn}. *) val subs_lift: 'a subs -> 'a subs -val subs_liftn: int -> 'a subs -> 'a subs -(** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) -val subs_shift_cons: int * 'a subs * 'a array -> 'a subs +(** Assuming Γ ⊢ σ : Δ and |Ξ| = n, then Γ, Ξ ⊢ subs_liftn n σ : Δ, Ξ *) +val subs_liftn: int -> 'a subs -> 'a subs (** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution [subs]. The result is either (Inl(lams,v)) when the variable is @@ -51,7 +61,6 @@ val is_subs_id: 'a subs -> bool mk_clos is used when a closure has to be created, i.e. when s1 is applied on an element of s2. *) -val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {6 Compact representation } *) (** Compact representation of explicit relocations @@ -60,6 +69,10 @@ val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs Invariant ensured by the private flag: no lift contains two consecutive [ELSHFT] nor two consecutive [ELLFT]. + + Relocations are a particular kind of substitutions that only contain + variables. In particular, [el_*] enjoys the same typing rules as the + equivalent substitution function [subs_*]. *) type lift = private | ELID @@ -77,5 +90,7 @@ val is_lift_id : lift -> bool substitution equivalent to applying el then s. Argument mk_clos is used when a closure has to be created, i.e. when el is applied on an element of s. + + That is, if Γ ⊢ e : Δ and Δ ⊢ σ : Ξ, then Γ ⊢ lift_subst mk e σ : Ξ. *) val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index e34b3c0b47..ce12d65614 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -330,33 +330,45 @@ let check_allowed_sort ksort specif = let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(elim_sort specif, ksort,s,error_elim_explain ksort s))) -let is_correct_arity env c pj ind specif params = +let check_correct_arity env c pj ind specif params = + (* We use l2r:true for compat with old versions which used CONV + instead of CUMUL called with arguments flipped. It is relevant + for performance eg in bedrock / Kami. *) let arsign,_ = get_instantiated_arity ind specif params in - let rec srec env pt ar = + let rec srec env ar pt = let pt' = whd_all env pt in - match kind pt', ar with - | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - let () = - try conv env a1 a1' - with NotConvertible -> raise (LocalArity None) in - srec (push_rel (LocalAssum (na1,a1)) env) t ar' - (* The last Prod domain is the type of the scrutinee *) - | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (LocalAssum (na1,a1)) env in - let ksort = match kind (whd_all env' a2) with - | Sort s -> Sorts.family s - | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind specif params in - let _ = - try conv env a1 dep_ind - with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif - | _, (LocalDef _ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' - | _ -> - raise (LocalArity None) + match ar, kind pt' with + | (LocalAssum (_,a1))::ar', Prod (na1,a1',t) -> + let () = + try conv_leq ~l2r:true env a1 a1' + with NotConvertible -> raise (LocalArity None) in + srec (push_rel (LocalAssum (na1,a1)) env) ar' t + (* The last Prod domain is the type of the scrutinee *) + | [], Prod (na1,a1',a2) -> + let env' = push_rel (LocalAssum (na1,a1')) env in + let ksort = match kind (whd_all env' a2) with + | Sort s -> Sorts.family s + | _ -> raise (LocalArity None) + in + let dep_ind = build_dependent_inductive ind specif params in + let () = + (* This ensures that the type of the scrutinee is <= the + inductive type declared in the predicate. *) + try conv_leq ~l2r:true env dep_ind a1' + with NotConvertible -> raise (LocalArity None) + in + let () = check_allowed_sort ksort specif in + (* We return the "higher" inductive universe instance from the predicate, + the branches must be typeable using these universes. + The find_rectype call cannot fail due to the cumulativity check above. *) + let (pind, _args) = find_rectype env a1' in + pind + | (LocalDef _ as d)::ar', _ -> + srec (push_rel d env) ar' (lift 1 pt') + | _ -> + raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) + try srec env (List.rev arsign) pj.uj_type with LocalArity kinds -> error_elim_arity env ind c pj kinds @@ -387,17 +399,16 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let build_case_type env n p c realargs = whd_betaiota env (Term.lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) -let type_case_branches env (pind,largs) pj c = - let specif = lookup_mind_specif env (fst pind) in +let type_case_branches env ((ind, _ as pind),largs) pj c = + let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in - let () = is_correct_arity env c pj pind specif params in + let pind = check_correct_arity env c pj pind specif params in let lc = build_branches_type pind specif params p in let ty = build_case_type env (snd specif).mind_nrealdecls p c realargs in (lc, ty) - (************************************************************************) (* Checking the case annotation is relevant *) diff --git a/kernel/names.ml b/kernel/names.ml index 13761ca245..be65faf234 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1115,3 +1115,5 @@ let eq_egr e1 e2 = match e1, e2 with type lident = Id.t CAst.t type lname = Name.t CAst.t type lstring = string CAst.t + +let lident_eq = CAst.eq Id.equal diff --git a/kernel/names.mli b/kernel/names.mli index 74a4e6f7d0..747299bb12 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -727,3 +727,5 @@ val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool type lident = Id.t CAst.t type lname = Name.t CAst.t type lstring = string CAst.t + +val lident_eq : lident -> lident -> bool diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 18f16f427d..b27c53ef0f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -102,7 +102,7 @@ let decompose_Llam_Llet lam = let subst_id = subs_id 0 let lift = subs_lift let liftn = subs_liftn -let cons v subst = subs_cons([|v|], subst) +let cons v subst = subs_cons v subst let shift subst = subs_shft (1, subst) (* Linked code location utilities *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 6abd283f6c..a35f94e3ce 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -247,6 +247,15 @@ let set_native_compiler b senv = let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } +(* Temporary sets custom typing flags *) +let with_typing_flags ?typing_flags senv ~f = + match typing_flags with + | None -> f senv + | Some typing_flags -> + let orig_typing_flags = Environ.typing_flags senv.env in + let res, senv = f (set_typing_flags typing_flags senv) in + res, set_typing_flags orig_typing_flags senv + (** Check that the engagement [c] expected by a library matches the current (initial) one *) let check_engagement env expected_impredicative_set = @@ -928,6 +937,9 @@ let add_constant l decl senv = in kn, senv +let add_constant ?typing_flags l decl senv = + with_typing_flags ?typing_flags senv ~f:(add_constant l decl) + let add_private_constant l decl senv : (Constant.t * private_constants) * safe_environment = let kn = Constant.make2 senv.modpath l in let cb = @@ -983,6 +995,9 @@ let add_mind l mie senv = let mib = Indtypes.check_inductive senv.env ~sec_univs kn mie in kn, add_checked_mind kn mib senv +let add_mind ?typing_flags l mie senv = + with_typing_flags ?typing_flags senv ~f:(add_mind l mie) + (** Insertion of module types *) let add_modtype l params_mte inl senv = diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 6fa9022906..287274e39a 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -93,6 +93,7 @@ val export_private_constants : (** returns the main constant *) val add_constant : + ?typing_flags:Declarations.typing_flags -> Label.t -> global_declaration -> Constant.t safe_transformer (** Similar to add_constant but also returns a certificate *) @@ -102,6 +103,7 @@ val add_private_constant : (** Adding an inductive type *) val add_mind : + ?typing_flags:Declarations.typing_flags -> Label.t -> Entries.mutual_inductive_entry -> MutInd.t safe_transformer diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 85e24f87b7..802a32b0e7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -198,7 +198,7 @@ let type_of_apply env func funt argsv argstv = let argt = argstv.(i) in let c1 = term_of_fconstr c1 in begin match conv_leq false env argt c1 with - | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) + | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons (inject arg) e) c2) | exception NotConvertible -> error_cant_apply_bad_type env (i+1,c1,argt) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 6b47dfc61d..6b2519918a 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -17,6 +17,7 @@ val maxuint31 : t val of_int : int -> t val to_int2 : t -> int * int (* msb, lsb *) val of_int64 : Int64.t -> t +val to_int64 : t -> Int64.t (* val of_uint : int -> t *) @@ -32,7 +33,6 @@ val hash : t -> int (* conversion to a string *) val to_string : t -> string -val of_string : string -> t val compile : t -> string diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 5b2d934b5d..988611df3e 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -23,9 +23,10 @@ let one = Int64.one (* conversion from an int *) let mask63 i = Int64.logand i maxuint63 -let of_int i = Int64.of_int i +let of_int i = mask63 (Int64.of_int i) let to_int2 i = (Int64.to_int (Int64.shift_right_logical i 31), Int64.to_int i) -let of_int64 i = i +let of_int64 = mask63 +let to_int64 i = i let to_int_min n m = if Int64.(compare n (of_int m)) < 0 then Int64.to_int n else m @@ -41,13 +42,6 @@ let hash i = (* conversion of an uint63 to a string *) let to_string i = Int64.to_string i -let of_string s = - let i64 = Int64.of_string s in - if Int64.compare Int64.zero i64 <= 0 - && Int64.compare i64 maxuint63 <= 0 - then i64 - else raise (Failure "Int63.of_string") - (* Compiles an unsigned int to OCaml code *) let compile i = Printf.sprintf "Uint63.of_int64 (%LiL)" i @@ -72,12 +66,12 @@ let l_xor x y = Int64.logxor x y (* addition of int63 *) let add x y = mask63 (Int64.add x y) -let addcarry x y = add (add x y) Int64.one +let addcarry x y = mask63 Int64.(add (add x y) one) (* subtraction *) let sub x y = mask63 (Int64.sub x y) -let subcarry x y = sub (sub x y) Int64.one +let subcarry x y = mask63 Int64.(sub (sub x y) one) (* multiplication *) let mul x y = mask63 (Int64.mul x y) diff --git a/kernel/uint63_63.ml b/kernel/uint63_63.ml index 21f57e2bfb..8d052d6593 100644 --- a/kernel/uint63_63.ml +++ b/kernel/uint63_63.ml @@ -25,7 +25,8 @@ let of_int i = i let to_int2 i = (0,i) -let of_int64 _i = assert false +let of_int64 = Int64.to_int +let to_int64 = to_uint64 let of_float = int_of_float @@ -39,13 +40,6 @@ let hash i = i (* conversion of an uint63 to a string *) let to_string i = Int64.to_string (to_uint64 i) -let of_string s = - let i64 = Int64.of_string s in - if Int64.compare Int64.zero i64 <= 0 - && Int64.compare i64 maxuint63 <= 0 - then Int64.to_int i64 - else raise (Failure "Int64.of_string") - (* Compiles an unsigned int to OCaml code *) let compile i = Printf.sprintf "Uint63.of_int (%i)" i diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 9cca204e8c..390fa58883 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -179,7 +179,7 @@ let decompose_Llam lam = let subst_id = subs_id 0 let lift = subs_lift let liftn = subs_liftn -let cons v subst = subs_cons([|v|], subst) +let cons v subst = subs_cons v subst let shift subst = subs_shft (1, subst) (* A generic map function *) diff --git a/lib/cAst.ml b/lib/cAst.ml index 18fa1c9b0d..30b7fca587 100644 --- a/lib/cAst.ml +++ b/lib/cAst.ml @@ -24,3 +24,5 @@ let map_from_loc f l = let with_val f n = f n.v let with_loc_val f n = f ?loc:n.loc n.v + +let eq f x y = f x.v y.v diff --git a/lib/cAst.mli b/lib/cAst.mli index 2e07d1cd78..025bdf25ab 100644 --- a/lib/cAst.mli +++ b/lib/cAst.mli @@ -22,3 +22,5 @@ val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> 'b t val with_val : ('a -> 'b) -> 'a t -> 'b val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b + +val eq : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool diff --git a/lib/cErrors.ml b/lib/cErrors.ml index cb64e36755..760c07783b 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -37,7 +37,7 @@ let user_err ?loc ?info ?hdr strm = let info = Option.cata (Loc.add_loc info) info loc in Exninfo.iraise (UserError (hdr, strm), info) -exception Timeout +exception Timeout = Control.Timeout (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always @@ -135,7 +135,7 @@ let _ = register_handler begin function | UserError(s, pps) -> Some (where s ++ pps) | _ -> None -end + end (** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled @@ -145,7 +145,7 @@ end let noncritical = function | Sys.Break | Out_of_memory | Stack_overflow | Assert_failure _ | Match_failure _ | Anomaly _ - | Timeout -> false + | Control.Timeout -> false | Invalid_argument "equal: functional value" -> false | _ -> true [@@@ocaml.warning "+52"] diff --git a/lib/control.ml b/lib/control.ml index 95ea3935a7..7da95ff3dd 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -16,6 +16,8 @@ let steps = ref 0 let enable_thread_delay = ref false +exception Timeout + let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end; if !enable_thread_delay then begin @@ -27,8 +29,8 @@ let check_for_interrupt () = end (** This function does not work on windows, sigh... *) -let unix_timeout n f x e = - let timeout_handler _ = raise e in +let unix_timeout n f x = + let timeout_handler _ = raise Timeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in let _ = Unix.alarm n in let restore_timeout () = @@ -38,13 +40,13 @@ let unix_timeout n f x e = try let res = f x in restore_timeout (); - res - with e -> - let e = Exninfo.capture e in + Some res + with Timeout -> restore_timeout (); - Exninfo.iraise e + None + -let windows_timeout n f x e = +let windows_timeout n f x = let killed = ref false in let exited = ref false in let thread init = @@ -70,18 +72,18 @@ let windows_timeout n f x e = exited := true; raise Sys.Break end in - res + Some res with | Sys.Break -> (* Just in case, it could be a regular Ctrl+C *) if not !exited then begin killed := true; raise Sys.Break end - else raise e + else None | e -> let e = Exninfo.capture e in let () = killed := true in Exninfo.iraise e -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } @@ -90,7 +92,7 @@ let timeout_fun = match Sys.os_type with let timeout_fun_ref = ref timeout_fun let set_timeout f = timeout_fun_ref := f -let timeout n f e = !timeout_fun_ref.timeout n f e +let timeout n f = !timeout_fun_ref.timeout n f let protect_sigalrm f x = let timed_out = ref false in diff --git a/lib/control.mli b/lib/control.mli index 25135934bc..9465d8f0d5 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -10,6 +10,9 @@ (** Global control of Coq. *) +(** Used to convert signals to exceptions *) +exception Timeout + (** Will periodically call [Thread.delay] if set to true *) val enable_thread_delay : bool ref @@ -21,13 +24,13 @@ val check_for_interrupt : unit -> unit (** Use this function as a potential yield function. If {!interrupt} has been set, il will raise [Sys.Break]. *) -val timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b -(** [timeout n f x e] tries to compute [f x], and if it fails to do so - before [n] seconds, it raises [e] instead. *) +val timeout : int -> ('a -> 'b) -> 'a -> 'b option +(** [timeout n f x] tries to compute [Some (f x)], and if it fails to do so + before [n] seconds, returns [None] instead. *) (** Set a particular timeout function; warning, this is an internal API and it is scheduled to go away. *) -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } val set_timeout : timeout -> unit (** [protect_sigalrm f x] computes [f x], but if SIGALRM is received during that diff --git a/lib/envars.ml b/lib/envars.ml index 585d5185b4..1702b5d7a2 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -12,7 +12,37 @@ open Util (** {1 Helper functions} *) -let getenv_else s dft = try Sys.getenv s with Not_found -> dft () +let parse_env_line l = + try Scanf.sscanf l "%[^=]=%S" (fun name value -> Some(name,value)) + with _ -> None + +let with_ic file f = + let ic = open_in file in + try + let rc = f ic in + close_in ic; + rc + with e -> close_in ic; raise e + +let getenv_from_file name = + let base = Filename.dirname Sys.executable_name in + try + with_ic (base ^ "/coq_environment.txt") (fun ic -> + let rec find () = + let l = input_line ic in + match parse_env_line l with + | Some(n,v) when n = name -> v + | _ -> find () + in + find ()) + with + | Sys_error s -> raise Not_found + | End_of_file -> raise Not_found + +let system_getenv name = + try Sys.getenv name with Not_found -> getenv_from_file name + +let getenv_else s dft = try system_getenv s with Not_found -> dft () let safe_getenv warning n = getenv_else n (fun () -> @@ -145,7 +175,7 @@ let coqpath = (** {2 Caml paths} *) -let ocamlfind () = Coq_config.ocamlfind +let ocamlfind () = getenv_else "OCAMLFIND" (fun () -> Coq_config.ocamlfind) (** {1 XDG utilities} *) diff --git a/library/global.ml b/library/global.ml index 5c847fda96..71cadb3600 100644 --- a/library/global.ml +++ b/library/global.ml @@ -105,9 +105,9 @@ let is_cumulative_sprop () = (typing_flags()).Declarations.cumulative_sprop let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants cd = globalize (Safe_typing.export_private_constants cd) -let add_constant id d = globalize (Safe_typing.add_constant (i2l id) d) +let add_constant ?typing_flags id d = globalize (Safe_typing.add_constant ?typing_flags (i2l id) d) let add_private_constant id d = globalize (Safe_typing.add_private_constant (i2l id) d) -let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) +let add_mind ?typing_flags id mie = globalize (Safe_typing.add_mind ?typing_flags (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) diff --git a/library/global.mli b/library/global.mli index 5faf0e8bbd..c9b9d7f536 100644 --- a/library/global.mli +++ b/library/global.mli @@ -52,10 +52,12 @@ val export_private_constants : Safe_typing.exported_private_constant list val add_constant : + ?typing_flags:Declarations.typing_flags -> Id.t -> Safe_typing.global_declaration -> Constant.t val add_private_constant : Id.t -> Safe_typing.side_effect_declaration -> Constant.t * Safe_typing.private_constants val add_mind : + ?typing_flags:Declarations.typing_flags -> Id.t -> Entries.mutual_inductive_entry -> MutInd.t (** Extra universe constraints *) diff --git a/library/libnames.ml b/library/libnames.ml index 88b2e41855..ba1ef1e2f9 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -145,6 +145,8 @@ let qualid_of_dirpath ?loc dir = let (l,a) = split_dirpath dir in make_qualid ?loc l a +let qualid_of_lident lid = qualid_of_ident ?loc:lid.CAst.loc lid.CAst.v + let qualid_is_ident qid = DirPath.is_empty qid.CAst.v.dirpath diff --git a/library/libnames.mli b/library/libnames.mli index a384510879..65aca0c87d 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -77,6 +77,7 @@ val qualid_of_string : ?loc:Loc.t -> string -> qualid val qualid_of_path : ?loc:Loc.t -> full_path -> qualid val qualid_of_dirpath : ?loc:Loc.t -> DirPath.t -> qualid val qualid_of_ident : ?loc:Loc.t -> Id.t -> qualid +val qualid_of_lident : lident -> qualid val qualid_is_ident : qualid -> bool val qualid_path : qualid -> DirPath.t diff --git a/library/nametab.ml b/library/nametab.ml index a51c281f2b..e94b696b60 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -98,6 +98,7 @@ module type NAMETREE = sig val find : user_name -> t -> elt val exists : user_name -> t -> bool val user_name : qualid -> t -> user_name + val shortest_qualid_gen : ?loc:Loc.t -> (Id.t -> bool) -> user_name -> t -> qualid val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list @@ -252,9 +253,9 @@ let exists uname tab = with Not_found -> false -let shortest_qualid ?loc ctx uname tab = +let shortest_qualid_gen ?loc hidden uname tab = let id,dir = U.repr uname in - let hidden = Id.Set.mem id ctx in + let hidden = hidden id in let rec find_uname pos dir tree = let is_empty = match pos with [] -> true | _ -> false in match tree.path with @@ -269,6 +270,9 @@ let shortest_qualid ?loc ctx uname tab = let found_dir = find_uname [] dir ptab in make_qualid ?loc (DirPath.make found_dir) id +let shortest_qualid ?loc ctx uname tab = + shortest_qualid_gen ?loc (fun id -> Id.Set.mem id ctx) uname tab + let push_node node l = match node with | Absolute (_,o) | Relative (_,o) when not (List.mem_f E.equal o l) -> o::l @@ -562,9 +566,9 @@ let shortest_qualid_of_modtype ?loc kn = let sp = MPmap.find kn !the_modtyperevtab in MPTab.shortest_qualid ?loc Id.Set.empty sp !the_modtypetab -let shortest_qualid_of_universe ?loc kn = +let shortest_qualid_of_universe ?loc ctx kn = let sp = UnivIdMap.find kn !the_univrevtab in - UnivTab.shortest_qualid ?loc Id.Set.empty sp !the_univtab + UnivTab.shortest_qualid_gen ?loc (fun id -> Id.Map.mem id ctx) sp !the_univtab let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) diff --git a/library/nametab.mli b/library/nametab.mli index 8a8b59733c..33aebca0b9 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -206,7 +206,9 @@ val shortest_qualid_of_global : ?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid val shortest_qualid_of_syndef : ?loc:Loc.t -> Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_module : ?loc:Loc.t -> ModPath.t -> qualid -val shortest_qualid_of_universe : ?loc:Loc.t -> Univ.Level.UGlobal.t -> qualid + +(** In general we have a [UnivNames.universe_binders] around rather than a [Id.Set.t] *) +val shortest_qualid_of_universe : ?loc:Loc.t -> 'u Id.Map.t -> Univ.Level.UGlobal.t -> qualid (** {5 Generic name handling} *) @@ -236,6 +238,7 @@ module type NAMETREE = sig val find : user_name -> t -> elt val exists : user_name -> t -> bool val user_name : qualid -> t -> user_name + val shortest_qualid_gen : ?loc:Loc.t -> (Id.t -> bool) -> user_name -> t -> qualid val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list val match_prefixes : qualid -> t -> elt list diff --git a/parsing/extend.ml b/parsing/extend.ml index 94c3768116..7d2ed9aed0 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -32,6 +32,7 @@ let production_level_eq lev1 lev2 = type 'a constr_entry_key_gen = | ETIdent + | ETName of bool (* Temporary: true = user told "name", false = user wrote "ident" *) | ETGlobal | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) @@ -55,6 +56,7 @@ type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm type constr_prod_entry_key = + | ETProdIdent (* Parsed as an ident *) | ETProdName (* Parsed as a name (ident or _) *) | ETProdReference (* Parsed as a global reference *) | ETProdBigint (* Parsed as an (unbounded) integer *) diff --git a/parsing/extend.mli b/parsing/extend.mli index b698415fd6..3cea45c3f5 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -27,6 +27,7 @@ val production_level_eq : production_level -> production_level -> bool type 'a constr_entry_key_gen = | ETIdent + | ETName of bool (* Temporary: true = user told "name", false = user wrote "ident" *) | ETGlobal | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) @@ -50,6 +51,7 @@ type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm type constr_prod_entry_key = + | ETProdIdent (* Parsed as an ident *) | ETProdName (* Parsed as a name (ident or _) *) | ETProdReference (* Parsed as a global reference *) | ETProdBigint (* Parsed as an (unbounded) integer *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 68530178f8..efe4bfd7f6 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -106,9 +106,9 @@ GRAMMAR EXTEND Gram [ [ c = lconstr -> { c } ] ] ; sort: - [ [ "Set" -> { UNamed [GSet,0] } - | "Prop" -> { UNamed [GProp,0] } - | "SProp" -> { UNamed [GSProp,0] } + [ [ "Set" -> { UNamed [CSet,0] } + | "Prop" -> { UNamed [CProp,0] } + | "SProp" -> { UNamed [CSProp,0] } | "Type" -> { UAnonymous {rigid=true} } | "Type"; "@{"; "_"; "}" -> { UAnonymous {rigid=false} } | "Type"; "@{"; u = universe; "}" -> { UNamed u } ] ] @@ -124,9 +124,9 @@ GRAMMAR EXTEND Gram | -> { 0 } ] ] ; universe_name: - [ [ id = global -> { GType id } - | "Set" -> { GSet } - | "Prop" -> { GProp } ] ] + [ [ id = global -> { CType id } + | "Set" -> { CSet } + | "Prop" -> { CProp } ] ] ; universe_expr: [ [ id = universe_name; n = universe_increment -> { (id,n) } ] ] @@ -282,12 +282,12 @@ GRAMMAR EXTEND Gram | -> { None } ] ] ; universe_level: - [ [ "Set" -> { UNamed GSet } + [ [ "Set" -> { UNamed CSet } (* no parsing SProp as a level *) - | "Prop" -> { UNamed GProp } + | "Prop" -> { UNamed CProp } | "Type" -> { UAnonymous {rigid=true} } | "_" -> { UAnonymous {rigid=false} } - | id = global -> { UNamed (GType id) } ] ] + | id = global -> { UNamed (CType id) } ] ] ; fix_decls: [ [ dcl = fix_decl -> { let (id,_,_,_,_) = dcl.CAst.v in (id,[dcl.CAst.v]) } diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d49a49d242..cc9e1bb31d 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -179,6 +179,7 @@ let make_rule r = [None, None, r] (** An entry that checks we reached the end of the input. *) +(* used by the Tactician plugin *) let eoi_entry en = let e = Entry.make ((Entry.name en) ^ "_eoi") in let symbs = Rule.next (Rule.next Rule.stop (Symbol.nterm en)) (Symbol.token Tok.PEOI) in @@ -187,14 +188,6 @@ let eoi_entry en = safe_extend e ext; e -let map_entry f en = - let e = Entry.make ((Entry.name en) ^ "_map") in - let symbs = Rule.next Rule.stop (Symbol.nterm en) in - let act = fun x loc -> f x in - let ext = { pos = None; data = make_rule [Production.make symbs act] } in - safe_extend e ext; - e - (* Parse a string, does NOT check if the entire string was read (use eoi_entry) *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d0ae594db1..06d05a4797 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -121,7 +121,6 @@ end val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t -val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t type gram_universe [@@deprecated "Deprecated in 8.13"] [@@@ocaml.warning "-3"] @@ -190,9 +189,9 @@ module Constr : [@@deprecated "Deprecated in 8.13; use 'term' instead"] val ident : Id.t Entry.t val global : qualid Entry.t - val universe_name : Glob_term.glob_sort_name Entry.t - val universe_level : Glob_term.glob_level Entry.t - val sort : Glob_term.glob_sort Entry.t + val universe_name : sort_name_expr Entry.t + val universe_level : univ_level_expr Entry.t + val sort : sort_expr Entry.t val sort_family : Sorts.family Entry.t val pattern : cases_pattern_expr Entry.t val constr_pattern : constr_expr Entry.t diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index c485c38009..499c9684b2 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -429,55 +429,55 @@ let cc_tactic depth additionnal_terms = match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); - match reason with - Discrimination (i,ipac,j,jpac) -> - let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in - let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac cstr p - | Incomplete -> - let open Glob_term in - let env = Proofview.Goal.env gl in - let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in - let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in - let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) - in - let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." - ++ fnl () ++ - str " Try " ++ - hov 8 - begin - str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") - pr_missing terms_to_complete ++ str ")\"," - end ++ - str " replacing metavariables by arbitrary terms.") in - Tacticals.New.tclFAIL 0 msg - | Contradiction dis -> - let env = Proofview.Goal.env gl in - let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in - let ta=term uf dis.lhs and tb=term uf dis.rhs in - match dis.rule with - Goal -> proof_tac p - | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p - | HeqG id -> - let id = EConstr.of_constr id in - convert_to_goal_tac id ta tb p - | HeqnH (ida,idb) -> - let ida = EConstr.of_constr ida in - let idb = EConstr.of_constr idb in - convert_to_hyp_tac ida ta idb tb p + debug (fun () -> Pp.str "Goal solved, generating proof ..."); + match reason with + Discrimination (i,ipac,j,jpac) -> + let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in + let cstr=(get_constructor_info uf ipac.cnode).ci_constr in + discriminate_tac cstr p + | Incomplete -> + let open Glob_term in + let env = Proofview.Goal.env gl in + let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in + let pr_missing (c, missing) = + let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in + let holes = List.init missing (fun _ -> hole) in + Printer.pr_glob_constr_env env sigma (DAst.make @@ GApp (c, holes)) + in + let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." + ++ fnl () ++ + str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ + prlist_with_sep + (fun () -> str ")" ++ spc () ++ str "(") + pr_missing terms_to_complete ++ + str ")\"," + end ++ + fnl() ++ str " replacing metavariables by arbitrary terms") + in + Tacticals.New.tclFAIL 0 msg + | Contradiction dis -> + let env = Proofview.Goal.env gl in + let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in + let ta=term uf dis.lhs and tb=term uf dis.rhs in + match dis.rule with + Goal -> proof_tac p + | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p + | HeqG id -> + let id = EConstr.of_constr id in + convert_to_goal_tac id ta tb p + | HeqnH (ida,idb) -> + let ida = EConstr.of_constr ida in + let idb = EConstr.of_constr idb in + convert_to_hyp_tac ida ta idb tb p end -let cc_fail = - Tacticals.New.tclZEROMSG (Pp.str "congruence failed.") let congruence_tac depth l = - Tacticals.New.tclORELSE - (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l)) - cc_fail + Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l) (* Beware: reflexivity = constructor 1 = apply refl_equal might be slow now, let's rather do something equivalent diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 52fc3acb6f..79c7d2c676 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -14,8 +14,6 @@ val proof_tac: Ccproof.proof -> unit Proofview.tactic val cc_tactic : int -> constr list -> unit Proofview.tactic -val cc_fail : unit Proofview.tactic - val congruence_tac : int -> constr list -> unit Proofview.tactic val f_equal : unit Proofview.tactic diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 21ec80abbc..da4a50b674 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -399,7 +399,11 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | MLuint i1, MLuint i2 -> Uint63.equal i1 i2 | MLfloat f1, MLfloat f2 -> Float64.equal f1 f2 -| _, _ -> false +| MLparray (t1,def1), MLparray (t2, def2) -> Array.equal eq_ml_ast t1 t2 && eq_ml_ast def1 def2 +| (MLrel _|MLapp _|MLlam _|MLletin _|MLglob _|MLcons _ + |MLtuple _|MLcase _|MLfix _|MLexn _|MLdummy _|MLaxiom + | MLmagic _| MLuint _| MLfloat _|MLparray _), _ + -> false and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 767a9ec39b..5bfb37f4cb 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -458,9 +458,11 @@ let rec pattern_to_term_and_type env typ = but only the value of the function *) +let pr_glob_constr_env env x = pr_glob_constr_env env (Evd.from_env env) x + let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = - observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); + observe (str " Entering : " ++ pr_glob_constr_env env rt); let open CAst in match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ @@ -638,9 +640,7 @@ let rec build_entry_lc env sigma funnames avoid rt : with Not_found -> user_err ( str "Cannot find the inductive associated to " - ++ Printer.pr_glob_constr_env env b - ++ str " in " - ++ Printer.pr_glob_constr_env env rt + ++ pr_glob_constr_env env b ++ str " in " ++ pr_glob_constr_env env rt ++ str ". try again with a cast" ) in let case_pats = build_constructors_of_type (fst ind) [] in @@ -662,9 +662,7 @@ let rec build_entry_lc env sigma funnames avoid rt : with Not_found -> user_err ( str "Cannot find the inductive associated to " - ++ Printer.pr_glob_constr_env env b - ++ str " in " - ++ Printer.pr_glob_constr_env env rt + ++ pr_glob_constr_env env b ++ str " in " ++ pr_glob_constr_env env rt ++ str ". try again with a cast" ) in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in @@ -1321,11 +1319,11 @@ let do_build_inductive evd (funconstants : pconstant list) @@ Constrexpr.CLetIn ( CAst.make n , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) , acc ) | None -> @@ -1335,7 +1333,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( [CAst.make n] , Constrexpr_ops.default_binder_kind , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t ) ] , acc )) rel_first_args @@ -1410,11 +1408,11 @@ let do_build_inductive evd (funconstants : pconstant list) @@ Constrexpr.CLetIn ( CAst.make n , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) , acc ) | None -> @@ -1424,7 +1422,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( [CAst.make n] , Constrexpr_ops.default_binder_kind , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t ) ] , acc )) rel_first_args @@ -1448,16 +1446,16 @@ let do_build_inductive evd (funconstants : pconstant list) | Some typ -> Constrexpr.CLocalDef ( CAst.make n - , Constrextern.extern_glob_constr Id.Set.empty t + , Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) ) | None -> Constrexpr.CLocalAssum ( [CAst.make n] , Constrexpr_ops.default_binder_kind - , Constrextern.extern_glob_constr Id.Set.empty t )) + , Constrextern.(extern_glob_constr empty_extern_env) t )) rels_params in let ext_rels_constructors = @@ -1466,7 +1464,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( false , ( CAst.make id , with_full_print - (Constrextern.extern_glob_type Id.Set.empty) + Constrextern.(extern_glob_type empty_extern_env) ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) rel_constructors in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 33076a876b..9d896e9182 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -776,7 +776,7 @@ let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos let a' = infos.info in let new_info = { infos with - info = mkCase (ci, t, iv, a', l) + info = mkCase (ci, a, iv, a', l) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index b7ac71181a..e39c066c95 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -122,10 +122,10 @@ END TACTIC EXTEND constructor | [ "constructor" ] -> { Tactics.any_constructor false None } -| [ "constructor" int_or_var(i) ] -> { +| [ "constructor" nat_or_var(i) ] -> { Tactics.constructor_tac false None i NoBindings } -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "constructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac false None i bl in Tacticals.New.tclDELAYEDWITHHOLES false bl tac } @@ -133,10 +133,10 @@ END TACTIC EXTEND econstructor | [ "econstructor" ] -> { Tactics.any_constructor true None } -| [ "econstructor" int_or_var(i) ] -> { +| [ "econstructor" nat_or_var(i) ] -> { Tactics.constructor_tac true None i NoBindings } -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "econstructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac true None i bl in Tacticals.New.tclDELAYEDWITHHOLES true bl tac } diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index ff4a82f864..daed855600 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -150,7 +150,7 @@ let pr_occurrences = pr_occurrences () () () let pr_gen env sigma prc _prlc _prtac x = prc env sigma x let pr_globc env sigma _prc _prlc _prtac (_,glob) = - Printer.pr_glob_constr_env env glob + Printer.pr_glob_constr_env env sigma glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index a2a47c0bf4..4a2c298caa 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -41,7 +41,7 @@ DECLARE PLUGIN "ltac_plugin" (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) -(* dependent rewrite *) +(* cutrewrite, dependent rewrite *) let with_delayed_uconstr ist c tac = let flags = { @@ -201,6 +201,12 @@ TACTIC EXTEND dependent_rewrite -> { rewriteInHyp b c id } END +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> { cutRewriteInHyp b eqn id } +END + (**********************************************************************) (* Decompose *) @@ -602,7 +608,7 @@ END { let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in + let occref = if occ > 0 then ref occ else Locusops.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec x = match DAst.get x with | GVar id -> @@ -622,7 +628,7 @@ let subst_var_with_hole occ tid t = | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t in - if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' + if !occref > 0 then Locusops.error_invalid_occurrence [occ] else t' let subst_hole_with_term occ tc t = let locref = ref 0 in @@ -686,7 +692,7 @@ let hResolve_auto id c t = } TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" nat_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> { hResolve_auto id c t } END @@ -695,7 +701,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } +| [ "hget_evar" nat_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 7e8400910c..069a342b2a 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -63,7 +63,7 @@ let eval_uconstrs ist cs = let pr_auto_using_raw env sigma _ _ _ = Pptactic.pr_auto_using @@ Ppconstr.pr_constr_expr env sigma let pr_auto_using_glob env sigma _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> - Printer.pr_glob_constr_env env c) + Printer.pr_glob_constr_env env sigma c) let pr_auto_using env sigma _ _ _ = Pptactic.pr_auto_using @@ Printer.pr_closed_glob_env env sigma @@ -96,17 +96,17 @@ TACTIC EXTEND debug_trivial END TACTIC EXTEND auto -| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto n (eval_uconstrs ist lems) db } END TACTIC EXTEND info_auto -| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "info_auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_auto -| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "debug" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END @@ -130,15 +130,15 @@ let deprecated_bfs tacname = } TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> deprecated_eauto_bfs () | _ -> () ); Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) +TACTIC EXTEND new_eauto (* todo: name doesn't match syntax *) +| [ "new" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) @@ -146,7 +146,7 @@ TACTIC EXTEND new_eauto END TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "debug" "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> (deprecated_bfs "debug eauto") () | _ -> () ); @@ -154,7 +154,7 @@ TACTIC EXTEND debug_eauto END TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "info_eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { ( match n,p with Some _, Some _ -> (deprecated_bfs "info_eauto") () | _ -> () ); @@ -162,13 +162,13 @@ TACTIC EXTEND info_eauto END TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "dfs" "eauto" nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END TACTIC EXTEND bfs_eauto -| [ "bfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "bfs" "eauto" nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { Eauto.gen_eauto (true, Eauto.make_depth p) (eval_uconstrs ist lems) db } END diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 8c2e633be5..0f59ac07b4 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -86,13 +86,13 @@ END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + | [ "typeclasses" "eauto" "bfs" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs l } - | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + | [ "typeclasses" "eauto" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d l } - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" "bfs" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs ~only_classes:true [Class_tactics.typeclasses_db] } - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~only_classes:true [Class_tactics.typeclasses_db] } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index c2e95c45f9..b1b96ea9a7 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -112,8 +112,8 @@ GRAMMAR EXTEND Gram | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA [ IDENT "try"; ta = ltac_expr -> { TacTry ta } - | IDENT "do"; n = int_or_var; ta = ltac_expr -> { TacDo (n,ta) } - | IDENT "timeout"; n = int_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } + | IDENT "do"; n = nat_or_var; ta = ltac_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = nat_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) } | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta } | IDENT "progress"; ta = ltac_expr -> { TacProgress ta } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index a3f03b5bb5..f12ca0685e 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -40,9 +40,9 @@ type glob_constr_with_bindings = glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings let pr_glob_constr_with_bindings_sign env sigma _ _ _ (ge : glob_constr_with_bindings_sign) = - Printer.pr_glob_constr_env env (fst (fst (snd ge))) + Printer.pr_glob_constr_env env sigma (fst (fst (snd ge))) let pr_glob_constr_with_bindings env sigma _ _ _ (ge : glob_constr_with_bindings) = - Printer.pr_glob_constr_env env (fst (fst ge)) + Printer.pr_glob_constr_env env sigma (fst (fst ge)) let pr_constr_expr_with_bindings env sigma prc _ _ (ge : constr_expr_with_bindings) = prc env sigma (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 072206c39c..43957bbde5 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -190,7 +190,7 @@ open Pvernac.Vernac_ GRAMMAR EXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr uconstr + bindings red_expr int_or_var nat_or_var open_constr uconstr simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: @@ -407,8 +407,8 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> { Some (id,ipat) } - | -> { None } ] ] + [ [ "in"; l = LIST1 [id = id_or_meta; ipat = as_ipat -> { (id,ipat) } ] SEP "," -> { l } + | -> { [] } ] ] ; orient_rw: [ [ "->" -> { true } diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 94e398fe5d..196a68e67c 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -29,6 +29,7 @@ let quantified_hypothesis = Entry.create "quantified_hypothesis" let destruction_arg = Entry.create "destruction_arg" let int_or_var = Entry.create "int_or_var" +let nat_or_var = Entry.create "nat_or_var" let simple_intropattern = Entry.create "simple_intropattern" let in_clause = Entry.create "in_clause" @@ -52,6 +53,7 @@ let () = let open Stdarg in let open Tacarg in register_grammar wit_int_or_var (int_or_var); + register_grammar wit_nat_or_var (nat_or_var); register_grammar wit_intro_pattern (simple_intropattern); (* To remove at end of deprecation phase *) (* register_grammar wit_intropattern (intropattern); *) (* To be added at end of deprecation phase *) register_grammar wit_simple_intropattern (simple_intropattern); diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 3a4a081c93..c0bf6b9f76 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -27,6 +27,7 @@ val uconstr : constr_expr Entry.t val quantified_hypothesis : quantified_hypothesis Entry.t val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Entry.t val int_or_var : int Locus.or_var Entry.t +val nat_or_var : int Locus.or_var Entry.t val simple_tactic : raw_tactic_expr Entry.t val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t val in_clause : Names.lident Locus.clause_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index edd56ee0f7..faad792ea9 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -458,8 +458,8 @@ let string_of_genarg_arg (ArgumentType arg) = | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) let pr_in_hyp_as prc pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep pr_comma (fun (id,ipat) -> pr_id id ++ pr_as_ipat prc ipat) l) let pr_in_clause pr_id = function | { onhyps=None; concl_occs=NoOccurrences } -> @@ -1131,12 +1131,12 @@ let pr_goal_selector ~toplevel s = let rec prtac n (t:glob_tactic_expr) = let pr = { pr_tactic = prtac; - pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); - pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); - pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); - pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); + pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)); + pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env sigma)); pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); - pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env sigma)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = Pputils.pr_glb_generic; @@ -1167,7 +1167,7 @@ let pr_goal_selector ~toplevel s = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); pr_constr = pr_econstr_env; - pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); pr_lconstr = pr_leconstr_env; pr_pattern = pr_constr_pattern_env; pr_lpattern = pr_lconstr_pattern_env; @@ -1190,7 +1190,7 @@ let pr_goal_selector ~toplevel s = let pr_raw_extend env sigma = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma - let pr_glob_extend env sigma = pr_glob_extend_rec (pr_glob_tactic_level env) + let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1213,8 +1213,8 @@ let declare_extra_genarg_pprule wit f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = Genprint.PrinterBasic (fun env sigma -> - g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) - (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)) (fun env sigma -> pr_glob_tactic_level env) x) in let h x = @@ -1243,8 +1243,8 @@ let declare_extra_genarg_pprule_with_level wit default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; printer = (fun env sigma n -> - g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) - (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)) (fun env sigma -> pr_glob_tactic_level env) n x) } in let h x = @@ -1302,10 +1302,10 @@ let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) let pr_glob_constr_pptac env sigma c = - pr_glob_constr_env env c + pr_glob_constr_env env sigma c let pr_lglob_constr_pptac env sigma c = - pr_lglob_constr_env env c + pr_lglob_constr_env env sigma c let pr_raw_intro_pattern = lift_env (fun env sigma -> Miscprint.pr_intro_pattern @@ pr_constr_expr env sigma) @@ -1318,6 +1318,7 @@ let () = let pr_unit _ = str "()" in let open Genprint in register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; + register_basic_print0 wit_nat_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref pr_qualid (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_smart_global diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 5e199dad62..79e0adf9f7 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -124,7 +124,7 @@ val pr_glb_generic : env -> Evd.evar_map -> glevel generic_argument -> Pp.t val pr_raw_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> raw_tactic_arg list -> Pp.t -val pr_glob_extend: env -> Evd.evar_map -> int -> +val pr_glob_extend: env -> int -> ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 9c15d24dd3..aa2449d962 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -244,7 +244,8 @@ let string_of_call ck = (Pptactic.pr_glob_tactic (Global.env ()) (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> - pr_glob_constr_env (Global.env ()) c + let env = Global.env () in + pr_glob_constr_env env (Evd.from_env env) c | Tacexpr.LtacMLCall te -> (Pptactic.pr_glob_tactic (Global.env ()) te) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 77162ce89a..59533eb3e3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -855,26 +855,20 @@ let coerce env cstr res = let res = { res with rew_evars = evars } in apply_constraint env res.rew_car rel prf cstr res -let apply_rule unify loccs : int pure_strategy = - let (nowhere_except_in,occs) = convert_occs loccs in - let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) - in - { strategy = fun { state = occ ; env ; +let apply_rule unify : occurrences_count pure_strategy = + { strategy = fun { state = occs ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar (goalevars evars) t then None else unify env evars t in match unif with - | None -> (occ, Fail) + | None -> (occs, Fail) | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) + let b, occs = update_occurrence_counter occs in + if not b then (occs, Fail) + else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occs, Identity) else let res = { rew with rew_car = ty } in let res = Success (coerce env cstr res) in - (occ, res) + (occs, res) } let apply_lemma l2r flags oc by loccs : strategy = { strategy = @@ -890,9 +884,10 @@ let apply_lemma l2r flags oc by loccs : strategy = { strategy = | None -> None | Some rew -> Some rew in - let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; + let loccs, res = (apply_rule unify).strategy { input with + state = initialize_occurrence_counter loccs ; evars } in + check_used_occurrences loccs; (), res } @@ -1423,12 +1418,13 @@ let rewrite_with l2r flags c occs : strategy = { strategy = let (sigma, rew) = refresh_hypinfo env sigma c in unify_eqn rew l2r flags env (sigma, cstrs) None t in - let app = apply_rule unify occs in + let app = apply_rule unify in let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat.strategy { input with state = 0 } in + let occs, res = strat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; ((), res) } @@ -2076,11 +2072,12 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.enter begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in - let app = apply_rule unify occs in + let app = apply_rule unify in let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in let substrat = Strategies.fix recstrat in let strat = { strategy = fun ({ state = () } as input) -> - let _, res = substrat.strategy { input with state = 0 } in + let occs, res = substrat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; (), res } in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 4c1fe6417e..9abdc2ddbe 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -429,7 +429,15 @@ let pr_value env v = | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) -let error_ltac_variable ?loc id env v s = - CErrors.user_err ?loc (str "Ltac variable " ++ Id.print id ++ +exception CoercionError of Id.t * (Environ.env * Evd.evar_map) option * Val.t * string + +let () = CErrors.register_handler begin function +| CoercionError (id, env, v, s) -> + Some (str "Ltac variable " ++ Id.print id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") +| _ -> None +end + +let error_ltac_variable ?loc id env v s = + Loc.raise ?loc (CoercionError (id, env, v, s)) diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index eaedf8d9c1..7b2c8e1d04 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -108,7 +108,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 50767821e4..2382dcfbb9 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -107,7 +107,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 47f1d3bf66..8bee7afa2c 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -444,11 +444,11 @@ let intern_red_expr ist = function | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (id,ipat) = - (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) - let intern_hyp_list ist = List.map (intern_hyp ist) +let intern_in_hyp_as ist lf (idl,ipat) = + (intern_hyp ist idl, Option.map (intern_intro_pattern lf ist) ipat) + let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,intern_hyp_list ist idl, @@ -527,7 +527,7 @@ let rec intern_atomic lf ist x = TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) | TacApply (a,ev,cb,inhyp) -> TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, - Option.map (intern_in_hyp_as ist lf) inhyp) + List.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -799,6 +799,7 @@ let intern_ltac ist tac = let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_nat_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_smart_global (lift intern_smart_global); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 3d734d3a66..f2241e78d2 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -773,7 +773,7 @@ let interp_may_eval f ist env sigma = function function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> - str"interpretation of term " ++ pr_glob_constr_env env (fst c))); + str"interpretation of term " ++ pr_glob_constr_env env sigma (fst c))); Exninfo.iraise reraise (* Interprets a constr expression possibly to first evaluate *) @@ -1667,10 +1667,10 @@ and interp_atomic ist tac : unit Proofview.tactic = (k,(make ?loc f))) cb in let sigma,tac = match cl with - | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l - | Some cl -> - let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev id l cl in + | [] -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | cl -> + let sigma,cl = List.fold_left_map (interp_in_hyp_as ist env) sigma cl in + sigma, List.fold_right (fun (id,ipat) -> Tactics.apply_delayed_in a ev id l ipat) cl Tacticals.New.tclIDTAC in Tacticals.New.tclWITHHOLES ev tac sigma end end @@ -2099,6 +2099,7 @@ let interp_pre_ident ist env sigma s = let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_nat_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_smart_global (lift interp_reference); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_pre_ident (lift interp_pre_ident); diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index ec44ae4698..90546ea939 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -128,7 +128,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb, + List.map (on_snd (Option.map (subst_intro_pattern subst))) cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) @@ -278,6 +279,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_nat_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_smart_global subst_global_reference; Genintern.register_subst0 wit_pre_ident (fun _ v -> v); diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 5fbea4eeef..c4c528d373 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -16,11 +16,12 @@ open Tacexpr let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () let prtac x = - Pptactic.pr_glob_tactic (Global.env()) x + let env = Global.env () in + Pptactic.pr_glob_tactic env x let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp let prmatchrl env sigma rl = - Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) + Pptactic.pr_match_rule false prtac (fun (_,p) -> Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. @@ -366,24 +367,22 @@ let explain_ltac_call_trace last trace loc = | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Tacexpr.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) + quote (prtac t) | Tacexpr.LtacVarCall (id,t) -> quote (Id.print id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + prtac t ++ str ")" | Tacexpr.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (CAst.make te))) + quote (prtac (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> - quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (* XXX: This hooks into the CErrors's additional error info API so + it is tricky to provide the right env for now. *) + let env = Global.env() in + let sigma = Evd.from_env env in + quote (Printer.pr_glob_constr_env env sigma c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - (* XXX: This hooks into the CErrors's additional error - info API so it is tricky to provide the right env for - now. *) - let env = Global.env () in - let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9008691bca..74d5374193 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -385,6 +385,16 @@ let subst sys = sys'; sys' +let tr_sys str f sys = + let sys' = f sys in + if debug then ( + Printf.fprintf stdout "[%s\n" str; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "\n => \n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; + Printf.fprintf stdout "]\n" ); + sys' + (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. For integers, the obtained constraints are sound but not complete. @@ -392,11 +402,7 @@ let subst sys = let saturate_by_linear_equalities sys0 = WithProof.saturate_subst false sys0 let saturate_by_linear_equalities sys = - let sys' = saturate_by_linear_equalities sys in - if debug then - Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" - output_sys sys output_sys sys'; - sys' + tr_sys "saturate_by_linear_equalities" saturate_by_linear_equalities sys let bound_monomials (sys : WithProof.t list) = let l = @@ -497,10 +503,10 @@ let nlinear_prover prfdepth sys = let sys = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in let id = List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in - let env = CList.interval 0 id in + let env = List.map (fun i -> ProofFormat.Hyp i) (CList.interval 0 id) in match linear_prover_cstr sys with | None -> Unknown | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) @@ -514,7 +520,7 @@ let linear_prover_with_cert prfdepth sys = | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q - (List.mapi (fun i e -> i) sys) + (List.mapi (fun i e -> ProofFormat.Hyp i) sys) cert) (* The prover is (probably) incomplete -- @@ -885,6 +891,11 @@ let check_sys sys = open ProofFormat +let output_cstr_sys sys = + (pp_list ";" (fun o (c, wp) -> + Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) + sys + let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -922,16 +933,10 @@ let xlia (can_enum : bool) reduction_equations sys = | _ -> Unknown ) and aux_lia (id : int) (sys : prf_sys) = assert (check_sys sys); - if debug then - Printf.printf "xlia: %a \n" - (pp_list ";" (fun o (c, _) -> output_cstr o c)) - sys; + if debug then Printf.printf "xlia: %a \n" output_cstr_sys sys; try let sys = reduction_equations sys in - if debug then - Printf.printf "after reduction: %a \n" - (pp_list ";" (fun o (c, _) -> output_cstr o c)) - sys; + if debug then Printf.printf "after reduction: %a \n" output_cstr_sys sys; match linear_prover_cstr sys with | Some prf -> Prf (Step (id, prf, Done)) | None -> if can_enum then enum_proof id sys else Unknown @@ -943,7 +948,7 @@ let xlia (can_enum : bool) reduction_equations sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let orpf = @@ -973,7 +978,7 @@ let xlia_simplex env red sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let env = CList.interval 0 (id - 1) in @@ -1007,6 +1012,128 @@ let gen_bench (tac, prover) can_enum prfdepth sys = flush o; close_out o ); res +let normalise sys = + List.fold_left + (fun acc s -> + match WithProof.cutting_plane s with + | None -> s :: acc + | Some s' -> s' :: acc) + [] sys + +let normalise = tr_sys "normalise" normalise + +let elim_redundant sys = + let module VectMap = Map.Make (Vect) in + let elim_eq sys = + List.fold_left + (fun acc (((v, o), prf) as wp) -> + match o with + | Gt -> assert false + | Ge -> wp :: acc + | Eq -> wp :: WithProof.neg wp :: acc) + [] sys + in + let of_list l = + List.fold_left + (fun m (((v, o), prf) as wp) -> + let q, v' = Vect.decomp_cst v in + try + let q', wp' = VectMap.find v' m in + match Q.compare q q' with + | 0 -> if o = Eq then VectMap.add v' (q, wp) m else m + | 1 -> m + | _ -> VectMap.add v' (q, wp) m + with Not_found -> VectMap.add v' (q, wp) m) + VectMap.empty l + in + let to_list m = VectMap.fold (fun _ (_, wp) sys -> wp :: sys) m [] in + to_list (of_list (elim_eq sys)) + +let elim_redundant sys = tr_sys "elim_redundant" elim_redundant sys + +(** [fourier_small] performs some variable elimination and keeps the cutting planes. + To decide which elimination to perform, the constraints are sorted according to + 1 - the number of variables + 2 - the value of the smallest coefficient + Given the smallest constraint, we eliminate the variable with the smallest coefficient. + The rational is that a constraint with a single variable provides some bound information. + When there are several variables, we hope to eliminate all the variables. + A necessary condition is to take the variable with the smallest coefficient *) + +let fourier_small (sys : WithProof.t list) = + let gen_pivot acc (q, x) wp l = + List.fold_left + (fun acc (s, wp') -> + match WithProof.simple_pivot (q, x) wp wp' with + | None -> acc + | Some wp2 -> ( + match WithProof.cutting_plane wp2 with + | Some wp2 -> (s, wp2) :: acc + | _ -> acc )) + acc l + in + let rec all_pivots acc l = + match l with + | [] -> acc + | ((_, qx), wp) :: l' -> all_pivots (gen_pivot acc qx wp (acc @ l')) l' + in + List.rev_map snd (all_pivots [] (WithProof.sort sys)) + +let fourier_small = tr_sys "fourier_small" fourier_small + +(** [propagate_bounds sys] generate new constraints by exploiting bounds. + A bound is a constraint of the form c + a.x >= 0 + *) + +(*let propagate_bounds sys = + let bounds, sys' = + List.fold_left + (fun (b, r) (((c, o), prf) as wp) -> + match Vect.Bound.of_vect c with + | None -> (b, wp :: r) + | Some b' -> ((b', wp) :: b, r)) + ([], []) sys + in + let exploit_bound acc (b, wp) = + let cf = b.Vect.Bound.coeff in + let vr = b.Vect.Bound.var in + List.fold_left + (fun acc (((c, o), prf) as wp') -> + let cf' = Vect.get vr c in + if Q.sign (cf */ cf') = -1 then + WithProof.( + let wf2 = + addition + (mult (LinPoly.constant (Q.abs cf')) wp) + (mult (LinPoly.constant (Q.abs cf)) wp') + in + match cutting_plane wf2 with None -> acc | Some cp -> cp :: acc) + else acc) + acc sys' + in + List.fold_left exploit_bound [] bounds + *) + +let rev_concat l = + let rec conc acc l = + match l with [] -> acc | l1 :: lr -> conc (List.rev_append l1 acc) lr + in + conc [] l + +let pre_process sys = + let sys = normalise sys in + let bnd1 = bound_monomials sys in + let sys1 = normalise (subst sys) in + let pbnd1 = fourier_small sys1 in + let sys2 = elim_redundant (List.rev_append pbnd1 sys1) in + let bnd2 = bound_monomials sys2 in + let pbnd2 = [] (*fourier_small sys2*) in + (* Should iterate ? *) + let sys = + rev_concat [pbnd2; bnd1; bnd2; saturate_by_linear_equalities sys2; sys2] + in + sys + let lia (can_enum : bool) (prfdepth : int) sys = let sys = develop_constraints prfdepth z_spec sys in if debug then begin @@ -1020,11 +1147,7 @@ let lia (can_enum : bool) (prfdepth : int) sys = p) sys end; - let bnd1 = bound_monomials sys in - let sys = subst sys in - let bnd2 = bound_monomials sys in - (* To deal with non-linear monomials *) - let sys = bnd1 @ bnd2 @ saturate_by_linear_equalities sys @ sys in + let sys = pre_process sys in let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' @@ -1039,7 +1162,8 @@ let nlia enum prfdepth sys = List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys end; if is_linear then - xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + xlia (List.map fst sys) enum reduction_equations + (make_cstr_system (pre_process sys)) else (* let sys1 = elim_every_substitution sys in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 542b99075d..e119ceb241 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,7 +12,7 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules M, Mc, Env, Cache, CacheZ *) +(* - Modules Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) @@ -197,6 +197,7 @@ let coq_proofTerm = lazy (constr_of_ref "micromega.ZArithProof.type") let coq_doneProof = lazy (constr_of_ref "micromega.ZArithProof.DoneProof") let coq_ratProof = lazy (constr_of_ref "micromega.ZArithProof.RatProof") let coq_cutProof = lazy (constr_of_ref "micromega.ZArithProof.CutProof") +let coq_splitProof = lazy (constr_of_ref "micromega.ZArithProof.SplitProof") let coq_enumProof = lazy (constr_of_ref "micromega.ZArithProof.EnumProof") let coq_ExProof = lazy (constr_of_ref "micromega.ZArithProof.ExProof") let coq_IsProp = lazy (constr_of_ref "micromega.kind.isProp") @@ -1341,6 +1342,12 @@ let rec dump_proof_term = function EConstr.mkApp ( Lazy.force coq_cutProof , [|dump_psatz coq_Z dump_z cone; dump_proof_term prf|] ) + | Micromega.SplitProof (p, prf1, prf2) -> + EConstr.mkApp + ( Lazy.force coq_splitProof + , [| dump_pol (Lazy.force coq_Z) dump_z p + ; dump_proof_term prf1 + ; dump_proof_term prf2 |] ) | Micromega.EnumProof (c1, c2, prfs) -> EConstr.mkApp ( Lazy.force coq_enumProof @@ -1364,6 +1371,7 @@ let rec size_of_pf = function | Micromega.DoneProof -> 1 | Micromega.RatProof (p, a) -> size_of_pf a + size_of_psatz p | Micromega.CutProof (p, a) -> size_of_pf a + size_of_psatz p + | Micromega.SplitProof (_, p1, p2) -> size_of_pf p1 + size_of_pf p2 | Micromega.EnumProof (p1, p2, l) -> size_of_psatz p1 + size_of_psatz p2 + List.fold_left (fun acc p -> size_of_pf p + acc) 0 l @@ -1382,6 +1390,9 @@ let rec pp_proof_term o = function Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof (cone, rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.SplitProof (p, p1, p2) -> + Printf.fprintf o "S[%a,%a,%a]" (pp_pol pp_z) p pp_proof_term p1 + pp_proof_term p2 | Micromega.EnumProof (c1, c2, rst) -> Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) @@ -2064,7 +2075,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) = +end) : +sig + type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list @@ -2196,6 +2211,7 @@ let hyps_of_pt pt = | Mc.DoneProof -> acc | Mc.RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) | Mc.CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | Mc.SplitProof (p, p1, p2) -> xhyps (base + 1) p1 (xhyps (base + 1) p2 acc) | Mc.EnumProof (c1, c2, l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l @@ -2212,6 +2228,8 @@ let compact_pt pt f = Mc.RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) | Mc.CutProof (c, pt) -> Mc.CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | Mc.SplitProof (p, p1, p2) -> + Mc.SplitProof (p, compact_pt (ofset + 1) p1, compact_pt (ofset + 1) p2) | Mc.EnumProof (c1, c2, l) -> Mc.EnumProof ( compact_cone c1 (translate ofset) diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 40eea91b31..852a485329 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -29,7 +29,7 @@ open Tacarg DECLARE PLUGIN "micromega_plugin" TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i +| [ "psatz_Z" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Z" tactic(t)] -> { (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) } @@ -74,12 +74,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_R" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_R" tactic(t) ] -> { (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_Q" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } END diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index b231779c7b..57de80bd24 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1384,11 +1384,13 @@ let rxcnf_or unsat deduce rXCNF polarity k e1 e2 = let rxcnf_impl unsat deduce rXCNF polarity k e1 e2 = let e3,t1 = rXCNF (negb polarity) k e1 in if polarity - then if is_cnf_ff e3 - then rXCNF polarity k e2 - else let e4,t2 = rXCNF polarity k e2 in - let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(rev_append t1 (rev_append t2 t')) + then if is_cnf_tt e3 + then e3,t1 + else if is_cnf_ff e3 + then rXCNF polarity k e2 + else let e4,t2 = rXCNF polarity k e2 in + let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) else let e4,t2 = rXCNF polarity k e2 in (and_cnf_opt e3 e4),(rev_append t1 t2) @@ -2140,6 +2142,11 @@ let zWeakChecker = let psub1 = psub0 Z0 Z.add Z.sub Z.opp zeq_bool +(** val popp1 : z pol -> z pol **) + +let popp1 = + popp0 Z.opp + (** val padd1 : z pol -> z pol -> z pol **) let padd1 = @@ -2233,6 +2240,7 @@ type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof | EnumProof of zWitness * zWitness * zArithProof list | ExProof of positive * zArithProof @@ -2344,6 +2352,15 @@ let rec zChecker l = function | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 | None -> true) | None -> false) +| SplitProof (p, pf1, pf2) -> + (match genCuttingPlane (p,NonStrict) with + | Some cp1 -> + (match genCuttingPlane ((popp1 p),NonStrict) with + | Some cp2 -> + (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) + (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) + | None -> false) + | None -> false) | EnumProof (w1, w2, pf0) -> (match eval_Psatz0 l w1 with | Some f1 -> diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 53f62e0f5b..f75d8880c6 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,942 +1,740 @@ + type __ = Obj.t -type unit0 = Tt + +type unit0 = +| Tt val negb : bool -> bool -type nat = O | S of nat -type ('a, 'b) sum = Inl of 'a | Inr of 'b +type nat = +| O +| S of nat + +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 -val fst : 'a1 * 'a2 -> 'a1 -val snd : 'a1 * 'a2 -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list -type comparison = Eq | Lt | Gt +type comparison = +| Eq +| Lt +| Gt val compOpp : comparison -> comparison + val add : nat -> nat -> nat + val nth : nat -> 'a1 list -> 'a1 -> 'a1 + val rev_append : 'a1 list -> 'a1 list -> 'a1 list + val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list -val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -type positive = XI of positive | XO of positive | XH -type n = N0 | Npos of positive -type z = Z0 | Zpos of positive | Zneg of positive +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -module Pos : sig - type mask = IsNul | IsPos of positive | IsNeg -end +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -module Coq_Pos : sig +type positive = +| XI of positive +| XO of positive +| XH + +type n = +| N0 +| Npos of positive + +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +module Pos : + sig + type mask = + | IsNul + | IsPos of positive + | IsNeg + end + +module Coq_Pos : + sig val succ : positive -> positive + val add : positive -> positive -> positive + val add_carry : positive -> positive -> positive + val pred_double : positive -> positive - type mask = Pos.mask = IsNul | IsPos of positive | IsNeg + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg val succ_double_mask : mask -> mask + val double_mask : mask -> mask + val double_pred_mask : positive -> mask + val sub_mask : positive -> positive -> mask + val sub_mask_carry : positive -> positive -> mask + val sub : positive -> positive -> positive + val mul : positive -> positive -> positive + val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 + val size_nat : positive -> nat + val compare_cont : comparison -> positive -> positive -> comparison + val compare : positive -> positive -> comparison + val max : positive -> positive -> positive + val leb : positive -> positive -> bool + val gcdn : nat -> positive -> positive -> positive + val gcd : positive -> positive -> positive + val of_succ_nat : nat -> positive -end + end -module N : sig +module N : + sig val of_nat : nat -> n -end + end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -module Z : sig +module Z : + sig val double : z -> z + val succ_double : z -> z + val pred_double : z -> z + val pos_sub : positive -> positive -> z + val add : z -> z -> z + val opp : z -> z + val sub : z -> z -> z + val mul : z -> z -> z + val pow_pos : z -> positive -> z + val pow : z -> z -> z + val compare : z -> z -> comparison + val leb : z -> z -> bool + val ltb : z -> z -> bool + val gtb : z -> z -> bool + val max : z -> z -> z + val abs : z -> z + val to_N : z -> n + val of_nat : nat -> z + val of_N : n -> z + val pos_div_eucl : positive -> z -> z * z + val div_eucl : z -> z -> z * z + val div : z -> z -> z + val gcd : z -> z -> z -end + end val zeq_bool : z -> z -> bool type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol + val p1 : 'a1 -> 'a1 pol + val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + val mkPinj : positive -> 'a1 pol -> 'a1 pol + val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol + val mkX : 'a1 -> 'a1 -> 'a1 pol + val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubI : - ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> + 'a1 pol -> 'a1 pol val paddX : - 'a1 - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubX : - 'a1 - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 - -> 'a1 pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 - -> 'a1 pol +val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol -> 'a1 pol val psquare : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol) - -> 'a1 pol - -> 'a1 pol - -> positive - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol) - -> 'a1 pol - -> n - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pExpr - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -type kind = IsProp | IsBool +type kind = +| IsProp +| IsBool type ('tA, 'tX, 'aA, 'aF) gFormula = - | TT of kind - | FF of kind - | X of kind * 'tX - | A of kind * 'tA * 'aA - | AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula - | IMPL of - kind - * ('tA, 'tX, 'aA, 'aF) gFormula - * 'aF option - * ('tA, 'tX, 'aA, 'aF) gFormula - | IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| TT of kind +| FF of kind +| X of kind * 'tX +| A of kind * 'tA * 'aA +| AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula +| IMPL of kind * ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula +| IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula val mapX : - (kind -> 'a2 -> 'a2) - -> kind - -> ('a1, 'a2, 'a3, 'a4) gFormula - -> ('a1, 'a2, 'a3, 'a4) gFormula + (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula -val foldA : - ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 +val foldA : ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 val cons_id : 'a1 option -> 'a1 list -> 'a1 list + val ids_of_formula : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + val collect_annot : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list type rtyp = __ + type eKind = __ + type 'a bFormula = ('a, eKind, unit0, unit0) gFormula val map_bformula : - kind - -> ('a1 -> 'a2) - -> ('a1, 'a3, 'a4, 'a5) gFormula - -> ('a2, 'a3, 'a4, 'a5) gFormula + kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula type ('x, 'annot) clause = ('x * 'annot) list + type ('x, 'annot) cnf = ('x, 'annot) clause list val cnf_tt : ('a1, 'a2) cnf + val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause option val or_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option val xor_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val is_cnf_tt : ('a1, 'a2) cnf -> bool + val is_cnf_ff : ('a1, 'a2) cnf -> bool + val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val or_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val mk_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option val xcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, 'a2) + clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> (('a1, + 'a2) clause, 'a2 list) sum val xror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list -> + ('a1, 'a2) cnf * 'a2 list val ror_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf * 'a2 list val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list - -type ('term, 'annot, 'tX) to_constrT = - { mkTT : kind -> 'tX - ; mkFF : kind -> 'tX - ; mkA : kind -> 'term -> 'annot -> 'tX - ; mkAND : kind -> 'tX -> 'tX -> 'tX - ; mkOR : kind -> 'tX -> 'tX -> 'tX - ; mkIMPL : kind -> 'tX -> 'tX -> 'tX - ; mkIFF : kind -> 'tX -> 'tX -> 'tX - ; mkNOT : kind -> 'tX -> 'tX - ; mkEQ : 'tX -> 'tX -> 'tX } - -val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = { mkTT : (kind -> 'tX); mkFF : (kind -> 'tX); + mkA : (kind -> 'term -> 'annot -> 'tX); + mkAND : (kind -> 'tX -> 'tX -> 'tX); + mkOR : (kind -> 'tX -> 'tX -> 'tX); + mkIMPL : (kind -> 'tX -> 'tX -> 'tX); + mkIFF : (kind -> 'tX -> 'tX -> 'tX); + mkNOT : (kind -> 'tX -> 'tX); mkEQ : ('tX -> 'tX -> 'tX) } + +val aformula : ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option val abs_and : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_or : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_not : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val mk_arrow : - 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_simpl : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_and : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_or : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_impl : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool +val or_is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool val abs_iff : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> kind -> ('a1, 'a2, + 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_iff : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_eq : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_form : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula -val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> (('a2 * 'a3) list -> 'a4 -> bool) - -> ('a1, rtyp, 'a3, unit0) gFormula - -> 'a4 list - -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, rtyp, 'a3, unit0) gFormula -> 'a4 + list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol -type op1 = Equal | NonEqual | Strict | NonStrict + +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict + type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option + val opAdd : op1 -> op1 -> op1 option type 'c psatz = - | PsatzIn of nat - | PsatzSquare of 'c polC - | PsatzMulC of 'c polC * 'c psatz - | PsatzMulE of 'c psatz * 'c psatz - | PsatzAdd of 'c psatz * 'c psatz - | PsatzC of 'c - | PsatzZ +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option +val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 polC - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> + 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula + -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula + option val eval_Psatz : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> 'a1 nFormula option - -val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + +val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> bool - -type op2 = OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt -type 't formula = {flhs : 't pExpr; fop : op2; frhs : 't pExpr} + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pExpr - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol -val padd0 : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol +val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a1 nFormula + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list val cnf_of_list : - 'a1 - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 nFormula, + 'a2) cnf val cnf_normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val cnf_negate : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr + val denorm : 'a1 pol -> 'a1 pExpr + val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr + val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula -val simpl_cone : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 psatz - -> 'a1 psatz +val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz -type q = {qnum : z; qden : positive} +type q = { qnum : z; qden : positive } val qeq_bool : q -> q -> bool + val qle_bool : q -> q -> bool + val qplus : q -> q -> q + val qmult : q -> q -> q + val qopp : q -> q + val qminus : q -> q -> q + val qinv : q -> q + val qpower_positive : q -> positive -> q + val qpower : q -> z -> q -type 'a t = Empty | Elt of 'a | Branch of 'a t * 'a * 'a t +type 'a t = +| Empty +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 + val singleton : 'a1 -> positive -> 'a1 -> 'a1 t + val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t + val zeval_const : z pExpr -> z option type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool + val psub1 : z pol -> z pol -> z pol + +val popp1 : z pol -> z pol + val padd1 : z pol -> z pol -> z pol + val normZ : z pExpr -> z pol + val zunsat : z nFormula -> bool + val zdeduce : z nFormula -> z nFormula -> z nFormula option + val xnnormalise : z formula -> z nFormula + val xnormalise0 : z nFormula -> z nFormula list + val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list + val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf + val xnegate0 : z nFormula -> z nFormula list + val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf -val cnfZ : - kind - -> (z formula, 'a1, 'a2, 'a3) tFormula - -> (z nFormula, 'a1) cnf * 'a1 list +val cnfZ : kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list val ceiling : z -> z -> z type zArithProof = - | DoneProof - | RatProof of zWitness * zArithProof - | CutProof of zWitness * zArithProof - | EnumProof of zWitness * zWitness * zArithProof list - | ExProof of positive * zArithProof +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof val zgcdM : z -> z -> z + val zgcd_pol : z polC -> z * z + val zdiv_pol : z polC -> z -> z polC + val makeCuttingPlane : z polC -> z polC * z + val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option -val nformula_of_cutting_plane : (z polC * z) * op1 -> z nFormula + +val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula + val is_pol_Z0 : z polC -> bool + val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option + val valid_cut_sign : op1 -> bool + val bound_var : positive -> z formula + val mk_eq_pos : positive -> positive -> positive -> z formula + val max_var : positive -> z pol -> positive + val max_var_nformulae : z nFormula list -> positive + val zChecker : z nFormula list -> zArithProof -> bool + val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool + val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qunsat : q nFormula -> bool + val qdeduce : q nFormula -> q nFormula -> q nFormula option + val normQ : q pExpr -> q pol -val cnfQ : - kind - -> (q formula, 'a1, 'a2, 'a3) tFormula - -> (q nFormula, 'a1) cnf * 'a1 list +val cnfQ : kind -> (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = - | C0 - | C1 - | CQ of q - | CZ of z - | CPlus of rcst * rcst - | CMinus of rcst * rcst - | CMult of rcst * rcst - | CPow of rcst * (z, nat) sum - | CInv of rcst - | COpp of rcst +| C0 +| C1 +| CQ of q +| CZ of z +| CPlus of rcst * rcst +| CMinus of rcst * rcst +| CMult of rcst * rcst +| CPow of rcst * (z, nat) sum +| CInv of rcst +| COpp of rcst val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool + val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val runsat : q nFormula -> bool + val rdeduce : q nFormula -> q nFormula -> q nFormula option + val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 21178a64a5..6e997696cb 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -33,11 +33,32 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct type key = Key.t - module Table = Hashtbl.Make (Key) - - exception InvalidTableFormat - - type 'a t = {outch : out_channel; htbl : 'a Table.t} + module Table : + sig + type 'a t + val empty : 'a t + val add : int -> 'a -> 'a t -> 'a t + val find : int -> 'a t -> 'a list + val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end = + struct + type 'a t = 'a list Int.Map.t + let empty = Int.Map.empty + let add h pos tab = + try Int.Map.modify h (fun _ l -> pos :: l) tab + with Not_found -> Int.Map.add h [pos] tab + + let fold f tab accu = + let fold h l accu = List.fold_left (fun accu pos -> f h pos accu) accu l in + Int.Map.fold fold tab accu + + let find h tab = Int.Map.find h tab + end + (* A mapping key hash -> file position *) + + type 'a data = { pos : int; mutable obj : (Key.t * 'a) option } + + type 'a t = {outch : out_channel; mutable htbl : 'a data Table.t; file : string } (* XXX: Move to Fun.protect once in Ocaml 4.08 *) let fun_protect ~(finally : unit -> unit) work = @@ -55,10 +76,19 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct finally_no_exn (); Printexc.raise_with_backtrace work_exn work_bt - let read_key_elem inch = - try Some (Marshal.from_channel inch) with - | End_of_file -> None - | e when CErrors.noncritical e -> raise InvalidTableFormat + let skip_blob ch = + let hd = Bytes.create Marshal.header_size in + let () = really_input ch hd 0 Marshal.header_size in + let len = Marshal.data_size hd 0 in + let pos = pos_in ch in + seek_in ch (pos + len) + + let read_key_elem inch = match input_binary_int inch with + | hash -> + let pos = pos_in inch in + let () = skip_blob inch in + Some (hash, pos) + | exception End_of_file -> None (** We used to only lock/unlock regions. @@ -100,48 +130,98 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct let do_under_lock kd fd f = if lock kd fd then fun_protect f ~finally:(fun () -> unlock fd) else f () - let open_in f = + let fopen_in = open_in + + let open_in (type a) f : a t = let flags = [O_RDONLY; O_CREAT] in let finch = openfile f flags 0o666 in let inch = in_channel_of_descr finch in - let htbl = Table.create 100 in - let rec xload () = + let exception InvalidTableFormat of a data Table.t in + let rec xload table = match read_key_elem inch with - | None -> () - | Some (key, elem) -> Table.add htbl key elem; xload () + | None -> table + | Some (hash, pos) -> xload (Table.add hash { pos; obj = None } table) + | exception e when CErrors.noncritical e -> raise (InvalidTableFormat table) in try (* Locking of the (whole) file while reading *) - do_under_lock Read finch xload; - close_in_noerr inch; - { outch = - out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) - ; htbl } - with InvalidTableFormat -> + let htbl = do_under_lock Read finch (fun () -> xload Table.empty) in + let () = close_in_noerr inch in + let outch = out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) in + { outch ; file = f; htbl } + with InvalidTableFormat htbl -> (* The file is corrupted *) - close_in_noerr inch; + let fold hash data accu = + let () = seek_in inch data.pos in + match Marshal.from_channel inch with + | (k, v) -> (hash, k, v) :: accu + | exception e -> accu + in + (* Try to salvage what we can *) + let data = do_under_lock Read finch (fun () -> Table.fold fold htbl []) in + let () = close_in_noerr inch in let flags = [O_WRONLY; O_TRUNC; O_CREAT] in let out = openfile f flags 0o666 in let outch = out_channel_of_descr out in - do_under_lock Write out (fun () -> - Table.iter - (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) - htbl; - flush outch); - {outch; htbl} + let fold htbl (h, k, e) = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + Table.add h { pos; obj = None } htbl + in + let dump () = + let htbl = List.fold_left fold Table.empty data in + let () = flush outch in + htbl + in + let htbl = do_under_lock Write out dump in + {outch; htbl; file = f} let add t k e = - let {outch; htbl = tbl} = t in + let {outch} = t in let fd = descr_of_out_channel outch in - Table.add tbl k e; - do_under_lock Write fd (fun _ -> - Marshal.to_channel outch (k, e) [Marshal.No_sharing]; - flush outch) + let h = Key.hash k land 0x7FFFFFFF in + let dump () = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + let () = flush outch in + pos + in + let pos = do_under_lock Write fd dump in + t.htbl <- Table.add h { pos; obj = Some (k, e) } t.htbl let find t k = let {outch; htbl = tbl} = t in - let res = Table.find tbl k in - res + let h = Key.hash k land 0x7FFFFFFF in + let lpos = Table.find h tbl in + (* First look for already live data *) + let find data = match data.obj with + | Some (k', v) -> if Key.equal k k' then Some v else None + | None -> None + in + match CList.find_map find lpos with + | res -> res + | exception Not_found -> + (* Otherwise perform I/O and look at the disk cache *) + let lpos = List.filter (fun data -> Option.is_empty data.obj) lpos in + let () = if CList.is_empty lpos then raise Not_found in + let ch = fopen_in t.file in + let find data = + let () = seek_in ch data.pos in + match Marshal.from_channel ch with + | (k', v) -> + if Key.equal k k' then + (* Store the data in memory *) + let () = data.obj <- Some (k, v) in + Some v + else None + | exception _ -> None + in + let lookup () = CList.find_map find lpos in + let res = do_under_lock Read (descr_of_out_channel outch) lookup in + let () = close_in_noerr ch in + res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 5c0aa9ef0d..7b29aa15f9 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -254,6 +254,16 @@ let is_strict c = c.op = Gt let eval_op = function Eq -> ( =/ ) | Ge -> ( >=/ ) | Gt -> ( >/ ) let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" +let compare_op o1 o2 = + match (o1, o2) with + | Eq, Eq -> 0 + | Eq, _ -> -1 + | _, Eq -> 1 + | Ge, Ge -> 0 + | Ge, _ -> -1 + | _, Ge -> 1 + | Gt, Gt -> 0 + let output_cstr o {coeffs; op; cst} = Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (Q.to_string cst) @@ -284,7 +294,11 @@ module LinPoly = struct if !fresh > vr then failwith (Printf.sprintf "Cannot reserve %i" vr) else fresh := vr + 1 - let get_fresh () = !fresh + let safe_reserve vr = if !fresh > vr then () else fresh := vr + 1 + + let get_fresh () = + let vr = !fresh in + incr fresh; vr let register m = try MonoMap.find m !index_of_monomial @@ -445,6 +459,7 @@ module ProofFormat = struct type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof @@ -471,6 +486,9 @@ module ProofFormat = struct | Done -> Printf.fprintf o "." | Step (i, p, pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Split (i, v, p1, p2) -> + Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 + output_proof p2 | Enum (i, p1, v, p2, pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp v output_prf_rule p2 (pp_list ";" output_proof) pl @@ -489,23 +507,36 @@ module ProofFormat = struct | CutPrf p -> pr_size p | MulC (v, p) -> pr_size p - let rec pr_rule_max_id = function - | Annot (_, p) -> pr_rule_max_id p - | Hyp i | Def i -> i + let rec pr_rule_max_hyp = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> i + | Def i -> -1 + | Cst _ | Zero | Square _ -> -1 + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_hyp p + | MulPrf (p1, p2) | AddPrf (p1, p2) -> + max (pr_rule_max_hyp p1) (pr_rule_max_hyp p2) + + let rec pr_rule_max_def = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> -1 + | Def i -> i | Cst _ | Zero | Square _ -> -1 - | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_id p + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_def p | MulPrf (p1, p2) | AddPrf (p1, p2) -> - max (pr_rule_max_id p1) (pr_rule_max_id p2) + max (pr_rule_max_def p1) (pr_rule_max_def p2) - let rec proof_max_id = function + let rec proof_max_def = function | Done -> -1 - | Step (i, pr, prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Step (i, pr, prf) -> max i (max (pr_rule_max_def pr) (proof_max_def prf)) + | Split (i, _, p1, p2) -> max i (max (proof_max_def p1) (proof_max_def p2)) | Enum (i, p1, _, p2, l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + let m = max (pr_rule_max_def p1) (pr_rule_max_def p2) in + List.fold_left (fun i prf -> max i (proof_max_def prf)) (max i m) l | ExProof (i, j, k, _, _, _, prf) -> - max (max (max i j) k) (proof_max_id prf) + max (max (max i j) k) (proof_max_def prf) + (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. + This is because the Coq proof format only accept they as a proof-step *) let rec pr_rule_def_cut id = function | Annot (_, p) -> pr_rule_def_cut id p | MulC (p, prf) -> @@ -536,46 +567,51 @@ module ProofFormat = struct let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p - let rec pr_rule_collect_hyps pr = + let rec pr_rule_collect_defs pr = match pr with - | Annot (_, pr) -> pr_rule_collect_hyps pr - | Hyp i | Def i -> ISet.add i ISet.empty + | Annot (_, pr) -> pr_rule_collect_defs pr + | Def i -> ISet.add i ISet.empty + | Hyp i -> ISet.empty | Cst _ | Zero | Square _ -> ISet.empty - | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_hyps pr + | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_defs pr | MulPrf (p1, p2) | AddPrf (p1, p2) -> - ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) - let simplify_proof p = - let rec simplify_proof p = - match p with - | Done -> (Done, ISet.empty) - | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) - | Step (i, pr, prf) -> - let prf', hyps = simplify_proof prf in - if not (ISet.mem i hyps) then (prf', hyps) - else - ( Step (i, pr, prf') - , ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps) ) - | Enum (i, p1, v, p2, pl) -> - let pl, hl = List.split (List.map simplify_proof pl) in - let hyps = List.fold_left ISet.union ISet.empty hl in - ( Enum (i, p1, v, p2, pl) - , ISet.add i - (ISet.union - (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) - hyps) ) - | ExProof (i, j, k, x, z, t, prf) -> - let prf', hyps = simplify_proof prf in - if - (not (ISet.mem i hyps)) - && (not (ISet.mem j hyps)) - && not (ISet.mem k hyps) - then (prf', hyps) - else - ( ExProof (i, j, k, x, z, t, prf') - , ISet.add i (ISet.add j (ISet.add k hyps)) ) - in - fst (simplify_proof p) + (** [simplify_proof p] removes proof steps that are never re-used. *) + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_defs pr)) + | Step (i, pr, prf) -> + let prf', hyps = simplify_proof prf in + if not (ISet.mem i hyps) then (prf', hyps) + else + ( Step (i, pr, prf') + , ISet.add i (ISet.union (pr_rule_collect_defs pr) hyps) ) + | Split (i, v, p1, p2) -> + let p1, h1 = simplify_proof p1 in + let p2, h2 = simplify_proof p2 in + if not (ISet.mem i h1) then (p1, h1) (* Should not have computed p2 *) + else if not (ISet.mem i h2) then (p2, h2) + else (Split (i, v, p1, p2), ISet.add i (ISet.union h1 h2)) + | Enum (i, p1, v, p2, pl) -> + let pl, hl = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + ( Enum (i, p1, v, p2, pl) + , ISet.add i + (ISet.union + (ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2)) + hyps) ) + | ExProof (i, j, k, x, z, t, prf) -> + let prf', hyps = simplify_proof prf in + if + (not (ISet.mem i hyps)) + && (not (ISet.mem j hyps)) + && not (ISet.mem k hyps) + then (prf', hyps) + else + ( ExProof (i, j, k, x, z, t, prf') + , ISet.add i (ISet.add j (ISet.add k hyps)) ) let rec normalise_proof id prf = match prf with @@ -591,6 +627,10 @@ module ProofFormat = struct bds in (id, prf) + | Split (i, v, p1, p2) -> + let id, p1 = normalise_proof id p1 in + let id, p2 = normalise_proof id p2 in + (id, Split (i, v, p1, p2)) | ExProof (i, j, k, x, z, t, prf) -> let id, prf = normalise_proof id prf in (id, ExProof (i, j, k, x, z, t, prf)) @@ -612,7 +652,7 @@ module ProofFormat = struct (bds2 @ bds1) ) let normalise_proof id prf = - let prf = simplify_proof prf in + let prf = fst (simplify_proof prf) in let res = normalise_proof id prf in if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof @@ -652,9 +692,9 @@ module ProofFormat = struct | Gcd (b1, p1), Gcd (b2, p2) -> cmp_pair Z.compare compare (b1, p1) (b2, p2) | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) - | AddPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) + cmp_pair compare compare (p1, p2) (q1, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, p2) (q1, q2) | CutPrf p, CutPrf p' -> compare p p' | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) end @@ -746,16 +786,23 @@ module ProofFormat = struct Zero vect module Env = struct - let rec string_of_int_list l = + let output_hyp_or_def o = function + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | _ -> () + + let rec output_hyps o l = match l with - | [] -> "" - | i :: l -> Printf.sprintf "%i,%s" i (string_of_int_list l) + | [] -> () + | i :: l -> Printf.fprintf o "%a,%a" output_hyp_or_def i output_hyps l let id_of_hyp hyp l = let rec xid_of_hyp i l' = match l' with | [] -> - failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + Printf.fprintf stdout "\nid_of_hyp: %a notin [%a]\n" output_hyp_or_def + hyp output_hyps l; + failwith "Cannot find hyp or def" | hyp' :: l' -> if hyp = hyp' then i else xid_of_hyp (i + 1) l' in xid_of_hyp 0 l @@ -764,7 +811,7 @@ module ProofFormat = struct let cmpl_prf_rule norm (cst : Q.t -> 'a) env prf = let rec cmpl = function | Annot (s, p) -> cmpl p - | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) + | (Hyp _ | Def _) as h -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp h env)) | Cst i -> Mc.PsatzC (cst i) | Zero -> Mc.PsatzZ | MulPrf (p1, p2) -> Mc.PsatzMulE (cmpl p1, cmpl p2) @@ -780,25 +827,40 @@ module ProofFormat = struct let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (Q.num x)) env r + let cmpl_pol_z lp = + try + let cst x = CamlToCoq.bigint (Q.num x) in + Mc.normZ (LinPoly.coq_poly_of_linpol cst lp) + with x -> + Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; + raise x + let rec cmpl_proof env = function | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with | CutPrf p' -> - Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (i :: env) prf) - | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (i :: env) prf) ) + Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (Def i :: env) prf) + | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (Def i :: env) prf) + ) + | Split (i, v, p1, p2) -> + Mc.SplitProof + ( cmpl_pol_z v + , cmpl_proof (Def i :: env) p1 + , cmpl_proof (Def i :: env) p2 ) | Enum (i, p1, _, p2, l) -> Mc.EnumProof ( cmpl_prf_rule_z env p1 , cmpl_prf_rule_z env p2 - , List.map (cmpl_proof (i :: env)) l ) + , List.map (cmpl_proof (Def i :: env)) l ) | ExProof (i, j, k, x, _, _, prf) -> - Mc.ExProof (CamlToCoq.positive x, cmpl_proof (i :: j :: k :: env) prf) + Mc.ExProof + (CamlToCoq.positive x, cmpl_proof (Def i :: Def j :: Def k :: env) prf) let compile_proof env prf = - let id = 1 + proof_max_id prf in + let id = 1 + proof_max_def prf in let _, prf = normalise_proof id prf in - cmpl_proof env prf + cmpl_proof (List.map (fun i -> Hyp i) env) prf let rec eval_prf_rule env = function | Annot (s, p) -> eval_prf_rule env p @@ -848,6 +910,7 @@ module ProofFormat = struct false end else eval_proof (IMap.add i (p, o) env) rst + | Split (i, v, p1, p2) -> failwith "Not implemented" | Enum (i, r1, v, r2, l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in @@ -863,7 +926,7 @@ module WithProof = struct let compare : t -> t -> int = fun ((lp1, o1), _) ((lp2, o2), _) -> let c = Vect.compare lp1 lp2 in - if c = 0 then compare o1 o2 else c + if c = 0 then compare_op o1 o2 else c let annot s (p, prf) = (p, ProofFormat.Annot (s, prf)) @@ -887,6 +950,13 @@ module WithProof = struct fun ((p1, o1), prf1) ((p2, o2), prf2) -> ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + let neg : t -> t = + fun ((p1, o1), prf1) -> + match o1 with + | Eq -> + ((Vect.mul Q.minus_one p1, o1), ProofFormat.mul_cst_proof Q.minus_one prf1) + | _ -> failwith "neg: invalid proof" + let mult p ((p1, o1), prf1) = match o1 with | Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1) @@ -912,13 +982,13 @@ module WithProof = struct else match o with | Eq -> - Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) + Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.CutPrf prf) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> (* This is a non-trivial common divisor *) Some ( (Vect.set 0 c1' (Vect.div (Q.of_bigint g) p), o) - , ProofFormat.Gcd (g, prf) ) + , ProofFormat.CutPrf prf ) let construct_sign p = let c, p' = Vect.decomp_cst p in @@ -1011,6 +1081,22 @@ module WithProof = struct | None -> sys0 | Some sys' -> sys' ) + let sort (sys : t list) = + let size ((p, o), prf) = + let _, p' = Vect.decomp_cst p in + let (x, q), p' = Vect.decomp_fst p' in + Vect.fold + (fun (l, (q, x)) x' q' -> + let q' = Q.abs q' in + (l + 1, if q </ q then (q, x) else (q', x'))) + (1, (Q.abs q, x)) + p + in + let cmp ((l1, (q1, _)), ((_, o), _)) ((l2, (q2, _)), ((_, o'), _)) = + if l1 < l2 then -1 else if l1 = l2 then Q.compare q1 q2 else 1 + in + List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) + let subst sys0 = let elim sys = let oeq, sys' = extract (is_substitution true) sys in @@ -1018,7 +1104,7 @@ module WithProof = struct | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in - iterate_until_stable elim sys0 + iterate_until_stable elim (List.map snd (sort sys0)) let saturate_subst b sys0 = let select = is_substitution b in @@ -1029,6 +1115,26 @@ module WithProof = struct in saturate select gen sys0 + let simple_pivot (q1, x) ((v1, o1), prf1) ((v2, o2), prf2) = + let q2 = Vect.get x v2 in + if q2 =/ Q.zero then None + else + let cv1, cv2 = + if Q.sign q1 <> Q.sign q2 then (Q.abs q2, Q.abs q1) + else + match (o1, o2) with + | Eq, _ -> (q2, Q.abs q1) + | _, Eq -> (Q.abs q2, q2) + | _, _ -> (Q.zero, Q.zero) + in + if cv2 =/ Q.zero then None + else + Some + ( (Vect.mul_add cv1 v1 cv2 v2, opAdd o1 o2) + , ProofFormat.add_proof + (ProofFormat.mul_cst_proof cv1 prf1) + (ProofFormat.mul_cst_proof cv2 prf2) ) + open Vect.Bound let mul_bound w1 w2 = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 9c09f76691..84b5421207 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -120,6 +120,7 @@ type cstr = {coeffs : Vect.t; op : op; cst : Q.t} and op = Eq | Ge | Gt val eval_op : op -> Q.t -> Q.t -> bool +val compare_op : op -> op -> int (*val opMult : op -> op -> op*) @@ -153,6 +154,9 @@ module LinPoly : sig (** [reserve i] reserves the integer i *) val reserve : int -> unit + (** [safe_reserve i] reserves the integer i *) + val safe_reserve : int -> unit + (** [get_fresh ()] return the first fresh variable *) val get_fresh : unit -> int @@ -283,14 +287,16 @@ module ProofFormat : sig type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof (* x = z - t, z >= 0, t >= 0 *) val pr_size : prf_rule -> Q.t - val pr_rule_max_id : prf_rule -> int - val proof_max_id : proof -> int + val pr_rule_max_def : prf_rule -> int + val pr_rule_max_hyp : prf_rule -> int + val proof_max_def : proof -> int val normalise_proof : int -> proof -> int * proof val output_prf_rule : out_channel -> prf_rule -> unit val output_proof : out_channel -> proof -> unit @@ -302,13 +308,16 @@ module ProofFormat : sig val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> (Q.t -> 'a) - -> int list + -> prf_rule list -> prf_rule -> 'a Micromega.psatz val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool + val simplify_proof : proof -> proof * Mutils.ISet.t + + module PrfRuleMap : Map.S with type key = prf_rule end val output_cstr : out_channel -> cstr -> unit @@ -344,6 +353,12 @@ module WithProof : sig @return the polynomial p+q with its sign and proof *) val addition : t -> t -> t + (** [neg p] + @return the polynomial -p with its sign and proof + @raise an error if this not an equality + *) + val neg : t -> t + (** [mult p q] @return the polynomial p*q with its sign and proof. @raise InvalidProof if p is not a constant and p is not an equality *) @@ -360,6 +375,13 @@ module WithProof : sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + (** [simple_pivot (c,x) p q] performs a pivoting over the variable [x] where + p = c+a1.x1+....+c.x+...an.xn and c <> 0 *) + val simple_pivot : Q.t * var -> t -> t -> t option + + (** [sort sys] sorts constraints according to the lexicographic order (number of variables, size of the smallest coefficient *) + val sort : t list -> ((int * (Q.t * var)) * t) list + (** [subst sys] performs the equivalent of the 'subst' tactic of Coq. For every p=0 \in sys such that p is linear in x with coefficient +/- 1 i.e. p = 0 <-> x = e and x \notin e. diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index f59d65085a..39024819be 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -60,6 +60,77 @@ let get_profile_info () = ( try (p.success_pivots + p.failure_pivots) / p.average_pivots with Division_by_zero -> 0 ) } +(* SMT output for debugging *) + +(* +let pp_smt_row o (k, v) = + Printf.fprintf o "(assert (= x%i %a))\n" k Vect.pp_smt v + +let pp_smt_assert_tbl o tbl = IMap.iter (fun k v -> pp_smt_row o (k, v)) tbl + +let pp_smt_goal_tbl o tbl = + let pp_rows o tbl = + IMap.iter (fun k v -> Printf.fprintf o "(= x%i %a)" k Vect.pp_smt v) tbl + in + Printf.fprintf o "(assert (not (and %a)))\n" pp_rows tbl + +let pp_smt_vars s o var = + ISet.iter + (fun i -> + Printf.fprintf o "(declare-const x%i %s);%a\n" i s LinPoly.pp_var i) + (ISet.remove 0 var) + +let pp_smt_goal s o tbl1 tbl2 = + let set_of_row vr v = ISet.add vr (Vect.variables v) in + let var = + IMap.fold (fun k v acc -> ISet.union (set_of_row k v) acc) tbl1 ISet.empty + in + Printf.fprintf o "(echo \"%s\")\n(push) %a %a %a (check-sat) (pop)\n" s + (pp_smt_vars "Real") var pp_smt_assert_tbl tbl1 pp_smt_goal_tbl tbl2; + flush stdout + +let pp_smt_cut o lp c = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + Printf.fprintf o + "(push) \n\ + (echo \"new cut\")\n\ + %a %a (assert (not (>= %a 0)))\n\ + (check-sat) (pop)\n" + (pp_smt_vars "Int") var pp_list lp Vect.pp_smt c + +let pp_smt_sat o lp sol = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + let pp_model o v = + Vect.fold + (fun () v x -> + Printf.fprintf o "(assert (= x%i %a))\n" v Vect.pp_smt (Vect.cst x)) + () v + in + Printf.fprintf o + "(push) \n(echo \"check base\")\n%a %a %a\n(check-sat) (pop)\n" + (pp_smt_vars "Real") var pp_list lp pp_model sol + *) + type iset = unit IMap.t (** Mapping basic variables to their equation. @@ -375,38 +446,6 @@ open Polynomial (*type varmap = (int * bool) IMap.t*) -let make_certificate vm l = - Vect.normalise - (Vect.fold - (fun acc x n -> - let x', b = IMap.find x vm in - Vect.set x' (if b then n else Q.neg n) acc) - Vect.null l) - -(** [eliminate_equalities vr0 l] - represents an equality e = 0 of index idx in the list l - by 2 constraints (vr:e >= 0) and (vr+1:-e >= 0) - The mapping vm maps vr to idx - *) - -let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) = - let rec elim idx vr vm l acc = - match l with - | [] -> (vr, vm, acc) - | c :: l -> ( - match c.op with - | Ge -> - let v = Vect.set 0 (Q.neg c.cst) c.coeffs in - elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc) - | Eq -> - let v1 = Vect.set 0 (Q.neg c.cst) c.coeffs in - let v2 = Vect.mul Q.minus_one v1 in - let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in - elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc) - | Gt -> raise Strict ) - in - elim 0 vr0 IMap.empty l [] - let find_solution rst tbl = IMap.fold (fun vr v res -> @@ -440,19 +479,9 @@ let rec solve opt l (rst : Restricted.t) (t : tableau) = | Some ((vr, v), l) -> ( match push_real opt vr v (Restricted.set_exc vr rst) t with | Sat (t', x) -> ( - (* let t' = remove_redundant rst t' in*) - match l with - | [] -> Inl (rst, t', x) - | _ -> solve opt l rst t' ) + match l with [] -> Inl (rst, t', x) | _ -> solve opt l rst t' ) | Unsat c -> Inr c ) -let find_unsat_certificate (l : Polynomial.cstr list) = - let vr = LinPoly.MonT.get_fresh () in - let _, vm, l' = eliminate_equalities vr l in - match solve false l' (Restricted.make vr) IMap.empty with - | Inr c -> Some (make_certificate vm c) - | Inl _ -> None - let fresh_var l = 1 + @@ -463,64 +492,110 @@ let fresh_var l = ISet.empty l) with Not_found -> 0 +module PrfEnv = struct + type t = WithProof.t IMap.t + + let empty = IMap.empty + + let register prf env = + let fr = LinPoly.MonT.get_fresh () in + (fr, IMap.add fr prf env) + + (* let register_def (v, op) {fresh; env} = + LinPoly.MonT.reserve fresh; + (fresh, {fresh = fresh + 1; env = IMap.add fresh ((v, op), Def fresh) env}) *) + + let set_prf i prf env = IMap.add i prf env + let find idx env = IMap.find idx env + + let rec of_list acc env l = + match l with + | [] -> (acc, env) + | (((lp, op), prf) as wp) :: l -> ( + match op with + | Gt -> raise Strict (* Should be eliminated earlier *) + | Ge -> + (* Simply register *) + let f, env' = register wp env in + of_list ((f, lp) :: acc) env' l + | Eq -> + (* Generate two constraints *) + let f1, env = register wp env in + let wp' = WithProof.neg wp in + let f2, env = register wp' env in + of_list ((f1, lp) :: (f2, fst (fst wp')) :: acc) env l ) + + let map f env = IMap.map f env +end + +let make_env (l : Polynomial.cstr list) = + PrfEnv.of_list [] PrfEnv.empty + (List.rev_map WithProof.of_cstr + (List.mapi (fun i x -> (x, ProofFormat.Hyp i)) l)) + let find_point (l : Polynomial.cstr list) = let vr = fresh_var l in - let _, vm, l' = eliminate_equalities vr l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env l in match solve false l' (Restricted.make vr) IMap.empty with | Inl (rst, t, _) -> Some (find_solution rst t) | _ -> None let optimise obj l = - let vr0 = LinPoly.MonT.get_fresh () in - let _, vm, l' = eliminate_equalities (vr0 + 1) l in + let vr = fresh_var l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env l in let bound pos res = match res with | Opt (_, Max n) -> Some (if pos then n else Q.neg n) | Opt (_, Ubnd _) -> None | Opt (_, Feas) -> None in - match solve false l' (Restricted.make vr0) IMap.empty with + match solve false l' (Restricted.make vr) IMap.empty with | Inl (rst, t, _) -> Some - ( bound false (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))) - , bound true (simplex true vr0 rst (add_row vr0 t obj)) ) + ( bound false (simplex true vr rst (add_row vr t (Vect.uminus obj))) + , bound true (simplex true vr rst (add_row vr t obj)) ) | _ -> None -open Polynomial +(** [make_certificate env l] makes very strong assumptions + about the form of the environment. + Each proof is assumed to be either: + - an hypothesis Hyp i + - or, the negation of an hypothesis (MulC(-1,Hyp i)) + *) -let env_of_list l = - List.fold_left (fun (i, m) l -> (i + 1, IMap.add i l m)) (0, IMap.empty) l +let make_certificate env l = + Vect.normalise + (Vect.fold + (fun acc x n -> + let _, prf = PrfEnv.find x env in + ProofFormat.( + match prf with + | Hyp i -> Vect.set i n acc + | MulC (_, Hyp i) -> Vect.set i (Q.neg n) acc + | _ -> failwith "make_certificate: invalid proof")) + Vect.null l) + +let find_unsat_certificate (l : Polynomial.cstr list) = + let l', env = make_env l in + let vr = fresh_var l in + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate env c) + | Inl _ -> None +open Polynomial open ProofFormat -let make_farkas_certificate (env : WithProof.t IMap.t) vm v = +let make_farkas_certificate (env : PrfEnv.t) v = Vect.fold - (fun acc x n -> - add_proof acc - begin - try - let x', b = IMap.find x vm in - mul_cst_proof (if b then n else Q.neg n) (snd (IMap.find x' env)) - with Not_found -> - (* This is an introduced hypothesis *) - mul_cst_proof n (snd (IMap.find x env)) - end) + (fun acc x n -> add_proof acc (mul_cst_proof n (snd (PrfEnv.find x env)))) Zero v -let make_farkas_proof (env : WithProof.t IMap.t) vm v = +let make_farkas_proof (env : PrfEnv.t) v = Vect.fold (fun wp x n -> - WithProof.addition wp - begin - try - let x', b = IMap.find x vm in - let n = if b then n else Q.neg n in - let prf = IMap.find x' env in - WithProof.mult (Vect.cst n) prf - with Not_found -> - let prf = IMap.find x env in - WithProof.mult (Vect.cst n) prf - end) + WithProof.addition wp (WithProof.mult (Vect.cst n) (PrfEnv.find x env))) WithProof.zero v let frac_num n = n -/ Q.floor n @@ -532,9 +607,15 @@ type ('a, 'b) hitkind = (* Yes, we have a positive result *) | Keep of 'b -let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = +let violation sol vect = + let sol = Vect.set 0 Q.one sol in + let c = Vect.get 0 vect in + if Q.zero =/ c then Vect.dotproduct sol vect + else Q.abs (Vect.dotproduct sol vect // c) + +let cut env rmin sol (rst : Restricted.t) tbl (x, v) = let n, r = Vect.decomp_cst v in - let fn = frac_num n in + let fn = frac_num (Q.abs n) in if fn =/ Q.zero then Forget (* The solution is integral *) else (* The cut construction is from: @@ -580,7 +661,7 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = in let lcut = ( fst ccoeff - , make_farkas_proof env vm (Vect.normalise (cut_vector (snd ccoeff))) ) + , make_farkas_proof env (Vect.normalise (cut_vector (snd ccoeff))) ) in let check_cutting_plane (p, c) = match WithProof.cutting_plane c with @@ -592,7 +673,9 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = | Some (v, prf) -> if debug then ( Printf.printf "%s: This is a cutting plane for %a:" p LinPoly.pp_var x; - Printf.printf " %a\n" WithProof.output (v, prf) ); + Printf.printf "(viol %f) %a\n" + (Q.to_float (violation sol (fst v))) + WithProof.output (v, prf) ); Some (x, (v, prf)) in match check_cutting_plane lcut with @@ -621,30 +704,69 @@ let merge_best lt oldr newr = | Forget, Keep v -> Keep v | Keep v, Keep v' -> Keep v' -let find_cut nb env u sol vm rst tbl = +(*let size_vect v = + let abs z = if Z.compare z Z.zero < 0 then Z.neg z else z in + Vect.fold + (fun acc _ q -> Z.add (abs (Q.num q)) (Z.add (Q.den q) acc)) + Z.zero v + *) + +let find_cut nb env u sol rst tbl = if nb = 0 then IMap.fold - (fun x v acc -> merge_result_old acc (cut env u sol vm rst tbl) (x, v)) + (fun x v acc -> merge_result_old acc (cut env u sol rst tbl) (x, v)) tbl Forget else - let lt (_, (_, p1)) (_, (_, p2)) = + let lt (_, ((v1, _), p1)) (_, ((v2, _), p2)) = + (*violation sol v1 >/ violation sol v2*) ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 in IMap.fold - (fun x v acc -> merge_best lt acc (cut env u sol vm rst tbl (x, v))) + (fun x v acc -> merge_best lt acc (cut env u sol rst tbl (x, v))) tbl Forget +let find_split env tbl rst = + let is_split x v = + let v, n = + let n, _ = Vect.decomp_cst v in + if Restricted.is_restricted x rst then + let n', v = Vect.decomp_cst (fst (fst (PrfEnv.find x env))) in + (v, n -/ n') + else (Vect.set x Q.one Vect.null, n) + in + if Restricted.is_restricted x rst then None + else + let fn = frac_num n in + if fn =/ Q.zero then None + else + let fn = Q.abs fn in + let score = Q.min fn (Q.one -/ fn) in + let vect = Vect.add (Vect.cst (Q.neg n)) v in + Some (Vect.normalise vect, score) + in + IMap.fold + (fun x v acc -> + match is_split x v with + | None -> acc + | Some (v, s) -> ( + match acc with + | None -> Some (v, s) + | Some (v', s') -> if s' >/ s then acc else Some (v, s) )) + tbl None + let var_of_vect v = fst (fst (Vect.decomp_fst v)) -let eliminate_variable (bounded, vr, env, tbl) x = +let eliminate_variable (bounded, env, tbl) x = if debug then Printf.printf "Eliminating variable %a from tableau\n%a\n" LinPoly.pp_var x output_tableau tbl; (* We identify the new variables with the constraint. *) - LinPoly.MonT.reserve vr; - let z = LinPoly.var (vr + 1) in + let vr = LinPoly.MonT.get_fresh () in + let vr1 = LinPoly.MonT.get_fresh () in + let vr2 = LinPoly.MonT.get_fresh () in + let z = LinPoly.var vr1 in let zv = var_of_vect z in - let t = LinPoly.var (vr + 2) in + let t = LinPoly.var vr2 in let tv = var_of_vect t in (* x = z - t *) let xdef = Vect.add z (Vect.uminus t) in @@ -653,9 +775,9 @@ let eliminate_variable (bounded, vr, env, tbl) x = let tp = ((t, Ge), Def tv) in (* Pivot the current tableau using xdef *) let tbl = IMap.map (fun v -> Vect.subst x xdef v) tbl in - (* Pivot the environment *) + (* Pivot the proof environment *) let env = - IMap.map + PrfEnv.map (fun lp -> let (v, o), p = lp in let ai = Vect.get x v in @@ -664,77 +786,123 @@ let eliminate_variable (bounded, vr, env, tbl) x = env in (* Add the variables to the environment *) - let env = IMap.add vr xp (IMap.add zv zp (IMap.add tv tp env)) in + let env = + PrfEnv.set_prf vr xp (PrfEnv.set_prf zv zp (PrfEnv.set_prf tv tp env)) + in (* Remember the mapping *) let bounded = IMap.add x (vr, zv, tv) bounded in if debug then ( Printf.printf "Tableau without\n %a\n" output_tableau tbl; Printf.printf "Environment\n %a\n" output_env env ); - (bounded, vr + 3, env, tbl) + (bounded, env, tbl) let integer_solver lp = - let l, _ = List.split lp in - let vr0 = 3 * LinPoly.MonT.get_fresh () in - let vr, vm, l' = eliminate_equalities vr0 l in - let _, env = env_of_list (List.map WithProof.of_cstr lp) in let insert_row vr v rst tbl = match push_real true vr v rst tbl with - | Sat (t', x) -> Inl (Restricted.restrict vr rst, t', x) + | Sat (t', x) -> + (*pp_smt_goal stdout tbl vr v t';*) + Inl (Restricted.restrict vr rst, t', x) | Unsat c -> Inr c in + let vr0 = LinPoly.MonT.get_fresh () in + (* Initialise the proof environment mapping variables of the simplex to their proof. *) + let l', env = + PrfEnv.of_list [] PrfEnv.empty (List.rev_map WithProof.of_cstr lp) + in let nb = ref 0 in - let rec isolve env cr vr res = + let rec isolve env cr res = incr nb; match res with | Inr c -> - Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c), Done)) + Some + (Step + ( LinPoly.MonT.get_fresh () + , make_farkas_certificate env (Vect.normalise c) + , Done )) | Inl (rst, tbl, x) -> ( if debug then begin Printf.fprintf stdout "Looking for a cut\n"; Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; flush stdout - (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; - let sol = find_full_solution rst tbl in - match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with - | Forget -> - None (* There is no hope, there should be an integer solution *) - | Hit (cr, ((v, op), cut)) -> - if op = Eq then - (* This is a contradiction *) - Some (Step (vr, CutPrf cut, Done)) - else ( - LinPoly.MonT.reserve vr; - let res = insert_row vr v (Restricted.set_exc vr rst) tbl in - let prf = - isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) (vr + 1) res + if !nb mod 3 = 0 then + match find_split env tbl rst with + | None -> + None (* There is no hope, there should be an integer solution *) + | Some (v, s) -> ( + let vr = LinPoly.MonT.get_fresh () in + let wp1 = ((v, Ge), Def vr) in + let wp2 = ((Vect.mul Q.minus_one v, Ge), Def vr) in + match (WithProof.cutting_plane wp1, WithProof.cutting_plane wp2) with + | None, _ | _, None -> + failwith "Error: splitting over an integer variable" + | Some wp1, Some wp2 -> ( + if debug then + Printf.fprintf stdout "Splitting over (%s) %a:%a or %a \n" + (Q.to_string s) LinPoly.pp_var vr WithProof.output wp1 + WithProof.output wp2; + let v1', v2' = (fst (fst wp1), fst (fst wp2)) in + if debug then + Printf.fprintf stdout "Solving with %a\n" LinPoly.pp v1'; + let res1 = insert_row vr v1' (Restricted.set_exc vr rst) tbl in + let prf1 = isolve (IMap.add vr ((v1', Ge), Def vr) env) cr res1 in + match prf1 with + | None -> None + | Some prf1 -> + let prf', hyps = ProofFormat.simplify_proof prf1 in + if not (ISet.mem vr hyps) then Some prf' + else ( + if debug then + Printf.fprintf stdout "Solving with %a\n" Vect.pp v2'; + let res2 = insert_row vr v2' (Restricted.set_exc vr rst) tbl in + let prf2 = + isolve (IMap.add vr ((v2', Ge), Def vr) env) cr res2 + in + match prf2 with + | None -> None + | Some prf2 -> Some (Split (vr, v, prf1, prf2)) ) ) ) + else + let sol = find_full_solution rst tbl in + match find_cut (!nb mod 2) env cr (*x*) sol rst tbl with + | Forget -> + None (* There is no hope, there should be an integer solution *) + | Hit (cr, ((v, op), cut)) -> ( + let vr = LinPoly.MonT.get_fresh () in + if op = Eq then + (* This is a contradiction *) + Some (Step (vr, CutPrf cut, Done)) + else + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = + isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) res + in + match prf with + | None -> None + | Some p -> Some (Step (vr, CutPrf cut, p)) ) + | Keep (x, v) -> ( + if debug then + Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; + let bounded, env, tbl = + Vect.fold + (fun acc x n -> + if x <> 0 && not (Restricted.is_restricted x rst) then + eliminate_variable acc x + else acc) + (IMap.empty, env, tbl) v in + let prf = isolve env cr (Inl (rst, tbl, None)) in match prf with | None -> None - | Some p -> Some (Step (vr, CutPrf cut, p)) ) - | Keep (x, v) -> ( - if debug then - Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; - let bounded, vr, env, tbl = - Vect.fold - (fun acc x n -> - if x <> 0 && not (Restricted.is_restricted x rst) then - eliminate_variable acc x - else acc) - (IMap.empty, vr, env, tbl) v - in - let prf = isolve env cr vr (Inl (rst, tbl, None)) in - match prf with - | None -> None - | Some pf -> - Some - (IMap.fold - (fun x (vr, zv, tv) acc -> ExProof (vr, zv, tv, x, zv, tv, acc)) - bounded pf) ) ) + | Some pf -> + Some + (IMap.fold + (fun x (vr, zv, tv) acc -> + ExProof (vr, zv, tv, x, zv, tv, acc)) + bounded pf) ) ) in let res = solve true l' (Restricted.make vr0) IMap.empty in - isolve env None vr res + isolve env None res let integer_solver lp = nb_pivot := 0; diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index 4df32f2ba4..fe1d721b89 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -57,12 +57,17 @@ let pp_var_num pp_var o {var = v; coe = n} = else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v let pp_var_num_smt pp_var o {var = v; coe = n} = - if Int.equal v 0 then - if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) + let pp_num o q = + let nn = Q.num n in + let dn = Q.den n in + if Z.equal dn Z.one then output_string o (Z.to_string nn) + else Printf.fprintf o "(/ %s %s)" (Z.to_string nn) (Z.to_string dn) + in + if Int.equal v 0 then if Q.zero =/ n then () else pp_num o n else if Q.one =/ n then pp_var o v else if Q.minus_one =/ n then Printf.fprintf o "(- %a)" pp_var v else if Q.zero =/ n then () - else Printf.fprintf o "(* %s %a)" (Q.to_string n) pp_var v + else Printf.fprintf o "(* %a %a)" pp_num n pp_var v let rec pp_gen pp_var o v = match v with diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 9db6c075f8..b4742430fa 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -56,8 +56,8 @@ val get_cst : t -> Q.t (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> Q.t * t -(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) -val decomp_at : int -> t -> Q.t * t +(** [decomp_at xi v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : var -> t -> Q.t * t val decomp_fst : t -> (var * Q.t) * t diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 917961fdcd..d1403558ad 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -1070,6 +1070,28 @@ let pp_trans_expr env evd e res = Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); res +let declared_term env evd hd args = + let match_operator (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp (hd, Array.sub args 0 (n - i)) in + if is_convertible env evd t' t then Some (t, Array.sub args (n - i) i) + else None + in + match t with + | OtherTerm t -> ( match d with InjTyp _ -> None | _ -> Some (t, args) ) + | Application t -> ( + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None ) + in + find_option match_operator (HConstr.find_all hd !table) + let rec trans_expr env evd e = let inj = e.inj in let e = e.constr in diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 537e652fd0..555bb4c7fb 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -31,3 +31,10 @@ val iter_specs : unit Proofview.tactic val assert_inj : EConstr.constr -> unit Proofview.tactic val iter_let : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic val elim_let : unit Proofview.tactic + +val declared_term : + Environ.env + -> Evd.evar_map + -> EConstr.t + -> EConstr.t array + -> EConstr.constr * EConstr.t array diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 42b9248979..61643c2aa3 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -50,7 +50,7 @@ let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = SsrHyp (Loc.tag ?loc id) :: clr', rcs' | _ -> clr', rcs' -let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) (project gl) let interp_nbargs ist gl rc = try diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cb58b9bcb8..cd219838d5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -895,7 +895,7 @@ open Constrexpr open Util (** Constructors for constr_expr *) -let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [GProp,0]) +let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [CProp,0]) let mkCType loc = CAst.make ?loc @@ CSort (UAnonymous {rigid=true}) let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index a7ebd5f9f5..fdfba48024 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) rt)); + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index ccdf5fa68e..f06b460ee9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1792,7 +1792,7 @@ GRAMMAR EXTEND Gram { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex Once tac clauses } - | IDENT "do"; n = int_or_var; m = ssrmmod; + | IDENT "do"; n = nat_or_var; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc (mk_index ~loc n) m tac clauses } ] ]; diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index ab36d4fc7c..95c8024e89 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -57,17 +57,16 @@ let pr_guarded guard prc c = let s = Format.flush_str_formatter () ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c -let prl_constr_expr = +let with_global_env_evm f x = let env = Global.env () in let sigma = Evd.from_env env in - Ppconstr.pr_lconstr_expr env sigma -let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c -let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c + f env sigma x + +let prl_constr_expr = with_global_env_evm Ppconstr.pr_lconstr_expr +let pr_glob_constr = with_global_env_evm Printer.pr_glob_constr_env +let prl_glob_constr = with_global_env_evm Printer.pr_lglob_constr_env let pr_glob_constr_and_expr = function - | _, Some c -> - let env = Global.env () in - let sigma = Evd.from_env env in - Ppconstr.pr_constr_expr env sigma c + | _, Some c -> with_global_env_evm Ppconstr.pr_constr_expr c | c, None -> pr_glob_constr c let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 99cf197b78..3e44bd4d3b 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -203,8 +203,8 @@ let pr_raw_ssrhintref env sigma prc _ _ = let open CAst in function let pr_rawhintref env sigma c = match DAst.get c with | GApp (f, args) when isRHoles args -> - pr_glob_constr_env env f ++ str "|" ++ int (List.length args) - | _ -> pr_glob_constr_env env c + pr_glob_constr_env env sigma f ++ str "|" ++ int (List.length args) + | _ -> pr_glob_constr_env env sigma c let pr_glob_ssrhintref env sigma _ _ _ (c, _) = pr_rawhintref env sigma c diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index d99ead139d..97926753f5 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -195,7 +195,7 @@ let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in Ssrprinters.ppdebug (lazy - Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env glob)); + Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in Ssrprinters.ppdebug (lazy @@ -205,7 +205,7 @@ let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in Ssrprinters.ppdebug (lazy - Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env glob)); + Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index a4aa08300d..ea014250ca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -88,8 +88,12 @@ let pr_guarded guard prc c = let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) -let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c -let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let with_global_env_evm f x = + let env = Global.env () in + let sigma = Evd.from_env env in + f env sigma x +let prl_glob_constr = with_global_env_evm pr_lglob_constr_env +let pr_glob_constr = with_global_env_evm pr_glob_constr_env let prl_constr_expr = pr_lconstr_expr let pr_constr_expr = pr_constr_expr let prl_glob_constr_and_expr env sigma = function diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index b14b02f3bb..110b26581f 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -20,14 +20,14 @@ open Libnames (*** Constants for locating int63 constructors ***) -let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.int" -let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.id_int" +let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int" +let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.id_int" let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) (* int63 stuff *) -let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "Int63"] +let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "PrimInt63"] let int63_path = make_path int63_module "int" let int63_scope = "int63_scope" diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a793e217d4..d2859b1b4e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -46,8 +46,10 @@ module NamedDecl = Context.Named.Declaration type pattern_matching_error = | BadPattern of constructor * constr | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int + | WrongNumargConstructor of + {cstr:constructor; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} + | WrongNumargInductive of + {ind:inductive; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} | UnusedClause of cases_pattern list | NonExhaustive of cases_pattern list | CannotInferPredicate of (constr * types) array @@ -65,11 +67,13 @@ let error_bad_constructor ?loc env cstr ind = raise_pattern_matching_error ?loc (env, Evd.empty, BadConstructor (cstr,ind)) -let error_wrong_numarg_constructor ?loc env c n = - raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargConstructor(c,n)) +let error_wrong_numarg_constructor ?loc env ~cstr ~expanded ~nargs ~expected_nassums ~expected_ndecls = + raise_pattern_matching_error ?loc (env, Evd.empty, + WrongNumargConstructor {cstr; expanded; nargs; expected_nassums; expected_ndecls}) -let error_wrong_numarg_inductive ?loc env c n = - raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargInductive(c,n)) +let error_wrong_numarg_inductive ?loc env ~ind ~expanded ~nargs ~expected_nassums ~expected_ndecls = + raise_pattern_matching_error ?loc (env, Evd.empty, + WrongNumargInductive {ind; expanded; nargs; expected_nassums; expected_ndecls}) let list_try_compile f l = let rec aux errors = function @@ -519,13 +523,18 @@ let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in - if Int.equal (List.length args) nb_args_constr then pat + let nargs = List.length args in + if Int.equal nargs nb_args_constr then pat else try let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) in DAst.make ?loc @@ PatCstr (cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor ?loc env cstr nb_args_constr + let nlet = List.count (function LocalDef _ -> true | _ -> false) ci.cs_args in + (* In practice, this is already checked at interning *) + error_wrong_numarg_constructor ?loc env ~cstr + (* as if not expanded: *) ~expanded:false ~nargs ~expected_nassums:nb_args_constr + ~expected_ndecls:(nb_args_constr + nlet) else (* Try to insert a coercion *) try diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9a986bc14c..ade1fbf3d3 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -23,17 +23,21 @@ open Evardefine type pattern_matching_error = | BadPattern of constructor * constr | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int + | WrongNumargConstructor of + {cstr:constructor; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} + | WrongNumargInductive of + {ind:inductive; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} | UnusedClause of cases_pattern list | NonExhaustive of cases_pattern list | CannotInferPredicate of (constr * types) array exception PatternMatchingError of env * evar_map * pattern_matching_error -val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a +val error_wrong_numarg_constructor : + ?loc:Loc.t -> env -> cstr:constructor -> expanded:bool -> nargs:int -> expected_nassums:int -> expected_ndecls:int -> 'a -val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a +val error_wrong_numarg_inductive : + ?loc:Loc.t -> env -> ind:inductive -> expanded:bool -> nargs:int -> expected_nassums:int -> expected_ndecls:int -> 'a val irrefutable : env -> cases_pattern -> bool diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 2661000a39..bada2c3a60 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -111,15 +111,20 @@ let shift_value n v = * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1})) * -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti) *) + +let rec mk_fix_subs make_body n env i = + if Int.equal i n then env + else mk_fix_subs make_body n (subs_cons (make_body i) env) (i + 1) + let contract_fixp env ((reci,i),(_,_,bds as bodies)) = let make_body j = FIXP(((reci,j),bodies), env, [||]) in let n = Array.length bds in - subs_cons(Array.init n make_body, env), bds.(i) + mk_fix_subs make_body n env 0, bds.(i) let contract_cofixp env (i,(_,_,bds as bodies)) = let make_body j = COFIXP((j,bodies), env, [||]) in let n = Array.length bds in - subs_cons(Array.init n make_body, env), bds.(i) + mk_fix_subs make_body n env 0, bds.(i) let make_constr_ref n k t = match k with @@ -401,6 +406,10 @@ let rec strip_app = function | APP (args,st) -> APP (args,strip_app st) | s -> TOP +let rec subs_consn v i n s = + if Int.equal i n then s + else subs_consn v (i + 1) n (subs_cons v.(i) s) + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -456,7 +465,7 @@ let rec norm_head info env t stack = (* New rule: for Cbv, Delta does not apply to locally bound variables or red_set info.reds fDELTA *) - let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in + let env' = subs_cons (cbv_stack_term info TOP env b) env in norm_head info env' c stack else (CBN(t,env), stack) (* Should we consider a commutative cut ? *) @@ -526,14 +535,14 @@ and cbv_stack_value info env = function when red_set info.reds fBETA -> let nargs = Array.length args in if nargs == nlams then - cbv_stack_term info stk (subs_cons(args,env)) b + cbv_stack_term info stk (subs_consn args 0 nargs env) b else if nlams < nargs then - let env' = subs_cons(Array.sub args 0 nlams, env) in + let env' = subs_consn args 0 nlams env in let eargs = Array.sub args nlams (nargs-nlams) in cbv_stack_term info (APP(eargs,stk)) env' b else let ctxt' = List.skipn nargs ctxt in - LAM(nlams-nargs,ctxt', b, subs_cons(args,env)) + LAM(nlams-nargs,ctxt', b, subs_consn args 0 nargs env) (* a Fix applied enough -> IOTA *) | (FIXP(fix,env,[||]), stk) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a3f1c0b004..0e69b814c7 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -528,10 +528,9 @@ let sub_match ?(closed=true) env sigma pat c = let sub = subargs env types @ subargs env' bodies in try_aux sub next_mk_ctx next | Proj (p,c') -> - begin try - let term = Retyping.expand_projection env sigma p c' [] in - aux env term mk_ctx next - with Retyping.RetypeError _ -> next () + begin match Retyping.expand_projection env sigma p c' [] with + | term -> aux env term mk_ctx next + | exception Retyping.RetypeError _ -> next () end | Array(u, t, def, ty) -> let next_mk_ctx = function diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a12a832f76..402a6f6ed3 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -648,26 +648,16 @@ let detype_cofix detype flags avoid env sigma n (names,tys,bodies) = Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -(* TODO use some algebraic type with a case for unnamed univs so we - can cleanly detype them. NB: this corresponds to a hack in - Pretyping.interp_universe_level_name to convert Foo.xx strings into - universes. *) -let hack_qualid_of_univ_level sigma l = - match Termops.reference_of_level sigma l with - | Some qid -> qid - | None -> - let path = String.split_on_char '.' (Univ.Level.to_string l) in - let path = List.rev_map Id.of_string_soft path in - Libnames.qualid_of_dirpath (DirPath.make path) +let detype_level_name sigma l = + if Univ.Level.is_sprop l then GSProp else + if Univ.Level.is_prop l then GProp else + if Univ.Level.is_set l then GSet else + match UState.id_of_level (Evd.evar_universe_context sigma) l with + | Some id -> GLocalUniv (CAst.make id) + | None -> GUniv l let detype_universe sigma u = - let fn (l, n) = - let s = - if Univ.Level.is_prop l then GProp else - if Univ.Level.is_set l then GSet else - GType (hack_qualid_of_univ_level sigma l) in - (s, n) in - List.map fn (Univ.Universe.repr u) + List.map (on_fst (detype_level_name sigma)) (Univ.Universe.repr u) let detype_sort sigma = function | SProp -> UNamed [GSProp,0] @@ -684,8 +674,7 @@ type binder_kind = BProd | BLambda | BLetIn (* Main detyping function *) let detype_level sigma l = - let l = hack_qualid_of_univ_level sigma l in - UNamed (GType l) + UNamed (detype_level_name sigma l) let detype_instance sigma l = let l = EInstance.kind sigma l in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b770ae53bd..4b0974ae03 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -455,6 +455,58 @@ let compare_cumulative_instances evd variances u u' = Success evd | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) +let compare_heads env evd ~nargs term term' = + let check_strict evd u u' = + let cstrs = Univ.enforce_eq_instances u u' Univ.Constraint.empty in + try Success (Evd.add_constraints evd cstrs) + with Univ.UniverseInconsistency p -> UnifFailure (evd, UnifUnivInconsistency p) + in + match EConstr.kind evd term, EConstr.kind evd term' with + | Const (c, u), Const (c', u') when QConstant.equal env c c' -> + if Int.equal nargs 1 && Environ.is_array_type env c + then + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + compare_cumulative_instances evd [|Univ.Variance.Irrelevant|] u u' + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + check_strict evd u u' + | Const _, Const _ -> UnifFailure (evd, NotSameHead) + | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.Ind.CanOrd.equal ind ind' -> + if EInstance.is_empty u && EInstance.is_empty u' then Success evd + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + let mind = Environ.lookup_mind mi env in + let open Declarations in + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> + let needed = Reduction.inductive_cumulativity_arguments (mind,i) in + if not (Int.equal nargs needed) + then check_strict evd u u' + else + compare_cumulative_instances evd variances u u' + end + | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) + | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') + when Names.Construct.CanOrd.equal cons cons' -> + if EInstance.is_empty u && EInstance.is_empty u' then Success evd + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + let mind = Environ.lookup_mind mi env in + let open Declarations in + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> + let needed = Reduction.constructor_cumulativity_arguments (mind,ind,ctor) in + if not (Int.equal nargs needed) + then check_strict evd u u' + else + Success (compare_constructor_instances evd u u') + end + | Construct _, Construct _ -> UnifFailure (evd, NotSameHead) + | _, _ -> anomaly (Pp.str "") + + let conv_fun f flags on_types = let typefn env evd pbty term1 term2 = let flags = { (default_flags env) with @@ -567,65 +619,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else evar_eqappr_x flags env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = - let check_strict evd u u' = - let cstrs = Univ.enforce_eq_instances u u' Univ.Constraint.empty in - try Success (Evd.add_constraints evd cstrs) - with Univ.UniverseInconsistency p -> UnifFailure (evd, UnifUnivInconsistency p) - in - let compare_heads evd = - match EConstr.kind evd term, EConstr.kind evd term' with - | Const (c, u), Const (c', u') when QConstant.equal env c c' -> - if Int.equal (Stack.args_size sk) 1 && Environ.is_array_type env c - then - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - compare_cumulative_instances evd [|Univ.Variance.Irrelevant|] u u' - else - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - check_strict evd u u' - | Const _, Const _ -> UnifFailure (evd, NotSameHead) - | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.Ind.CanOrd.equal ind ind' -> - if EInstance.is_empty u && EInstance.is_empty u' then Success evd - else - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - let mind = Environ.lookup_mind mi env in - let open Declarations in - begin match mind.mind_variance with - | None -> check_strict evd u u' - | Some variances -> - let nparamsaplied = Stack.args_size sk in - let nparamsaplied' = Stack.args_size sk' in - let needed = Reduction.inductive_cumulativity_arguments (mind,i) in - if not (Int.equal nparamsaplied needed && Int.equal nparamsaplied' needed) - then check_strict evd u u' - else - compare_cumulative_instances evd variances u u' - end - | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) - | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') - when Names.Construct.CanOrd.equal cons cons' -> - if EInstance.is_empty u && EInstance.is_empty u' then Success evd - else - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - let mind = Environ.lookup_mind mi env in - let open Declarations in - begin match mind.mind_variance with - | None -> check_strict evd u u' - | Some variances -> - let nparamsaplied = Stack.args_size sk in - let nparamsaplied' = Stack.args_size sk' in - let needed = Reduction.constructor_cumulativity_arguments (mind,ind,ctor) in - if not (Int.equal nparamsaplied needed && Int.equal nparamsaplied' needed) - then check_strict evd u u' - else - Success (compare_constructor_instances evd u u') - end - | Construct _, Construct _ -> UnifFailure (evd, NotSameHead) - | _, _ -> anomaly (Pp.str "") - in - ise_and evd [(fun i -> - try compare_heads i - with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] + let nargs = Stack.args_size sk in + let nargs' = Stack.args_size sk' in + if not (Int.equal nargs nargs') then UnifFailure (evd, NotSameArgSize) + else + ise_and evd [(fun i -> + try compare_heads env i ~nargs term term' + with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] in let consume l2r (_, skF as apprF) (_,skM as apprM) i = if not (Stack.is_empty skF && Stack.is_empty skM) then diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index a5a8d1f916..be03ced7eb 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -84,6 +84,12 @@ val check_conv_record : env -> evar_map -> (constr Stack.t * constr Stack.t) * constr * (int option * constr) +(** Compares two constants/inductives/constructors unifying their universes. + It required the number of arguments applied to the c/i/c in order to decided + the kind of check it must perform. *) +val compare_heads : env -> evar_map -> + nargs:int -> EConstr.t -> EConstr.t -> Evarsolve.unification_result + (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index bd717e2d1f..52e3364109 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -21,42 +21,15 @@ module NamedDecl = Context.Named.Declaration (** Processing occurrences *) -type occurrence_error = - | InvalidOccurrence of int list - | IncorrectInValueOccurrence of Id.t - -let explain_invalid_occurrence l = - let l = List.sort_uniquize Int.compare l in - str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") - ++ prlist_with_sep spc int l ++ str "." - let explain_incorrect_in_value_occurrence id = Id.print id ++ str " has no value." -let explain_occurrence_error = function - | InvalidOccurrence l -> explain_invalid_occurrence l - | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id - -let error_occurrences_error e = - user_err (explain_occurrence_error e) - -let error_invalid_occurrence occ = - error_occurrences_error (InvalidOccurrence occ) - -let check_used_occurrences nbocc (nowhere_except_in,locs) = - let rest = List.filter (fun o -> o >= nbocc) locs in - match rest with - | [] -> () - | _ -> error_occurrences_error (InvalidOccurrence rest) - let proceed_with_occurrences f occs x = match occs with | NoOccurrences -> x | occs -> - let plocs = Locusops.convert_occs occs in - assert (List.for_all (fun x -> x >= 0) (snd plocs)); - let (nbocc,x) = f 1 x in - check_used_occurrences nbocc plocs; + let (occs,x) = f (Locusops.initialize_occurrence_counter occs) x in + Locusops.check_used_occurrences occs; x (** Applying a function over a named_declaration with an hypothesis @@ -70,7 +43,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> - error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) + user_err (explain_incorrect_in_value_occurrence id.Context.binder_name) | LocalAssum (id,typ), _ -> let acc,typ = f acc typ in acc, LocalAssum (id,typ) | LocalDef (id,body,typ), InHypTypeOnly -> @@ -101,43 +74,43 @@ type 'a testing_function = { means all occurrences except the ones in l *) let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref occ in + let count = ref (Locusops.initialize_occurrence_counter occs) in let nested = ref false in - let add_subst t subst = + let add_subst pos t subst = try test.testing_state <- test.merge_fun subst test.testing_state; - test.last_found <- Some ((cl,!pos),t) + test.last_found <- Some ((cl,pos),t) with NotUnifiable e when not like_first -> let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,e)) in let rec substrec k t = - if nowhere_except_in && !pos > maxocc then t else + if Locusops.occurrences_done !count then t else try let subst = test.match_fun test.testing_state t in - if Locusops.is_selected !pos occs then + let selected, count' = Locusops.update_occurrence_counter !count in count := count'; + if selected then + let pos = Locusops.current_occurrence !count in (if !nested then begin (* in case it is nested but not later detected as unconvertible, as when matching "id _" in "id (id 0)" *) let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,None)) + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,None)) end; - add_subst t subst; incr pos; + add_subst pos t subst; (* Check nested matching subterms *) - if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then + if Locusops.more_specific_occurrences !count then begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) else - (incr pos; subst_below k t) + subst_below k t with NotUnifiable _ -> subst_below k t and subst_below k t = map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in - (!pos, t') + (!count, t') let replace_term_occ_modulo evd occs test bywhat t = let occs',like_first = diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 436b730a88..1ddae01e2b 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -65,6 +65,3 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> constr -> named_declaration -> named_declaration * evar_map - -(** Miscellaneous *) -val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index f42c754ef5..86d2cc78e0 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -48,8 +48,10 @@ let glob_sort_name_eq g1 g2 = match g1, g2 with | GSProp, GSProp | GProp, GProp | GSet, GSet -> true - | GType u1, GType u2 -> Libnames.qualid_eq u1 u2 - | (GSProp|GProp|GSet|GType _), _ -> false + | GUniv u1, GUniv u2 -> Univ.Level.equal u1 u2 + | GLocalUniv u1, GLocalUniv u2 -> lident_eq u1 u2 + | GRawUniv u1, GRawUniv u2 -> Univ.Level.equal u1 u2 + | (GSProp|GProp|GSet|GUniv _|GLocalUniv _|GRawUniv _), _ -> false exception ComplexSort @@ -60,19 +62,23 @@ let glob_sort_family = let open Sorts in function | UNamed [GSet,0] -> InSet | _ -> raise ComplexSort -let glob_sort_expr_eq f u1 u2 = +let map_glob_sort_gen f = function + | UNamed l -> UNamed (f l) + | UAnonymous _ as x -> x + +let glob_sort_gen_eq f u1 u2 = match u1, u2 with | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 | UNamed l1, UNamed l2 -> f l1 l2 | (UNamed _ | UAnonymous _), _ -> false let glob_sort_eq u1 u2 = - glob_sort_expr_eq + glob_sort_gen_eq (List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n)) u1 u2 let glob_level_eq u1 u2 = - glob_sort_expr_eq glob_sort_name_eq u1 u2 + glob_sort_gen_eq glob_sort_name_eq u1 u2 let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Explicit, Explicit -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 6da8173dce..5ad1a207f3 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -11,8 +11,12 @@ open Names open Glob_term +val map_glob_sort_gen : ('a -> 'b) -> 'a glob_sort_gen -> 'b glob_sort_gen + (** Equalities *) +val glob_sort_gen_eq : ('a -> 'a -> bool) -> 'a glob_sort_gen -> 'a glob_sort_gen -> bool + val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool val glob_level_eq : Glob_term.glob_level -> Glob_term.glob_level -> bool diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index a49c8abe26..9f93e5e6c1 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -26,17 +26,23 @@ type glob_sort_name = | GSProp (** representation of [SProp] literal *) | GProp (** representation of [Prop] level *) | GSet (** representation of [Set] level *) - | GType of Libnames.qualid (** representation of a [Type] level *) + | GUniv of Univ.Level.t + | GLocalUniv of lident (** Locally bound universes (may also be nonstrict declaration) *) + | GRawUniv of Univ.Level.t + (** Hack for funind, DO NOT USE -type 'a glob_sort_expr = + Note that producing the similar Constrexpr.CRawType for printing + is OK, just don't try to reinterp it. *) + +type 'a glob_sort_gen = | UAnonymous of { rigid : bool } (** not rigid = unifiable by minimization *) | UNamed of 'a (** levels, occurring in universe instances *) -type glob_level = glob_sort_name glob_sort_expr +type glob_level = glob_sort_name glob_sort_gen (** sort expressions *) -type glob_sort = (glob_sort_name * int) list glob_sort_expr +type glob_sort = (glob_sort_name * int) list glob_sort_gen type glob_constraint = glob_sort_name * Univ.constraint_type * glob_sort_name @@ -131,7 +137,7 @@ type cases_pattern_disjunction = [ `any ] cases_pattern_disjunction_g type 'a extended_glob_local_binder_r = | GLocalAssum of Name.t * binding_kind * 'a glob_constr_g - | GLocalDef of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g option + | GLocalDef of Name.t * 'a glob_constr_g * 'a glob_constr_g option | GLocalPattern of ('a cases_pattern_disjunction_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 23145b1629..bd875cf68b 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -245,6 +245,14 @@ let inductive_alldecls env (ind,u) = let inductive_alldecls_env env (ind,u) = inductive_alldecls env (ind,u) [@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] +let inductive_alltags env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.to_tags mip.mind_arity_ctxt + +let constructor_alltags env (ind,j) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.to_tags (fst mip.mind_nf_lc.(j-1)) + let constructor_has_local_defs env (indsp,j) = let (mib,mip) = Inductive.lookup_mind_specif env indsp in let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1e2bba9f73..3705d39280 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -138,6 +138,10 @@ val constructor_nrealdecls : env -> constructor -> int val constructor_nrealdecls_env : env -> constructor -> int [@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] +(** @return tags of all decls: true = assumption, false = letin *) +val inductive_alltags : env -> inductive -> bool list +val constructor_alltags : env -> constructor -> bool list + (** Is there local defs in params or args ? *) val constructor_has_local_defs : env -> constructor -> bool val inductive_has_local_defs : env -> inductive -> bool diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 86352eb79a..256d61a32b 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Locus (** Utilities on or_var *) @@ -27,12 +28,43 @@ let occurrences_map f = function if l' = [] then AllOccurrences else AllOccurrencesBut l' | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o -let convert_occs = function - | AtLeastOneOccurrence -> (false,[]) - | AllOccurrences -> (false,[]) - | AllOccurrencesBut l -> (false,l) - | NoOccurrences -> (true,[]) - | OnlyOccurrences l -> (true,l) +type occurrences_count = {current: int; remaining: int list; where: (bool * int)} + +let error_invalid_occurrence l = + CErrors.user_err Pp.(str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") + ++ prlist_with_sep spc int l ++ str ".") + +let initialize_occurrence_counter occs = + let (nowhere_except_in,occs) = + match occs with + | AtLeastOneOccurrence -> (false,[]) + | AllOccurrences -> (false,[]) + | AllOccurrencesBut l -> (false,List.sort_uniquize Int.compare l) + | NoOccurrences -> (true,[]) + | OnlyOccurrences l -> (true,List.sort_uniquize Int.compare l) in + let max = + match occs with + | n::_ when n <= 0 -> error_invalid_occurrence [n] + | [] -> 0 + | _ -> Util.List.last occs in + {current = 0; remaining = occs; where = (nowhere_except_in,max)} + +let update_occurrence_counter {current; remaining; where = (nowhere_except_in,_ as where)} = + let current = succ current in + match remaining with + | occ::remaining when Int.equal current occ -> (nowhere_except_in,{current;remaining;where}) + | _ -> (not nowhere_except_in,{current;remaining;where}) + +let check_used_occurrences {remaining} = + if not (Util.List.is_empty remaining) then error_invalid_occurrence remaining + +let occurrences_done {current; where = (nowhere_except_in,max)} = + nowhere_except_in && current > max + +let current_occurrence {current} = current + +let more_specific_occurrences {current; where = (_,max)} = + current <= max let is_selected occ = function | AtLeastOneOccurrence -> true diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 911ccc1a38..748bfbc252 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -20,13 +20,44 @@ val or_var_map : ('a -> 'b) -> 'a or_var -> 'b or_var val occurrences_map : ('a list -> 'b list) -> 'a occurrences_gen -> 'b occurrences_gen -(** From occurrences to a list of positions (or complement of positions) *) -val convert_occs : occurrences -> bool * int list +(** {6 Counting occurrences} *) + +type occurrences_count + (** A counter of occurrences associated to a list of occurrences *) + +(** Three basic functions to initialize, count, and conclude a loop + browsing over subterms *) + +val initialize_occurrence_counter : occurrences -> occurrences_count + (** Initialize an occurrence_counter *) + +val update_occurrence_counter : occurrences_count -> bool * occurrences_count + (** Increase the occurrence counter by one and tell if the current occurrence is selected *) + +val check_used_occurrences : occurrences_count -> unit + (** Increase the occurrence counter and tell if the current occurrence is selected *) + +(** Auxiliary functions about occurrence counters *) + +val current_occurrence : occurrences_count -> int + (** Tell the value of the current occurrence *) + +val occurrences_done : occurrences_count -> bool + (** Tell if there are no more occurrences to select and if the loop + can be shortcut *) + +val more_specific_occurrences : occurrences_count -> bool + (** Tell if there are no more occurrences to select (or unselect) + and if an inner loop can be shortcut *) + +(** {6 Miscellaneous} *) val is_selected : int -> occurrences -> bool val is_all_occurrences : 'a occurrences_gen -> bool +val error_invalid_occurrence : int list -> 'a + (** Usual clauses *) val allHypsAndConcl : 'a clause_expr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index b70ff20e32..9dbded75ba 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -130,53 +130,32 @@ let is_strict_universe_declarations = (** Miscellaneous interpretation functions *) -let interp_known_universe_level_name evd qid = - try - let open Libnames in - if qualid_is_ident qid then Evd.universe_of_name evd @@ qualid_basename qid - else raise Not_found - with Not_found -> - let qid = Nametab.locate_universe qid in - Univ.Level.make qid - -let interp_universe_level_name evd qid = - try evd, interp_known_universe_level_name evd qid +let universe_level_name evd ({CAst.v=id} as lid) = + try evd, Evd.universe_of_name evd id with Not_found -> - if Libnames.qualid_is_ident qid then (* Undeclared *) - let id = Libnames.qualid_basename qid in - if not (is_strict_universe_declarations ()) then - new_univ_level_variable ?loc:qid.CAst.loc ~name:id univ_rigid evd - else user_err ?loc:qid.CAst.loc ~hdr:"interp_universe_level_name" - (Pp.(str "Undeclared universe: " ++ Id.print id)) - else - let dp, i = Libnames.repr_qualid qid in - let num = - try int_of_string (Id.to_string i) - with Failure _ -> - user_err ?loc:qid.CAst.loc ~hdr:"interp_universe_level_name" - (Pp.(str "Undeclared global universe: " ++ Libnames.pr_qualid qid)) - in - let level = Univ.Level.(make (UGlobal.make dp num)) in - let evd = - try Evd.add_global_univ evd level - with UGraph.AlreadyDeclared -> evd - in evd, level + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ?loc:lid.CAst.loc ~name:id univ_rigid evd + else user_err ?loc:lid.CAst.loc ~hdr:"universe_level_name" + (Pp.(str "Undeclared universe: " ++ Id.print id)) -let interp_sort_name sigma = function +let sort_name sigma = function | GSProp -> sigma, Univ.Level.sprop | GProp -> sigma, Univ.Level.prop | GSet -> sigma, Univ.Level.set - | GType l -> interp_universe_level_name sigma l + | GUniv u -> sigma, u + | GRawUniv u -> + (try Evd.add_global_univ sigma u with UGraph.AlreadyDeclared -> sigma), u + | GLocalUniv l -> universe_level_name sigma l -let interp_sort_info ?loc evd l = +let sort_info ?loc evd l = List.fold_left (fun (evd, u) (l,n) -> - let evd', u' = interp_sort_name evd l in + let evd', u' = sort_name evd l in let u' = Univ.Universe.make u' in let u' = match n with | 0 -> u' | 1 -> Univ.Universe.super u' | n -> - user_err ?loc ~hdr:"interp_universe" + user_err ?loc ~hdr:"sort_info" (Pp.(str "Cannot interpret universe increment +" ++ int n)) in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l @@ -393,24 +372,33 @@ let pretype_id pretype loc env sigma id = (*************************************************************************) (* Main pretyping function *) -let interp_known_glob_level ?loc evd = function +let known_universe_level_name evd lid = + try Evd.universe_of_name evd lid.CAst.v + with Not_found -> + let u = Nametab.locate_universe (Libnames.qualid_of_lident lid) in + Univ.Level.make u + +let known_glob_level evd = function | GSProp -> Univ.Level.sprop | GProp -> Univ.Level.prop | GSet -> Univ.Level.set - | GType qid -> - try interp_known_universe_level_name evd qid + | GUniv u -> u + | GRawUniv u -> anomaly Pp.(str "Raw universe in known_glob_level.") + | GLocalUniv lid -> + try known_universe_level_name evd lid with Not_found -> - user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) + user_err ?loc:lid.CAst.loc ~hdr:"known_level_info" + (str "Undeclared universe " ++ Id.print lid.CAst.v) -let interp_glob_level ?loc evd : glob_level -> _ = function +let glob_level ?loc evd : glob_level -> _ = function | UAnonymous {rigid} -> new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd - | UNamed s -> interp_sort_name evd s + | UNamed s -> sort_name evd s -let interp_instance ?loc evd l = +let instance ?loc evd l = let evd, l' = List.fold_left (fun (evd, univs) l -> - let evd, l = interp_glob_level ?loc evd l in + let evd, l = glob_level ?loc evd l in (evd, l :: univs)) (evd, []) l in @@ -424,7 +412,7 @@ let pretype_global ?loc rigid env evd gr us = let evd, instance = match us with | None -> evd, None - | Some l -> interp_instance ?loc evd l + | Some l -> instance ?loc evd l in Evd.fresh_global ?loc ~rigid ?names:instance !!env evd gr @@ -451,11 +439,11 @@ let pretype_ref ?loc sigma env ref us = let sigma, ty = type_of !!env sigma c in sigma, make_judge c ty -let interp_sort ?loc evd : glob_sort -> _ = function +let sort ?loc evd : glob_sort -> _ = function | UAnonymous {rigid} -> let evd, l = new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd in evd, Univ.Universe.make l - | UNamed l -> interp_sort_info ?loc evd l + | UNamed l -> sort_info ?loc evd l let judge_of_sort ?loc evd s = let judge = @@ -469,11 +457,22 @@ let pretype_sort ?loc sigma s = | UNamed [GProp,0] -> sigma, judge_of_prop | UNamed [GSet,0] -> sigma, judge_of_set | _ -> - let sigma, s = interp_sort ?loc sigma s in + let sigma, s = sort ?loc sigma s in judge_of_sort ?loc sigma s -let new_type_evar env sigma loc = - new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) +let new_typed_evar env sigma ?naming ~src tycon = + match tycon with + | Some ty -> + let sigma, c = new_evar env sigma ~src ?naming ty in + sigma, c, ty + | None -> + let sigma, ty = new_type_evar env sigma ~src in + let sigma, c = new_evar env sigma ~src ?naming ty in + let evk = fst (destEvar sigma c) in + let ido = Evd.evar_ident evk sigma in + let src = (fst src,Evar_kinds.EvarType (ido,evk)) in + let sigma = update_source sigma (fst (destEvar sigma ty)) src in + sigma, c, ty let mark_obligation_evar sigma k evc = match k with @@ -636,13 +635,9 @@ struct discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon let pretype_patvar self kind ?loc ~program_mode ~poly resolve_tc tycon env sigma = - let sigma, ty = - match tycon with - | Some ty -> sigma, ty - | None -> new_type_evar env sigma loc in let k = Evar_kinds.MatchingVar kind in - let sigma, uj_val = new_evar env sigma ~src:(loc,k) ty in - sigma, { uj_val; uj_type = ty } + let sigma, uj_val, uj_type = new_typed_evar env sigma ~src:(loc,k) tycon in + sigma, { uj_val; uj_type } let pretype_hole self (k, naming, ext) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -653,19 +648,15 @@ struct | IntroIdentifier id -> IntroIdentifier (interp_ltac_id env id) | IntroAnonymous -> IntroAnonymous | IntroFresh id -> IntroFresh (interp_ltac_id env id) in - let sigma, ty = - match tycon with - | Some ty -> sigma, ty - | None -> new_type_evar env sigma loc in - let sigma, uj_val = new_evar env sigma ~src:(loc,k) ~naming ty in + let sigma, uj_val, uj_type = new_typed_evar env sigma ~src:(loc,k) ~naming tycon in let sigma = if program_mode then mark_obligation_evar sigma k uj_val else sigma in - sigma, { uj_val; uj_type = ty } + sigma, { uj_val; uj_type } | Some arg -> let sigma, ty = match tycon with | Some ty -> sigma, ty - | None -> new_type_evar env sigma loc in + | 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 } @@ -1144,7 +1135,7 @@ struct | None -> let sigma, p = match tycon with | Some ty -> sigma, ty - | None -> new_type_evar env sigma loc + | None -> new_type_evar env sigma ~src:(loc,Evar_kinds.CasesType false) in sigma, it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar sigma pred in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 7bb4a6e273..5668098fe6 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -30,8 +30,7 @@ val get_bidirectionality_hint : GlobRef.t -> int option val clear_bidirectionality_hint : GlobRef.t -> unit -val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> - glob_sort_name -> Univ.Level.t +val known_glob_level : Evd.evar_map -> glob_sort_name -> Univ.Level.t (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index b6e44265ae..aa862a912e 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -323,23 +323,32 @@ let check_and_decompose_canonical_structure env sigma ref = let lookup_canonical_conversion env (proj,pat) = assoc_pat env pat (GlobRef.Map.find proj !object_table) -let decompose_projection sigma c args = +let rec get_nth n = function +| [] -> raise Not_found +| arg :: args -> + let len = Array.length arg in + if n < len then arg.(n) + else get_nth (n - len) args + +let rec decompose_projection sigma c args = match EConstr.kind sigma c with + | Meta mv -> decompose_projection sigma (Evd.meta_value sigma mv) 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 (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (GlobRef.ConstRef c) !object_table in - let arg = Stack.nth args n in - arg + get_nth n args | Proj (p, c) -> let _ = GlobRef.Map.find (GlobRef.ConstRef (Projection.constant p)) !object_table in c | _ -> raise Not_found -let is_open_canonical_projection env sigma (c,args) = +let is_open_canonical_projection env sigma c = let open EConstr in try - let arg = decompose_projection sigma c args in + let arg = decompose_projection sigma c [] in try let arg = whd_all env sigma arg in let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 5b8dc8184a..83927085e9 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -94,7 +94,7 @@ 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 -> Reductionops.state -> bool + Environ.env -> Evd.evar_map -> EConstr.t -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index cf5d4de40c..52f60fbc5e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -934,14 +934,6 @@ let stack_red_of_state_red f = let f env sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f env sigma (x, Stack.empty))) in f -(* Drops the Cst_stack *) -let iterate_whd_gen flags env sigma s = - let rec aux t = - let (hd,sk) = whd_state_gen flags env sigma (t,Stack.empty) in - let whd_sk = Stack.map aux sk in - Stack.zip sigma (hd,whd_sk) - in aux s - let red_of_state_red f env sigma x = Stack.zip sigma (f env sigma (x,Stack.empty)) @@ -1196,11 +1188,15 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = let default_plain_instance_ident = Id.of_string "H" +type subst_fun = { sfun : metavariable -> EConstr.t } + (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) -let plain_instance sigma s c = +let plain_instance sigma s c = match s with +| None -> c +| Some s -> let rec irec n u = match EConstr.kind sigma u with - | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) + | Meta p -> (try lift n (s.sfun p) with Not_found -> u) | App (f,l) when isCast sigma f -> let (f,_,t) = destCast sigma f in let l' = Array.Fun1.Smart.map irec n l in @@ -1209,7 +1205,7 @@ let plain_instance sigma s c = (* Don't flatten application nodes: this is used to extract a proof-term from a proof-tree and we want to keep the structure of the proof-tree *) - (try let g = Metamap.find p s in + (try let g = s.sfun p in match EConstr.kind sigma g with | App _ -> let l' = Array.Fun1.Smart.map lift 1 l' in @@ -1220,12 +1216,11 @@ let plain_instance sigma s c = with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta sigma m -> - (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) + (try lift n (s.sfun (destMeta sigma m)) with Not_found -> u) | _ -> map_with_binders sigma succ irec n u in - if Metamap.is_empty s then c - else irec 0 c + irec 0 c (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] has (unfortunately) different subtle side effects: @@ -1427,23 +1422,41 @@ let is_arity env sigma c = (*************************************) (* Metas *) -let meta_value env evd mv = - let rec valrec mv = - match meta_opt_fvalue evd mv with - | Some (b,_) -> - let metas = Metamap.bind valrec b.freemetas in - instance env evd metas b.rebus - | None -> mkMeta mv +type meta_instance_subst = { + sigma : Evd.evar_map; + mutable cache : EConstr.t Metamap.t; +} + +let create_meta_instance_subst sigma = { + sigma; + cache = Metamap.empty; +} + +let eval_subst env subst = + let rec ans mv = + try Metamap.find mv subst.cache + with Not_found -> + match meta_opt_fvalue subst.sigma mv with + | None -> mkMeta mv + | Some (b, _) -> + let metas = + if Metaset.is_empty b.freemetas then None + else Some { sfun = ans } + in + let res = instance env subst.sigma metas b.rebus in + let () = subst.cache <- Metamap.add mv res subst.cache in + res in - valrec mv + { sfun = ans } -let meta_instance env sigma b = +let meta_instance env subst b = let fm = b.freemetas in if Metaset.is_empty fm then b.rebus else - let c_sigma = Metamap.bind (fun mv -> meta_value env sigma mv) fm in - instance env sigma c_sigma b.rebus + let sfun = eval_subst env subst in + instance env subst.sigma (Some sfun) b.rebus let nf_meta env sigma c = + let sigma = create_meta_instance_subst sigma in let cl = mk_freelisted c in meta_instance env sigma { cl with rebus = cl.rebus } diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 29b698f9d6..ae93eb48b4 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -133,8 +133,6 @@ end (************************************************************************) -type state = constr * constr Stack.t - type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr @@ -142,11 +140,6 @@ type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -type state_reduction_function = - env -> evar_map -> state -> state - -val pr_state : env -> evar_map -> state -> Pp.t - (** {6 Reduction Function Operators } *) val strong_with_flags : @@ -154,12 +147,6 @@ val strong_with_flags : (CClosure.RedFlags.reds -> reduction_function) val strong : reduction_function -> reduction_function -val whd_state_gen : - CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state - -val iterate_whd_gen : CClosure.RedFlags.reds -> - Environ.env -> Evd.evar_map -> constr -> constr - (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function @@ -193,24 +180,13 @@ val whd_all_stack : stack_reduction_function val whd_allnolet_stack : stack_reduction_function val whd_betalet_stack : stack_reduction_function -val whd_nored_state : state_reduction_function -val whd_beta_state : state_reduction_function -val whd_betaiota_state : state_reduction_function -val whd_betaiotazeta_state : state_reduction_function -val whd_all_state : state_reduction_function -val whd_allnolet_state : state_reduction_function -val whd_betalet_state : state_reduction_function - (** {6 Head normal forms } *) val whd_delta_stack : stack_reduction_function -val whd_delta_state : state_reduction_function val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function -val whd_betadeltazeta_state : state_reduction_function val whd_betadeltazeta : reduction_function val whd_zeta_stack : stack_reduction_function -val whd_zeta_state : state_reduction_function val whd_zeta : reduction_function val shrink_eta : Environ.env -> constr -> constr @@ -296,11 +272,24 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> (** {6 Heuristic for Conversion with Evar } *) +type state = constr * constr Stack.t + +type state_reduction_function = + env -> evar_map -> state -> state + +val pr_state : env -> evar_map -> state -> Pp.t + +val whd_nored_state : state_reduction_function + val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state + TransparentState.t -> state_reduction_function (** {6 Meta-related reduction functions } *) -val meta_instance : env -> evar_map -> constr freelisted -> constr +type meta_instance_subst + +val create_meta_instance_subst : Evd.evar_map -> meta_instance_subst + +val meta_instance : env -> meta_instance_subst -> constr freelisted -> constr val nf_meta : env -> evar_map -> constr -> constr exception AnomalyInConversion of exn diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9cf7119709..c705ac16e7 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1046,28 +1046,23 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref 1 in + let count = ref (Locusops.initialize_occurrence_counter occs) in (* FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = - if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t + if Locusops.occurrences_done !count then (* Shortcut *) t else try let subst = if byhead then matches_head env sigma c t else Constr_matching.matches env sigma c t in - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; + let ok, count' = Locusops.update_occurrence_counter !count in count := count'; if ok then begin if Option.has_some nested then - user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (Locusops.current_occurrence !count) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) - if locs != [] then - ignore (traverse_below (Some (!pos-1)) envc t); + if Locusops.more_specific_occurrences !count then + ignore (traverse_below (Some (Locusops.current_occurrence !count)) envc t); let (evm, t) = (f subst) env !evd t in (evd := evm; t) end @@ -1087,7 +1082,7 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> (traverse nested) envc sigma t in let t' = traverse None (env,c) t in - if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; + Locusops.check_used_occurrences !count; (!evd, t') end @@ -1105,28 +1100,25 @@ let match_constr_evaluable_ref sigma c evref = | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None -let substlin env sigma evalref n (nowhere_except_in,locs) c = - let maxocc = List.fold_right max locs 0 in - let pos = ref n in - assert (List.for_all (fun x -> x >= 0) locs); +let substlin env sigma evalref occs c = + let count = ref (Locusops.initialize_occurrence_counter occs) in let value u = value_of_evaluable_ref env evalref u in let rec substrec () c = - if nowhere_except_in && !pos > maxocc then c + if Locusops.occurrences_done !count then c else match match_constr_evaluable_ref sigma c evalref with | Some u -> - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value u else c + let ok, count' = Locusops.update_occurrence_counter !count in + count := count'; + if ok then value u else c | None -> map_constr_with_binders_left_to_right sigma (fun _ () -> ()) substrec () c in let t' = substrec () c in - (!pos, t') + Locusops.check_used_occurrences !count; + (Locusops.current_occurrence !count, t') let string_of_evaluable_ref env = function | EvalVarRef id -> Id.to_string id @@ -1154,23 +1146,14 @@ let unfold env sigma name c = * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = - let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in - if Int.equal nbocc 1 then + match occs with + | NoOccurrences -> c + | AllOccurrences -> unfold env sigma name c + | OnlyOccurrences _ | AllOccurrencesBut _ | AtLeastOneOccurrence -> + let (occ,uc) = substlin env sigma name occs c in + if Int.equal occ 0 then user_err Pp.(str ((string_of_evaluable_ref env name)^" does not occur.")); - let rest = List.filter (fun o -> o >= nbocc) locs in - let () = match rest with - | [] -> () - | _ -> error_invalid_occurrence rest - in nf_betaiotazeta env sigma uc - in - match occs with - | NoOccurrences -> c - | AllOccurrences -> unfold env sigma name c - | OnlyOccurrences l -> unfo true l - | AllOccurrencesBut l -> unfo false l - | AtLeastOneOccurrence -> unfo false [] (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = diff --git a/pretyping/typing.ml b/pretyping/typing.ml index aeb3873de7..e3e5244a8c 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -33,7 +33,7 @@ let meta_type env evd mv = let ty = try Evd.meta_ftype evd mv with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in - meta_instance env evd ty + meta_instance env (create_meta_instance_subst evd) ty let inductive_type_knowing_parameters env sigma (ind,u) jl = let u = Unsafe.to_instance u in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c352a6ac1f..3d3010d1a4 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1070,10 +1070,8 @@ 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 - let f1l1 = whd_nored_state curenv sigma (cM,Stack.empty) in - if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state curenv sigma (cN,Stack.empty) in - solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn + if 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) in @@ -1086,14 +1084,14 @@ 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 - let f2l2 = whd_nored_state curenv sigma (cN, Stack.empty) in - if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state curenv sigma (cM, Stack.empty) in - solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn + if 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) - and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) = + 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)) = try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1944,7 +1942,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = try (* First try finding a subterm w/o conversion on open terms *) let flags = set_no_delta_open_flags flags in w_unify_to_subterm env evd ~flags t' - with e -> + with e when CErrors.noncritical e -> (* If this fails, try with full conversion *) w_unify_to_subterm env evd ~flags t' else w_unify_to_subterm env evd ~flags t' diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8942bc7805..4c410c3170 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -152,14 +152,15 @@ let tag_var = tag Tag.variable let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) - let pr_glob_sort_name = function - | GSProp -> str "SProp" - | GProp -> str "Prop" - | GSet -> str "Set" - | GType qid -> pr_qualid qid + let pr_sort_name_expr = function + | CSProp -> str "SProp" + | CProp -> str "Prop" + | CSet -> str "Set" + | CType qid -> pr_qualid qid + | CRawType s -> Univ.Level.pr s let pr_univ_expr (u,n) = - pr_glob_sort_name u ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) + pr_sort_name_expr u ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) let pr_univ l = match l with @@ -168,21 +169,22 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" - let pr_glob_sort = let open Glob_term in function - | UNamed [GSProp,0] -> tag_type (str "SProp") - | UNamed [GProp,0] -> tag_type (str "Prop") - | UNamed [GSet,0] -> tag_type (str "Set") + let pr_sort_expr = function + | UNamed [CSProp,0] -> tag_type (str "SProp") + | UNamed [CProp,0] -> tag_type (str "Prop") + | UNamed [CSet,0] -> tag_type (str "Set") | UAnonymous {rigid=true} -> tag_type (str "Type") | UAnonymous {rigid=false} -> tag_type (str "Type") ++ pr_univ_annot (fun _ -> str "_") () | UNamed u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) - let pr_glob_level = let open Glob_term in function - | UNamed GSProp -> tag_type (str "SProp") - | UNamed GProp -> tag_type (str "Prop") - | UNamed GSet -> tag_type (str "Set") + let pr_univ_level_expr = function + | UNamed CSProp -> tag_type (str "SProp") + | UNamed CProp -> tag_type (str "Prop") + | UNamed CSet -> tag_type (str "Set") | UAnonymous {rigid=true} -> tag_type (str "Type") | UAnonymous {rigid=false} -> tag_type (str "_") - | UNamed (GType u) -> tag_type (pr_qualid u) + | UNamed (CType u) -> tag_type (pr_qualid u) + | UNamed (CRawType s) -> tag_type (Univ.Level.pr s) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -200,7 +202,7 @@ let tag_var = tag Tag.variable let pr_patvar = pr_id let pr_universe_instance l = - pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_level)) l + pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_univ_level_expr)) l let pr_reference qid = if qualid_is_ident qid then tag_var (pr_id @@ qualid_basename qid) @@ -664,7 +666,7 @@ let tag_var = tag Tag.variable | CPatVar p -> return (str "@?" ++ pr_patvar p, latom) | CSort s -> - return (pr_glob_sort s, latom) + return (pr_sort_expr s, latom) | CCast (a,b) -> return ( hv 0 (pr mt (LevelLt lcast) a ++ spc () ++ @@ -717,7 +719,7 @@ let tag_var = tag Tag.variable let transf env sigma c = if !Flags.beautify_file then let r = Constrintern.for_grammar (Constrintern.intern_constr env sigma) c in - Constrextern.extern_glob_constr (Termops.vars_of_env env) r + Constrextern.(extern_glob_constr (extern_env env sigma)) r else c let pr_expr env sigma prec c = diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 02e04573f8..d66b77efb2 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -32,9 +32,9 @@ val pr_id : Id.t -> Pp.t val pr_qualid : qualid -> Pp.t val pr_patvar : Pattern.patvar -> Pp.t -val pr_glob_sort_name : Glob_term.glob_sort_name -> Pp.t -val pr_glob_level : Glob_term.glob_level -> Pp.t -val pr_glob_sort : Glob_term.glob_sort -> Pp.t +val pr_sort_name_expr : sort_name_expr -> Pp.t +val pr_univ_level_expr : univ_level_expr -> Pp.t +val pr_sort_expr : sort_expr -> Pp.t val pr_guard_annot : (constr_expr -> Pp.t) -> local_binder_expr list diff --git a/printing/printer.ml b/printing/printer.ml index ea718526de..1425cebafc 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -97,10 +97,10 @@ let pr_ltype_env ?lax ?goal_concl_style env sigma ?impargs c = let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) -let pr_lglob_constr_env env c = - pr_lconstr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) -let pr_glob_constr_env env c = - pr_constr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) +let pr_lglob_constr_env env sigma c = + pr_lconstr_expr env sigma (extern_glob_constr (extern_env env sigma) c) +let pr_glob_constr_env env sigma c = + pr_constr_expr env sigma (extern_glob_constr (extern_env env sigma) c) let pr_closed_glob_n_env ?lax ?goal_concl_style ?inctx ?scope env sigma n c = pr_constr_expr_n env sigma n (extern_closed_glob ?lax ?goal_concl_style ?inctx ?scope env sigma c) @@ -115,7 +115,7 @@ let pr_constr_pattern_env env sigma c = let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) -let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) +let pr_sort sigma s = pr_sort_expr (extern_sort sigma s) let () = Termops.Internal.set_print_constr (fun env sigma t -> pr_lconstr_expr env sigma (extern_constr ~lax:true env sigma t)) diff --git a/printing/printer.mli b/printing/printer.mli index ea388ae57e..732af5570d 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -107,9 +107,9 @@ val pr_closed_glob_env : ?lax:bool -> ?goal_concl_style:bool -> ?inctx:bool val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t -val pr_lglob_constr_env : env -> 'a glob_constr_g -> Pp.t +val pr_lglob_constr_env : env -> evar_map -> 'a glob_constr_g -> Pp.t -val pr_glob_constr_env : env -> 'a glob_constr_g -> Pp.t +val pr_glob_constr_env : env -> evar_map -> 'a glob_constr_g -> Pp.t val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 387f0f6f5f..00ac5a0624 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -37,15 +37,28 @@ type clausenv = { env : env; evd : evar_map; templval : constr freelisted; - templtyp : constr freelisted } + templtyp : constr freelisted; + cache : Reductionops.meta_instance_subst; +} + +let mk_clausenv env evd templval templtyp = { + env; evd; templval; templtyp; cache = create_meta_instance_subst evd; +} + +let update_clenv_evd clenv evd = + mk_clausenv clenv.env evd clenv.templval clenv.templtyp let cl_env ce = ce.env let cl_sigma ce = ce.evd -let clenv_term clenv c = meta_instance clenv.env clenv.evd c -let clenv_meta_type clenv mv = Typing.meta_type clenv.env clenv.evd mv -let clenv_value clenv = meta_instance clenv.env clenv.evd clenv.templval -let clenv_type clenv = meta_instance clenv.env clenv.evd clenv.templtyp +let clenv_term clenv c = meta_instance clenv.env clenv.cache c +let clenv_meta_type clenv mv = + let ty = + try Evd.meta_ftype clenv.evd mv + with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in + meta_instance clenv.env clenv.cache ty +let clenv_value clenv = meta_instance clenv.env clenv.cache clenv.templval +let clenv_type clenv = meta_instance clenv.env clenv.cache clenv.templtyp let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -67,7 +80,8 @@ let clenv_push_prod cl = { templval = mk_freelisted def; templtyp = mk_freelisted concl; evd = e'; - env = cl.env } + env = cl.env; + cache = create_meta_instance_subst e' } | _ -> raise NotExtensibleClause in clrec typ @@ -109,7 +123,8 @@ let mk_clenv_from_env env sigma n (c,cty) = { templval = mk_freelisted (applist (c,args)); templtyp = mk_freelisted concl; evd = evd; - env = env } + env = env; + cache = create_meta_instance_subst evd } let mk_clenv_from_n gls n (c,cty) = let env = Proofview.Goal.env gls in @@ -158,7 +173,7 @@ let clenv_assign mv rhs clenv = clenv else let st = (Conv,TypeNotProcessed) in - {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} + update_clenv_evd clenv (meta_assign mv (rhs_fls.rebus,st) clenv.evd) with Not_found -> user_err Pp.(str "clenv_assign: undefined meta") @@ -202,19 +217,19 @@ let clenv_assign mv rhs clenv = In any case, we respect the order given in A. *) -let clenv_metas_in_type_of_meta env evd mv = - (mk_freelisted (meta_instance env evd (meta_ftype evd mv))).freemetas +let clenv_metas_in_type_of_meta clenv mv = + (mk_freelisted (meta_instance clenv.env clenv.cache (meta_ftype clenv.evd mv))).freemetas let dependent_in_type_of_metas clenv mvs = List.fold_right - (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.env clenv.evd mv)) + (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv mv)) mvs Metaset.empty let dependent_closure clenv mvs = let rec aux mvs acc = Metaset.fold (fun mv deps -> - let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.env clenv.evd mv in + let metas_of_meta_type = clenv_metas_in_type_of_meta clenv mv in aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) mvs acc in aux mvs mvs @@ -297,11 +312,10 @@ let meta_reducible_instance env evd b = else irec b.rebus let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = - { clenv with - evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } + update_clenv_evd clenv (w_unify ~flags clenv.env clenv.evd cv_pb t1 t2) let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv = - { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } + update_clenv_evd clenv (w_unify_meta_types ~flags:flags clenv.env clenv.evd) let clenv_unique_resolver_gen ?(flags=default_unify_flags ()) clenv concl = if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.env clenv.evd clenv.templtyp.rebus))) then @@ -414,11 +428,13 @@ let fchain_flags () = let clenv_fchain ?with_univs ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) + let evd = meta_merge ?with_univs nextclenv.evd clenv.evd in let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = meta_merge ?with_univs nextclenv.evd clenv.evd; - env = nextclenv.env } in + evd; + env = nextclenv.env; + cache = create_meta_instance_subst evd } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = clenv_unify ~flags CUMUL @@ -538,7 +554,7 @@ let clenv_assign_binding clenv k c = let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in let c_typ = nf_betaiota clenv.env clenv.evd (clenv_get_type_of clenv c) in let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in - { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd } + update_clenv_evd clenv' (meta_assign k (c,(Conv,status)) clenv'.evd) let clenv_match_args bl clenv = if List.is_empty bl then @@ -640,7 +656,7 @@ let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = Typeclasses.make_unresolvables (fun x -> true) evd' else clenv.evd in - let clenv = { clenv with evd = evd' } in + let clenv = update_clenv_evd clenv evd' in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS (Evd.clear_metas evd')) (refiner ~check:false EConstr.Unsafe.(to_constr (clenv_cast_meta clenv (clenv_value clenv)))) diff --git a/proofs/clenv.mli b/proofs/clenv.mli index a72c8c5e1f..6e472da452 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -22,14 +22,18 @@ open Tactypes (** {6 The Type of Constructions clausale environments.} *) -type clausenv = { +type clausenv = private { env : env; (** the typing context *) evd : evar_map; (** the mapping from metavar and evar numbers to their types and values *) templval : constr freelisted; (** the template which we are trying to fill out *) - templtyp : constr freelisted (** its type *)} + templtyp : constr freelisted; (** its type *) + cache : Reductionops.meta_instance_subst; (* Reductionops.create_meta_instance_subst evd) *) +} +val mk_clausenv : env -> evar_map -> constr freelisted -> types freelisted -> clausenv +val update_clenv_evd : clausenv -> evar_map -> clausenv (** subject of clenv (instantiated) *) val clenv_value : clausenv -> constr diff --git a/proofs/proof.ml b/proofs/proof.ml index 24f3ac3f29..50a0e63700 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -115,6 +115,7 @@ type t = (** the name of the theorem whose proof is being constructed *) ; poly : bool (** polymorphism *) + ; typing_flags : Declarations.typing_flags option } (*** General proof functions ***) @@ -278,7 +279,7 @@ let end_of_stack = CondEndStack end_of_stack_kind let unfocused = is_last_focus end_of_stack_kind -let start ~name ~poly sigma goals = +let start ~name ~poly ?typing_flags sigma goals = let entry, proofview = Proofview.init sigma goals in let pr = { proofview @@ -286,10 +287,11 @@ let start ~name ~poly sigma goals = ; focus_stack = [] ; name ; poly + ; typing_flags } in _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr -let dependent_start ~name ~poly goals = +let dependent_start ~name ~poly ?typing_flags goals = let entry, proofview = Proofview.dependent_init goals in let pr = { proofview @@ -297,6 +299,7 @@ let dependent_start ~name ~poly goals = ; focus_stack = [] ; name ; poly + ; typing_flags } in let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr @@ -560,6 +563,7 @@ let solve ?with_end_tac gi info_lvl tac pr = else tac in let env = Global.env () in + let env = Environ.update_typing_flags ?typing_flags:pr.typing_flags env in let (p,(status,info),()) = run_tactic env tac pr in let env = Global.env () in let sigma = Evd.from_env env in diff --git a/proofs/proof.mli b/proofs/proof.mli index f487595dac..a527820c7a 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -55,11 +55,13 @@ val data : t -> data val start : name:Names.Id.t -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> Evd.evar_map -> (Environ.env * EConstr.types) list -> t val dependent_start : name:Names.Id.t -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> Proofview.telescope -> t (* Returns [true] if the considered proof is completed, that is if no goal remain diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 4f04b9fe1c..4c4c26f47e 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -125,7 +125,7 @@ module Make(T : Task) () = struct "-async-proofs-worker-priority"; CoqworkmgrApi.(string_of_priority priority)] (* Options to discard: 0 arguments *) - | "-emacs"::tl -> + | ("-emacs" | "--xml_format=Ppcmds" | "-batch") :: tl -> set_slave_opt tl (* Options to discard: 1 argument *) | ( "-async-proofs" | "-vio2vo" | "-o" diff --git a/stm/stm.ml b/stm/stm.ml index f7d66b7b53..1c06c1efb7 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2681,8 +2681,10 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtStartProof (guarantee, names) -> if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then - "Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on." - |> Pp.str + "Nested proofs are discouraged and not allowed by default. \ + This error probably means that you forgot to close the last \"Proof.\" with \"Qed.\" or \"Defined.\". \ + If you really intended to use nested proofs, you can do so by turning the \"Nested Proofs Allowed\" flag on." + |> Pp.strbrk |> (fun s -> (UserError (None, s), Exninfo.null)) |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise diff --git a/tactics/declareUctx.ml b/tactics/declareUctx.ml index 3f67ff20a4..6c8bc92865 100644 --- a/tactics/declareUctx.ml +++ b/tactics/declareUctx.ml @@ -16,7 +16,7 @@ let name_instance inst = assert false | Some na -> try - let qid = Nametab.shortest_qualid_of_universe na in + let qid = Nametab.shortest_qualid_of_universe Names.Id.Map.empty na in Names.Name (Libnames.qualid_basename qid) with Not_found -> (* Best-effort naming from the string representation of the level. diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index d4cc193eb3..9b3f9053cd 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -123,8 +123,8 @@ let idy = Id.of_string "y" let mkGenDecideEqGoal rectype ops g = let hypnames = pf_ids_set_of_hyps g in - let xname = next_ident_away idx hypnames - and yname = next_ident_away idy hypnames in + let xname = next_ident_away idx hypnames in + let yname = next_ident_away idy (Id.Set.add xname hypnames) in (mkNamedProd (make_annot xname Sorts.Relevant) rectype (mkNamedProd (make_annot yname Sorts.Relevant) rectype (mkDecideEqGoal true ops diff --git a/tactics/equality.ml b/tactics/equality.ml index 486575d229..633b9da053 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -154,7 +154,8 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let c1 = args.(arglen - 2) in let c2 = args.(arglen - 1) in let try_occ (evd', c') = - Clenv.clenv_pose_dependent_evars ~with_evars:true {eqclause with evd = evd'} + let clenv = Clenv.update_clenv_evd eqclause evd' in + Clenv.clenv_pose_dependent_evars ~with_evars:true clenv in let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = @@ -1655,6 +1656,17 @@ let cutSubstClause l2r eqn cls = | None -> cutSubstInConcl l2r eqn | Some id -> cutSubstInHyp l2r eqn id +let warn_deprecated_cutrewrite = + CWarnings.create ~name:"deprecated-cutrewrite" ~category:"deprecated" + (fun () -> strbrk"\"cutrewrite\" is deprecated. Use \"replace\" instead.") + +let cutRewriteClause l2r eqn cls = + warn_deprecated_cutrewrite (); + try_rewrite (cutSubstClause l2r eqn cls) + +let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) +let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None + let substClause l2r c cls = Proofview.Goal.enter begin fun gl -> let eq = pf_apply get_type_of gl c in diff --git a/tactics/equality.mli b/tactics/equality.mli index 5a4fe47cab..fdcbbc0e3c 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -107,6 +107,10 @@ val dEqThen : keep_proofs:(bool option) -> evars_flag -> (clear_flag -> constr - val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) +(* The family cutRewriteIn expect an equality statement *) +val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic +val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic + (* The family rewriteIn expect the proof of an equality *) val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic val rewriteInConcl : bool -> constr -> unit Proofview.tactic diff --git a/tactics/genredexpr.ml b/tactics/genredexpr.ml index 1f6b04c1d3..9939490e79 100644 --- a/tactics/genredexpr.ml +++ b/tactics/genredexpr.ml @@ -35,13 +35,13 @@ type 'a glob_red_flag = { (** Generic kinds of reductions *) -type ('a,'b,'c) red_expr_gen = +type ('a, 'b, 'c, 'flags) red_expr_gen0 = | Red of bool | Hnf - | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option - | Cbv of 'b glob_red_flag - | Cbn of 'b glob_red_flag - | Lazy of 'b glob_red_flag + | Simpl of 'flags * ('b, 'c) Util.union Locus.with_occurrences option + | Cbv of 'flags + | Cbn of 'flags + | Lazy of 'flags | Unfold of 'b Locus.with_occurrences list | Fold of 'a list | Pattern of 'a Locus.with_occurrences list @@ -49,6 +49,9 @@ type ('a,'b,'c) red_expr_gen = | CbvVm of ('b,'c) Util.union Locus.with_occurrences option | CbvNative of ('b,'c) Util.union Locus.with_occurrences option +type ('a, 'b, 'c) red_expr_gen = + ('a, 'b, 'c, 'b glob_red_flag) red_expr_gen0 + type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a diff --git a/tactics/hints.ml b/tactics/hints.ml index 6fab111e6f..ace51c40d4 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -340,10 +340,8 @@ let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = merge_context_set_opt sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in - let cl = {cl with templval = - { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; - env = empty_env} - in + let templval = { cl.templval with rebus = strip_params env sigma cl.templval.rebus } in + let cl = mk_clausenv empty_env cl.evd templval cl.templtyp in { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; } in let code = match p.code.obj with @@ -1649,14 +1647,17 @@ let connect_hint_clenv h gl = let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (* Only metas are mentioning the old universes. *) - { - templval = Evd.map_fl emap clenv.templval; - templtyp = Evd.map_fl emap clenv.templtyp; - evd = Evd.map_metas emap evd; - env = Proofview.Goal.env gl; - } + Clenv.mk_clausenv + (Proofview.Goal.env gl) + (Evd.map_metas emap evd) + (Evd.map_fl emap clenv.templval) + (Evd.map_fl emap clenv.templtyp) | None -> - { clenv with evd = evd ; env = Proofview.Goal.env gl } + Clenv.mk_clausenv + (Proofview.Goal.env gl) + evd + clenv.templval + clenv.templtyp let fresh_hint env sigma h = let { hint_term = c; hint_uctx = ctx } = h in diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index a8747e0a7c..9c2df71f82 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -129,6 +129,9 @@ let set_strategy local str = type red_expr = (constr, evaluable_global_reference, constr_pattern) red_expr_gen +type red_expr_val = + (constr, evaluable_global_reference, constr_pattern, CClosure.RedFlags.reds) red_expr_gen0 + let make_flag_constant = function | EvalVarRef id -> fVAR id | EvalConstRef sp -> fCONST sp @@ -221,38 +224,117 @@ let warn_simpl_unfolding_modifiers = (fun () -> Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.") -let reduction_of_red_expr env = - let make_flag = make_flag env in - let rec reduction_of_red_expr = function +let rec eval_red_expr env = function +| Simpl (f, o) -> + let () = + if not (simplIsCbn () || List.is_empty f.rConst) then + warn_simpl_unfolding_modifiers () in + let f = if simplIsCbn () then make_flag env f else CClosure.all (* dummy *) in + Simpl (f, o) +| Cbv f -> Cbv (make_flag env f) +| Cbn f -> Cbn (make_flag env f) +| Lazy f -> Lazy (make_flag env f) +| ExtraRedExpr s -> + begin match String.Map.find s !red_expr_tab with + | e -> eval_red_expr env e + | exception Not_found -> ExtraRedExpr s (* delay to runtime interpretation *) + end +| (Red _ | Hnf | Unfold _ | Fold _ | Pattern _ | CbvVm _ | CbvNative _) as e -> e + +let reduction_of_red_expr_val = function | Red internal -> if internal then (e_red try_red_product,DEFAULTcast) else (e_red red_product,DEFAULTcast) | Hnf -> (e_red hnf_constr,DEFAULTcast) | Simpl (f,o) -> - let whd_am = if simplIsCbn () then whd_cbn (make_flag f) else whd_simpl in - let am = if simplIsCbn () then strong_cbn (make_flag f) else simpl in - let () = - if not (simplIsCbn () || List.is_empty f.rConst) then - warn_simpl_unfolding_modifiers () in + let whd_am = if simplIsCbn () then whd_cbn f else whd_simpl in + let am = if simplIsCbn () then strong_cbn f else simpl in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) - | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) + | Cbv f -> (e_red (cbv_norm_flags f),DEFAULTcast) | Cbn f -> - (e_red (strong_cbn (make_flag f)), DEFAULTcast) - | Lazy f -> (e_red (clos_norm_flags (make_flag f)),DEFAULTcast) + (e_red (strong_cbn f), DEFAULTcast) + | Lazy f -> (e_red (clos_norm_flags f),DEFAULTcast) | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast) | Fold cl -> (e_red (fold_commands cl),DEFAULTcast) | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast) | ExtraRedExpr s -> (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast) with Not_found -> - (try reduction_of_red_expr (String.Map.find s !red_expr_tab) - with Not_found -> user_err ~hdr:"Redexpr.reduction_of_red_expr" - (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) + (str "unknown user-defined reduction \"" ++ str s ++ str "\"")) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) + +let reduction_of_red_expr env r = + reduction_of_red_expr_val (eval_red_expr env r) + +(* Possibly equip a reduction with the occurrences mentioned in an + occurrence clause *) + +let error_illegal_clause () = + CErrors.user_err Pp.(str "\"at\" clause not supported in presence of an occurrence clause.") + +let error_illegal_non_atomic_clause () = + CErrors.user_err Pp.(str "\"at\" clause not supported in presence of a non atomic \"in\" clause.") + +let error_occurrences_not_unsupported () = + CErrors.user_err Pp.(str "Occurrences not supported for this reduction tactic.") + +let bind_red_expr_occurrences occs nbcl redexp = + let open Locus in + let has_at_clause = function + | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Simpl (_,Some (occl,_)) -> occl != AllOccurrences + | _ -> false in + if occs == AllOccurrences then + if nbcl > 1 && has_at_clause redexp then + error_illegal_non_atomic_clause () + else + redexp + else + match redexp with + | Unfold (_::_::_) -> + error_illegal_clause () + | Unfold [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Unfold [(occs,c)] + | Pattern (_::_::_) -> + error_illegal_clause () + | Pattern [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Pattern [(occs,c)] + | Simpl (f,Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + Simpl (f,Some (occs,c)) + | CbvVm (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvVm (Some (occs,c)) + | CbvNative (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvNative (Some (occs,c)) + | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ + | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> + error_occurrences_not_unsupported () + | Unfold [] | Pattern [] -> + assert false + +let reduction_of_red_expr_val ?occs r = + let r = match occs with + | None -> r + | Some (occs, nbcl) -> bind_red_expr_occurrences occs nbcl r in - reduction_of_red_expr + reduction_of_red_expr_val r let subst_mps subst c = EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) diff --git a/tactics/redexpr.mli b/tactics/redexpr.mli index d43785218f..5f3a7b689b 100644 --- a/tactics/redexpr.mli +++ b/tactics/redexpr.mli @@ -19,10 +19,18 @@ open Reductionops open Locus type red_expr = - (constr, evaluable_global_reference, constr_pattern) red_expr_gen + (constr, evaluable_global_reference, constr_pattern) red_expr_gen + +type red_expr_val val out_with_occurrences : 'a with_occurrences -> occurrences * 'a +val eval_red_expr : Environ.env -> red_expr -> red_expr_val + +val reduction_of_red_expr_val : ?occs:(Locus.occurrences_expr * int) -> + red_expr_val -> e_reduction_function * cast_kind + +(** Composition of {!reduction_of_red_expr_val} with {!eval_red_expr} *) val reduction_of_red_expr : Environ.env -> red_expr -> e_reduction_function * cast_kind diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 24aa178ed2..68afd9a128 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -727,6 +727,32 @@ module New = struct let (loc,_) = evi.Evd.evar_source in Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None + let tclMAPDELAYEDWITHHOLES accept_unresolved_holes l tac = + let rec aux = function + | [] -> tclUNIT () + | x :: l -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma_initial = Proofview.Goal.sigma gl in + let (sigma, x) = x env sigma_initial in + Proofview.Unsafe.tclEVARS sigma <*> tac x >>= fun () -> aux l >>= fun () -> + if accept_unresolved_holes then + tclUNIT () + else + tclEVARMAP >>= fun sigma_final -> + try + let () = check_evars env sigma_final sigma sigma_initial in + tclUNIT () + with e when CErrors.noncritical e -> + let e, info = Exninfo.capture e in + tclZERO ~info e + end in + aux l + + (* The following is basically + tclMAPDELAYEDWITHHOLES accept_unresolved_holes [fun _ _ -> (sigma,())] (fun () -> tac) + but with value not necessarily in unit *) + let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> if sigma == sigma_initial then tac diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index e97c5f3c1f..19d08dcc36 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -209,6 +209,10 @@ module New : sig 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 + (* in [tclMAPDELAYEDWITHHOLES with_evars l tac] the delayed + argument of [l] are evaluated in the possibly-updated + environment and updated sigma of each new successive goals *) val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e3369bc9be..39c5c9562f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -85,24 +85,6 @@ let () = optread = (fun () -> !universal_lemma_under_conjunctions) ; optwrite = (fun b -> universal_lemma_under_conjunctions := b) } -(* The following boolean governs what "intros []" do on examples such - as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; - if false, it behaves as "intro H; case H; clear H" for fresh H. - Kept as false for compatibility. - *) - -let bracketing_last_or_and_intro_pattern = ref true - -let use_bracketing_last_or_and_intro_pattern () = - !bracketing_last_or_and_intro_pattern - -let () = - declare_bool_option - { optdepr = true; - optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; - optread = (fun () -> !bracketing_last_or_and_intro_pattern); - optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } - (*********************************************) (* Tactics *) (*********************************************) @@ -634,70 +616,10 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where env sigma dec in (sigma, LocalDef (id,b',ty')) -(* Possibly equip a reduction with the occurrences mentioned in an - occurrence clause *) - -let error_illegal_clause () = - error "\"at\" clause not supported in presence of an occurrence clause." - -let error_illegal_non_atomic_clause () = - error "\"at\" clause not supported in presence of a non atomic \"in\" clause." - -let error_occurrences_not_unsupported () = - error "Occurrences not supported for this reduction tactic." - let bind_change_occurrences occs = function | None -> None | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) -let bind_red_expr_occurrences occs nbcl redexp = - let has_at_clause = function - | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l - | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l - | Simpl (_,Some (occl,_)) -> occl != AllOccurrences - | _ -> false in - if occs == AllOccurrences then - if nbcl > 1 && has_at_clause redexp then - error_illegal_non_atomic_clause () - else - redexp - else - match redexp with - | Unfold (_::_::_) -> - error_illegal_clause () - | Unfold [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Unfold [(occs,c)] - | Pattern (_::_::_) -> - error_illegal_clause () - | Pattern [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Pattern [(occs,c)] - | Simpl (f,Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - Simpl (f,Some (occs,c)) - | CbvVm (Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - CbvVm (Some (occs,c)) - | CbvNative (Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - CbvNative (Some (occs,c)) - | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ - | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> - error_occurrences_not_unsupported () - | Unfold [] | Pattern [] -> - assert false - (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a certain hypothesis *) @@ -959,17 +881,16 @@ let reduce redexp cl = | Red _ | Hnf | CbvVm _ | CbvNative _ -> StableHypConv | ExtraRedExpr _ -> StableHypConv (* Should we be that lenient ?*) in + let redexp = Redexpr.eval_red_expr env redexp in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> - let redexp = bind_red_expr_occurrences occs nbcl redexp in - let redfun = Redexpr.reduction_of_red_expr env redexp in + let redfun = Redexpr.reduction_of_red_expr_val ~occs:(occs, nbcl) redexp in e_change_in_concl ~check (revert_cast redfun) end <*> let f (id, occs, where) = - let redexp = bind_red_expr_occurrences occs nbcl redexp in - let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr_val ~occs:(occs, nbcl) redexp in let redfun _ env sigma c = redfun env sigma c in let redfun env sigma d = e_pf_change_decl redfun where env sigma d in (id, redfun) @@ -1083,10 +1004,10 @@ let intros_using_then l tac = intros_using_then_helper tac [] l let intros = Tacticals.New.tclREPEAT intro -let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = +let intro_forthcoming_then_gen name_flag move_flag dep_flag bound n tac = let rec aux n ids = (* Note: we always use the bound when there is one for "*" and "**" *) - if (match bound with None -> true | Some (_,p) -> n < p) then + if (match bound with None -> true | Some p -> n < p) then Proofview.tclORELSE begin intro_then_gen name_flag move_flag false dep_flag @@ -1380,20 +1301,18 @@ let do_replace id = function let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = let clenv = Clenv.clenv_pose_dependent_evars ~with_evars clenv in - let clenv = - { clenv with evd = Typeclasses.resolve_typeclasses - ~fail:(not with_evars) clenv.env clenv.evd } - in + let evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd in + let clenv = Clenv.update_clenv_evd clenv evd in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; - if not with_evars && occur_meta clenv.evd new_hyp_typ then + if not with_evars && occur_meta evd new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Logic.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf) in let naming = NamingMustBe (CAst.make targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) + (Proofview.Unsafe.tclEVARS (clear_metas evd)) (Tacticals.New.tclTHENLAST (assert_after_then_gen ?err with_clear naming new_hyp_typ tac) exact_tac) @@ -2282,10 +2201,9 @@ let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 let split_with_bindings with_evars l = Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l -let split_with_delayed_bindings with_evars = - Tacticals.New.tclMAP (fun bl -> - Tacticals.New.tclDELAYEDWITHHOLES with_evars bl - (constructor_tac with_evars (Some 1) 1)) +let split_with_delayed_bindings with_evars bl = + Tacticals.New.tclMAPDELAYEDWITHHOLES with_evars bl + (constructor_tac with_evars (Some 1) 1) let left = left_with_bindings false let simplest_left = left NoBindings @@ -2307,7 +2225,7 @@ let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make () let (forward_subst_one, subst_one) = Hook.make () let error_unexpected_extra_pattern loc bound pat = - let _,nb = Option.get bound in + let nb = Option.get bound in let s1,s2,s3 = match pat with | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" @@ -2340,14 +2258,14 @@ let intro_decomp_eq ?loc l thin tac id = match my_find_eq_data_decompose env sigma t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function - (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) + (fun n -> tac ((CAst.make id)::thin) (Some n) l) (eq,t,eq_args) (c, t) | None -> let info = Exninfo.reify () in Tacticals.New.tclZEROMSG ~info (str "Not a primitive equality here.") end -let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = +let intro_or_and_pattern ?loc with_evars ll thin tac id = Proofview.Goal.enter begin fun gl -> let c = mkVar id in let env = Proofview.Goal.env gl in @@ -2361,11 +2279,11 @@ let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) - (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) + (Array.map2 (fun n l -> tac thin (Some n) l) nv_with_let ll)) end -let rewrite_hyp_then assert_style with_evars thin l2r id tac = +let rewrite_hyp_then with_evars thin l2r id tac = let rew_on l2r = Hook.get forward_general_rewrite_clause l2r with_evars (mkVar id,NoBindings) in let subst_on l2r x rhs = @@ -2477,11 +2395,11 @@ let make_tmp_naming avoid l = function let fit_bound n = function | None -> true - | Some (use_bound,n') -> not use_bound || n = n' + | Some n' -> n = n' let exceed_bound n = function | None -> false - | Some (use_bound,n') -> use_bound && n >= n' + | Some n' -> n >= n' (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right @@ -2502,60 +2420,59 @@ let exceed_bound n = function [patl]: introduction patterns to interpret *) -let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = +let rec intro_patterns_core with_evars avoid ids thin destopt bound n tac = function | [] when fit_bound n bound -> tac ids thin | [] -> (* Behave as IntroAnonymous *) - intro_patterns_core with_evars b avoid ids thin destopt bound n tac + intro_patterns_core with_evars avoid ids thin destopt bound n tac [CAst.make @@ IntroNaming IntroAnonymous] | {CAst.loc;v=pat} :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with | IntroForthcoming onlydeps -> intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt onlydeps n bound - (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound + destopt onlydeps bound n + (fun ids -> intro_patterns_core with_evars avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) destopt true false - (intro_pattern_action ?loc with_evars (b || not (List.is_empty l)) false - pat thin destopt - (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 + (intro_pattern_action ?loc with_evars pat thin destopt + (fun thin bound' -> intro_patterns_core with_evars avoid ids thin destopt bound' 0 (fun ids thin -> - intro_patterns_core with_evars b avoid ids thin destopt bound (n+1) tac l))) + intro_patterns_core with_evars avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> - intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound (n+1) tac l + intro_pattern_naming loc with_evars avoid ids pat thin destopt bound (n+1) tac l (* Pi-introduction rule, used backwards *) -and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac l = +and intro_pattern_naming loc with_evars avoid ids pat thin destopt bound n tac l = match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen (NamingMustBe CAst.(make ?loc id)) destopt true false - (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) + (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) destopt true false - (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) + (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l))) destopt true false - (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) + (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) -and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = +and intro_pattern_action ?loc with_evars pat thin destopt tac id = match pat with | IntroWildcard -> tac (CAst.(make ?loc id)::thin) None [] | IntroOrAndPattern ll -> - intro_or_and_pattern ?loc with_evars b ll thin tac id + intro_or_and_pattern ?loc with_evars ll thin tac id | IntroInjection l' -> intro_decomp_eq ?loc l' thin tac id | IntroRewrite l2r -> - rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) + rewrite_hyp_then with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn ({CAst.loc=loc';v=f},{CAst.loc;v=pat}) -> let naming,tac_ipat = prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in @@ -2576,28 +2493,26 @@ and prepare_intros ?loc with_evars dft destopt = function | IntroAction ipat -> prepare_naming ?loc dft, (let tac thin bound = - intro_patterns_core with_evars true Id.Set.empty [] thin destopt bound 0 + intro_patterns_core with_evars Id.Set.empty [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in fun id -> - intro_pattern_action ?loc with_evars true true ipat [] destopt tac id) + intro_pattern_action ?loc with_evars ipat [] destopt tac id) | IntroForthcoming _ -> user_err ?loc (str "Introduction pattern for one hypothesis expected.") -let intro_patterns_head_core with_evars b destopt bound pat = +let intro_patterns_head_core with_evars destopt bound pat = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in check_name_unicity env [] [] pat; - intro_patterns_core with_evars b Id.Set.empty [] [] destopt + intro_patterns_core with_evars Id.Set.empty [] [] destopt bound 0 (fun _ l -> clear_wildcards l) pat end let intro_patterns_bound_to with_evars n destopt = - intro_patterns_head_core with_evars true destopt - (Some (true,n)) + intro_patterns_head_core with_evars destopt (Some n) let intro_patterns_to with_evars destopt = - intro_patterns_head_core with_evars (use_bracketing_last_or_and_intro_pattern ()) - destopt None + intro_patterns_head_core with_evars destopt None let intro_pattern_to with_evars destopt pat = intro_patterns_to with_evars destopt [CAst.make pat] @@ -2635,7 +2550,7 @@ let assert_as first hd ipat t = (* apply in as *) let general_apply_in ?(respect_opaque=false) with_delta - with_destruct with_evars id lemmas ipat = + with_destruct with_evars id lemmas ipat then_tac = let tac (naming,lemma) tac id = apply_in_delayed_once ~respect_opaque with_delta with_destruct with_evars naming id lemma tac in @@ -2653,7 +2568,8 @@ let general_apply_in ?(respect_opaque=false) with_delta List.map (fun lem -> (NamingMustBe (CAst.make id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) - List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id + List.fold_right tac lemmas_target + (tac last_lemma_target (fun id -> Tacticals.New.tclTHEN (ipat_tac id) then_tac)) id end (* @@ -2666,10 +2582,10 @@ let general_apply_in ?(respect_opaque=false) with_delta let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in - general_apply_in simple simple with_evars id lemmas ipat + general_apply_in simple simple with_evars id lemmas ipat Tacticals.New.tclIDTAC -let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat +let apply_delayed_in simple with_evars id lemmas ipat then_tac = + general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat then_tac (*****************************) (* Tactics abstracting terms *) @@ -3271,7 +3187,7 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = (intros_move newlstatus) let dest_intro_patterns with_evars avoid thin dest pat tac = - intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat + intro_patterns_core with_evars avoid [] thin dest None 0 tac pat let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 54c781af5c..0fd2f1253f 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -233,7 +233,7 @@ val apply_in : val apply_delayed_in : advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> - intro_pattern option -> unit Proofview.tactic + intro_pattern option -> unit Proofview.tactic -> unit Proofview.tactic (** {6 Elimination tactics. } *) diff --git a/test-suite/.csdp.cache.test-suite b/test-suite/.csdp.cache.test-suite Binary files differindex 36efdf469e..5bd4f65546 100644 --- a/test-suite/.csdp.cache.test-suite +++ b/test-suite/.csdp.cache.test-suite diff --git a/test-suite/bugs/closed/bug_13303.v b/test-suite/bugs/closed/bug_13303.v new file mode 100644 index 0000000000..6bee24b48a --- /dev/null +++ b/test-suite/bugs/closed/bug_13303.v @@ -0,0 +1,27 @@ +Module Pt1. + + Module M. Universe i. End M. + Module N. Universe i. End N. + Import M. + Notation foo := Type@{i (* M.i??? *)}. + Import N. + Fail Check foo : Type@{M.i}. (* should NOT succeed *) + Check foo : Type@{i (* N.i *)}. (* should succeed *) + + Definition bar@{i} := Type@{i}. + Check bar : Type@{N.i}. + Check bar : Type@{M.i}. + +End Pt1. + +Module Pt2. + + Module M. Universe i. Notation foo := Type@{i}. End M. + + Definition foo1 := M.foo. + (* should succeed, currently errors undeclared universe i *) + + Definition foo2@{i} : Type@{i} := M.foo. + (* should succeed, currently errors universe inconsistency *) + +End Pt2. diff --git a/test-suite/bugs/closed/bug_13453.v b/test-suite/bugs/closed/bug_13453.v new file mode 100644 index 0000000000..4d0e435df7 --- /dev/null +++ b/test-suite/bugs/closed/bug_13453.v @@ -0,0 +1,6 @@ +Require Extraction. + +Primitive array := #array_type. + +Definition a : array nat := [| 0%nat | 0%nat |]. +Extraction a. diff --git a/test-suite/bugs/closed/bug_13456.v b/test-suite/bugs/closed/bug_13456.v new file mode 100644 index 0000000000..b2e7fa7be5 --- /dev/null +++ b/test-suite/bugs/closed/bug_13456.v @@ -0,0 +1,5 @@ +Lemma minbug (n : nat) (P : nat -> Prop) (pn : P n) : exists (m : nat) (p : P m), True. +Proof. + exists _, pn. + exact I. +Qed. diff --git a/test-suite/bugs/closed/bug_13493.v b/test-suite/bugs/closed/bug_13493.v new file mode 100644 index 0000000000..779df8e7f2 --- /dev/null +++ b/test-suite/bugs/closed/bug_13493.v @@ -0,0 +1,7 @@ +Set Mangle Names. + +Goal forall (m n:nat), True. + intros m n. compare m n. + - constructor. + - constructor. +Qed. diff --git a/test-suite/bugs/closed/bug_13495.v b/test-suite/bugs/closed/bug_13495.v new file mode 100644 index 0000000000..489574b854 --- /dev/null +++ b/test-suite/bugs/closed/bug_13495.v @@ -0,0 +1,18 @@ +Universe u. +(* Constraint Set < u. *) +Polymorphic Cumulative Record pack@{u} := Pack { pack_type : Type@{u} }. +(* u is covariant *) + +Polymorphic Definition pack_id@{u} (p : pack@{u}) : pack@{u} := + match p with + | Pack T => Pack T + end. +Definition packid_nat (p : pack@{Set}) := pack_id@{u} p. +(* No constraints: Set <= u *) + +Definition sr_dont_break := Eval compute in packid_nat. +(* Incorrect elimination of "p" in the inductive type "pack": + ill-formed elimination predicate. + + This is because it tries to enforce Set = u + *) diff --git a/test-suite/bugs/closed/bug_4787.v b/test-suite/bugs/closed/bug_4787.v deleted file mode 100644 index a1444a4f63..0000000000 --- a/test-suite/bugs/closed/bug_4787.v +++ /dev/null @@ -1,7 +0,0 @@ -(* [Unset Bracketing Last Introduction Pattern] was not working *) - -Unset Bracketing Last Introduction Pattern. - -Goal forall T (x y : T * T), fst x = fst y /\ snd x = snd y -> x = y. -do 10 ((intros [] || intro); simpl); reflexivity. -Qed. diff --git a/test-suite/bugs/closed/bug_7967.v b/test-suite/bugs/closed/bug_7967.v index 2c8855fd54..987a820831 100644 --- a/test-suite/bugs/closed/bug_7967.v +++ b/test-suite/bugs/closed/bug_7967.v @@ -1,2 +1,6 @@ Set Universe Polymorphism. Inductive A@{} : Set := B : ltac:(let y := constr:(Type) in exact nat) -> A. + +(* A similar bug *) +Context (C := ltac:(let y := constr:(Type) in exact nat)). +Check C@{}. diff --git a/test-suite/bugs/closed/bug_9517.v b/test-suite/bugs/closed/bug_9517.v index bb43edbe74..93ed94df39 100644 --- a/test-suite/bugs/closed/bug_9517.v +++ b/test-suite/bugs/closed/bug_9517.v @@ -2,6 +2,7 @@ Declare Custom Entry expr. Declare Custom Entry stmt. Notation "x" := x (in custom stmt, x ident). Notation "x" := x (in custom expr, x ident). +Notation "'_'" := _ (in custom expr). Notation "1" := 1 (in custom expr). diff --git a/test-suite/complexity/bug_13227_1.v b/test-suite/complexity/bug_13227_1.v new file mode 100644 index 0000000000..25aae05217 --- /dev/null +++ b/test-suite/complexity/bug_13227_1.v @@ -0,0 +1,28 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall Y r0 r q q0 r1 q1 : Z, + 3 = 4294967296 * q1 + r1 -> + Y - r1 = 4294967296 * q0 + r0 -> + r1 < 4294967296 -> + 0 <= r1 -> + r0 < 4294967296 -> + 0 <= r0 -> + r < 4 -> + 0 <= r -> + 0 < 4 -> + r0 = 4 * q + r -> + Y < 4294967296 -> + 0 <= Y -> + r = 0 -> + r0 < 268517376 -> + 268513280 <= r0 -> + 268587008 <= Y -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_2.v b/test-suite/complexity/bug_13227_2.v new file mode 100644 index 0000000000..25aae05217 --- /dev/null +++ b/test-suite/complexity/bug_13227_2.v @@ -0,0 +1,28 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall Y r0 r q q0 r1 q1 : Z, + 3 = 4294967296 * q1 + r1 -> + Y - r1 = 4294967296 * q0 + r0 -> + r1 < 4294967296 -> + 0 <= r1 -> + r0 < 4294967296 -> + 0 <= r0 -> + r < 4 -> + 0 <= r -> + 0 < 4 -> + r0 = 4 * q + r -> + Y < 4294967296 -> + 0 <= Y -> + r = 0 -> + r0 < 268517376 -> + 268513280 <= r0 -> + 268587008 <= Y -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_3.v b/test-suite/complexity/bug_13227_3.v new file mode 100644 index 0000000000..707e06e174 --- /dev/null +++ b/test-suite/complexity/bug_13227_3.v @@ -0,0 +1,46 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) + (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), + two64 = 2 ^ 64 -> + r3 = 8 * Z.of_nat length_xs -> + r2 = 8 * Z.of_nat length_x -> + 0 <= 8 * Z.of_nat length_x -> + 8 * Z.of_nat length_x < two64 -> + r1 = 2 ^ 4 * q + r -> + 0 < 2 ^ 4 -> + 0 <= r -> + r < 2 ^ 4 -> + x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> + 0 < two64 -> + 0 <= r0 -> + r0 < two64 -> + 8 * Z.of_nat length_x = two64 * q1 + r1 -> + 0 <= r1 -> + r1 < two64 -> + x2 - x1 = two64 * q2 + r2 -> + 0 <= r2 -> + r2 < two64 -> + right - left = two64 * q3 + r3 -> + 0 <= r3 -> + r3 < two64 -> + Z.of_nat length_x = Z.of_nat v -> + 0 <= Z.of_nat length_x -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat v -> + (r2 = 0 -> False) -> + (2 ^ 4 = 0 -> False) -> + (2 ^ 4 < 0 -> False) -> + (two64 = 0 -> False) -> + (two64 < 0 -> False) -> + (r0 < 8 * Z.of_nat length_x -> False) -> + False. +Proof. + intros. + subst. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_4.v b/test-suite/complexity/bug_13227_4.v new file mode 100644 index 0000000000..32cbd4e187 --- /dev/null +++ b/test-suite/complexity/bug_13227_4.v @@ -0,0 +1,45 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) + (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), + two64 = 2 ^ 64 -> + r3 = 8 * Z.of_nat length_xs -> + r2 = 8 * Z.of_nat length_x -> + 0 <= 8 * Z.of_nat length_x -> + 8 * Z.of_nat length_x < two64 -> + r1 = 2 ^ 4 * q + r -> + 0 < 2 ^ 4 -> + 0 <= r -> + r < 2 ^ 4 -> + x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> + 0 < two64 -> + 0 <= r0 -> + r0 < two64 -> + 8 * Z.of_nat length_x = two64 * q1 + r1 -> + 0 <= r1 -> + r1 < two64 -> + x2 - x1 = two64 * q2 + r2 -> + 0 <= r2 -> + r2 < two64 -> + right - left = two64 * q3 + r3 -> + 0 <= r3 -> + r3 < two64 -> + Z.of_nat length_x = Z.of_nat v -> + 0 <= Z.of_nat length_x -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat v -> + (r2 = 0 -> False) -> + (2 ^ 4 = 0 -> False) -> + (2 ^ 4 < 0 -> False) -> + (two64 = 0 -> False) -> + (two64 < 0 -> False) -> + (r0 < 8 * Z.of_nat length_x -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_5.v b/test-suite/complexity/bug_13227_5.v new file mode 100644 index 0000000000..4869c4c6b4 --- /dev/null +++ b/test-suite/complexity/bug_13227_5.v @@ -0,0 +1,79 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +Axiom word: Type. + +(* Expected time < 1.00s *) +Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) (x : list word) + (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 r4 q3 q4 + r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 z83 z84 : Z), + z84 = 0 -> + Z.of_nat (Datatypes.length x) - (z83 + 1) <= 0 -> + z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> + z83 = 0 -> + q0 <= 0 -> + 0 <= Z.of_nat v -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat (Datatypes.length x) -> + Z.of_nat (Datatypes.length x) = Z.of_nat v -> + r14 < 2 ^ 64 -> + 0 <= r14 -> + right - left = 2 ^ 64 * q14 + r14 -> + r13 < 2 ^ 64 -> + 0 <= r13 -> + r10 - x1 = 2 ^ 64 * q13 + r13 -> + r12 < 2 ^ 64 -> + 0 <= r12 -> + q = 2 ^ 64 * q12 + r12 -> + r11 < 2 ^ 64 -> + 0 <= r11 -> + r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> + r10 < 2 ^ 64 -> + 0 <= r10 -> + x1 + r11 = 2 ^ 64 * q10 + r10 -> + r9 < 2 ^ 64 -> + 0 <= r9 -> + r10 + r3 = 2 ^ 64 * q9 + r9 -> + r8 < 2 ^ 64 -> + 0 <= r8 -> + x2 - x1 = 2 ^ 64 * q8 + r8 -> + r7 < 2 ^ 64 -> + 0 <= r7 -> + Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> + r6 < 2 ^ 64 -> + 0 <= r6 -> + Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> + r5 < 2 ^ 64 -> + 0 <= r5 -> + x1 + r6 = 2 ^ 64 * q5 + r5 -> + r4 < 2 ^ 64 -> + 0 <= r4 -> + r5 - x1 = 2 ^ 64 * q4 + r4 -> + r3 < 2 ^ 64 -> + 0 <= r3 -> + 8 = 2 ^ 64 * q3 + r3 -> + r2 < r3 -> + 0 <= r2 -> + r4 = r3 * q2 + r2 -> + r1 < 2 ^ 64 -> + 0 <= r1 -> + 0 < 2 ^ 64 -> + x2 - r9 = 2 ^ 64 * q1 + r1 -> + r0 < r3 -> + 0 <= r0 -> + 0 < r3 -> + r13 = r3 * q0 + r0 -> + r < 2 ^ 4 -> + 0 <= r -> + 0 < 2 ^ 4 -> + r8 = 2 ^ 4 * q + r -> + r8 = 8 * Z.of_nat (Datatypes.length x) -> + r14 = 8 * Z.of_nat length_xs -> + (r1 = 8 * z84 -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_6.v b/test-suite/complexity/bug_13227_6.v new file mode 100644 index 0000000000..800aa4f625 --- /dev/null +++ b/test-suite/complexity/bug_13227_6.v @@ -0,0 +1,16 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (x2 x3 x : Z) + (H : 0 <= 1073741824 * x + x2 - 67146752) + (H0 : 0 <= -8192 + x2) + (H1 : 0 <= 34816 + - x2) + (H2 : 0 <= -1073741824 * x - x2 + 1073741823), + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/dune b/test-suite/dune index 6ab2988331..1864153021 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -9,6 +9,10 @@ (action (with-stdout-to %{targets} (run ./ocaml_pwd.exe -quoted ../../install/%{context_name}/lib/coq/ )))) (rule + (targets bin.inc) + (action (with-stdout-to %{targets} (run ./ocaml_pwd.exe -quoted -trailing-slash ../../install/%{context_name}/bin/ )))) + +(rule (targets summary.log) (deps ; File that should be promoted. @@ -44,4 +48,4 @@ ; %{bin:fake_ide} (action (progn - (bash "make -j %{env:NJOBS=2} BIN= COQLIB=%{read:libpath.inc} PRINT_LOGS=1 UNIT_TESTS=%{env:COQ_UNIT_TEST=unit-tests}")))) + (bash "make -j %{env:NJOBS=2} BIN=%{read:bin.inc} COQLIB=%{read:libpath.inc} PRINT_LOGS=1 UNIT_TESTS=%{env:COQ_UNIT_TEST=unit-tests}")))) diff --git a/test-suite/ltac2/compat.v b/test-suite/ltac2/compat.v index 9c11d19c27..b50371386f 100644 --- a/test-suite/ltac2/compat.v +++ b/test-suite/ltac2/compat.v @@ -40,6 +40,67 @@ Fail Ltac1.run (ltac1val:(x |- idtac) 0). Ltac1.run (ltac1val:(x |- idtac x) (Ltac1.of_constr constr:(Type))). Abort. +(** Check value-returning FFI *) + +(* A dummy CPS wrapper in Ltac1 *) +Ltac arg k := +match goal with +| [ |- ?P ] => k P +end. + +Ltac2 testeval v := + let r := { contents := None } in + let k c := + let () := match Ltac1.to_constr c with + | None => () + | Some c => r.(contents) := Some c + end in + (* dummy return value *) + ltac1val:(idtac) + in + let tac := ltac1val:(arg) in + let () := Ltac1.apply tac [Ltac1.lambda k] (fun _ => ()) in + match r.(contents) with + | None => fail + | Some c => if Constr.equal v c then () else fail + end. + +Goal True. +Proof. +testeval 'True. +Abort. + +Goal nat. +Proof. +testeval 'nat. +Abort. + +(* CPS towers *) +Ltac2 testeval2 tac := + let fail _ := Control.zero Not_found in + let cast c := match Ltac1.to_constr c with + | None => fail () + | Some c => c + end in + let f x y z := + let x := cast x in + let y := cast y in + let z := cast z in + Ltac1.of_constr constr:($x $y $z) + in + let f := Ltac1.lambda (fun x => Ltac1.lambda (fun y => Ltac1.lambda (fun z => f x y z))) in + Ltac1.apply tac [f] Ltac1.run. + +Goal False -> True. +Proof. +ltac1:( +let ff := ltac2:(tac |- testeval2 tac) in +ff ltac:(fun k => + let c := k (fun (n : nat) (i : True) (e : False) => i) O I in + exact c) +). +Qed. + (** Test calls to Ltac2 from Ltac1 *) Set Default Proof Mode "Classic". diff --git a/test-suite/micromega/bug_13227_1.v b/test-suite/micromega/bug_13227_1.v new file mode 100644 index 0000000000..fa6aa53447 --- /dev/null +++ b/test-suite/micromega/bug_13227_1.v @@ -0,0 +1,75 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +Axiom word: Type. + +Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) + (x : list word) (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 + r4 q3 q4 r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 + z83 z84 : Z), + z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> + 0 < Z.of_nat (Datatypes.length x) - (z83 + 1) -> + z83 = 0 -> + q0 <= 0 -> + 0 <= Z.of_nat v -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat (Datatypes.length x) -> + Z.of_nat (Datatypes.length x) = Z.of_nat v -> + r14 < 2 ^ 64 -> + 0 <= r14 -> + right - left = 2 ^ 64 * q14 + r14 -> + r13 < 2 ^ 64 -> + 0 <= r13 -> + r10 - x1 = 2 ^ 64 * q13 + r13 -> + r12 < 2 ^ 64 -> + 0 <= r12 -> + q = 2 ^ 64 * q12 + r12 -> + r11 < 2 ^ 64 -> + 0 <= r11 -> + r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> + r10 < 2 ^ 64 -> + 0 <= r10 -> + x1 + r11 = 2 ^ 64 * q10 + r10 -> + r9 < 2 ^ 64 -> + 0 <= r9 -> + r10 + r3 = 2 ^ 64 * q9 + r9 -> + r8 < 2 ^ 64 -> + 0 <= r8 -> + x2 - x1 = 2 ^ 64 * q8 + r8 -> + r7 < 2 ^ 64 -> + 0 <= r7 -> + Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> + r6 < 2 ^ 64 -> + 0 <= r6 -> + Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> + r5 < 2 ^ 64 -> + 0 <= r5 -> + x1 + r6 = 2 ^ 64 * q5 + r5 -> + r4 < 2 ^ 64 -> + 0 <= r4 -> + r5 - x1 = 2 ^ 64 * q4 + r4 -> + r3 < 2 ^ 64 -> + 0 <= r3 -> + 8 = 2 ^ 64 * q3 + r3 -> + r2 < r3 -> + 0 <= r2 -> + r4 = r3 * q2 + r2 -> + r1 < 2 ^ 64 -> + 0 <= r1 -> + 0 < 2 ^ 64 -> + x2 - r9 = 2 ^ 64 * q1 + r1 -> + r0 < r3 -> + 0 <= r0 -> + 0 < r3 -> + r13 = r3 * q0 + r0 -> + r8 = 2 ^ 4 * q + r -> + r8 = 8 * Z.of_nat (Datatypes.length x) -> + r14 = 8 * Z.of_nat length_xs -> + (r1 = 8 * z84 -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/micromega/int63.v b/test-suite/micromega/int63.v index 20dfa2631e..15146187ca 100644 --- a/test-suite/micromega/int63.v +++ b/test-suite/micromega/int63.v @@ -1,5 +1,6 @@ -Require Import ZArith ZifyInt63 Lia. +Require Import ZArith Lia. Require Import Int63. +Require ZifyInt63. Open Scope int63_scope. diff --git a/test-suite/misc/11170.sh b/test-suite/misc/11170.sh new file mode 100755 index 0000000000..da8843fcf6 --- /dev/null +++ b/test-suite/misc/11170.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +set -e + +export PATH=$BIN:$PATH +export OCAMLRUNPARAM=s=1 + +${coqc#"$BIN"} misc/aux11170.v diff --git a/test-suite/misc/aux11170.v b/test-suite/misc/aux11170.v new file mode 100644 index 0000000000..d4a8630053 --- /dev/null +++ b/test-suite/misc/aux11170.v @@ -0,0 +1,6 @@ +Fixpoint T n := match n with O => nat | S n => nat -> T n end. +Fixpoint app n : T n -> nat := + match n with O => fun x => x | S n => fun f => app n (f 0) end. +Definition n := (fix aux n := match n with S n => aux n + aux n | O => 1 end) 13. +Axiom f : T n. +Eval vm_compute in let t := (app n f, 0) in snd t. diff --git a/test-suite/misc/coq_environment.sh b/test-suite/misc/coq_environment.sh new file mode 100755 index 0000000000..667d11f89e --- /dev/null +++ b/test-suite/misc/coq_environment.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +TMP=`mktemp -d` +cd $TMP + +cat > coq_environment.txt <<EOT +# we override COQLIB because we can +COQLIB="$TMP/overridden" # bla bla +OCAMLFIND="$TMP/overridden" +FOOBAR="one more" +EOT + +cp $BIN/coqc . +cp $BIN/coq_makefile . +mkdir -p overridden/tools/ +cp $COQLIB/tools/CoqMakefile.in overridden/tools/ + +unset COQLIB +N=`./coqc -config | grep COQLIB | grep /overridden | wc -l` +if [ $N -ne 1 ]; then + echo COQLIB not overridden by coq_environment + coqc -config + exit 1 +fi +N=`./coqc -config | grep OCAMLFIND | grep /overridden | wc -l` +if [ $N -ne 1 ]; then + echo OCAMLFIND not overridden by coq_environment + coqc -config + exit 1 +fi +./coq_makefile -o CoqMakefile -R . foo > /dev/null +N=`grep COQMF_OCAMLFIND CoqMakefile.conf | grep /overridden | wc -l` +if [ $N -ne 1 ]; then + echo COQMF_OCAMLFIND not overridden by coq_environment + cat CoqMakefile.conf + exit 1 +fi + +export COQLIB="/overridden2" +N=`./coqc -config | grep COQLIB | grep /overridden2 | wc -l` +if [ $N -ne 1 ]; then + echo COQLIB not overridden by COQLIB when coq_environment present + coqc -config + exit 1 +fi + +rm -rf $TMP +exit 0 diff --git a/test-suite/misc/quotation_token/src/quotation.mlg b/test-suite/misc/quotation_token/src/quotation.mlg index ba0bcb1b3c..0f843b3b14 100644 --- a/test-suite/misc/quotation_token/src/quotation.mlg +++ b/test-suite/misc/quotation_token/src/quotation.mlg @@ -7,6 +7,6 @@ GRAMMAR EXTEND Gram term: LEVEL "0" [ [ s = QUOTATION "foobar:" -> { - CAst.make ~loc Constrexpr.(CSort Glob_term.(UNamed [GProp,0])) } ] ] + CAst.make ~loc Constrexpr.(CSort Glob_term.(UNamed [CProp,0])) } ] ] ; END diff --git a/test-suite/misc/side-eff-leak-univs/src/evil.mlg b/test-suite/misc/side-eff-leak-univs/src/evil.mlg index d89ab887a8..bb6eaff409 100644 --- a/test-suite/misc/side-eff-leak-univs/src/evil.mlg +++ b/test-suite/misc/side-eff-leak-univs/src/evil.mlg @@ -7,7 +7,7 @@ open Stdarg TACTIC EXTEND magic | [ "magic" ident(i) ident(j) ] -> { - let open Glob_term in - DeclareUniv.do_constraint ~poly:false [ GType (Libnames.qualid_of_ident i), Univ.Lt, GType (Libnames.qualid_of_ident j)]; Proofview.tclUNIT() + let open Constrexpr in + DeclareUniv.do_constraint ~poly:false [ CType (Libnames.qualid_of_ident i), Univ.Lt, CType (Libnames.qualid_of_ident j)]; Proofview.tclUNIT() } END diff --git a/test-suite/ocaml_pwd.ml b/test-suite/ocaml_pwd.ml index afa3deea3a..054a921b93 100644 --- a/test-suite/ocaml_pwd.ml +++ b/test-suite/ocaml_pwd.ml @@ -1,7 +1,26 @@ +open Arg + +let quoted = ref false +let trailing_slash = ref false + +let arguments = [ + "-quoted",Set quoted, "Quote path"; + "-trailing-slash",Set trailing_slash, "End the path with a /"; +] +let subject = ref None +let set_subject x = + if !subject <> None then + failwith "only one path"; + subject := Some x + let _ = - let quoted = Sys.argv.(1) = "-quoted" in - let ch_dir = Sys.argv.(if quoted then 2 else 1) in - Sys.chdir ch_dir; + Arg.parse arguments set_subject "Usage:"; + let subject = + match !subject with + | None -> failwith "no path given"; + | Some x -> x in + Sys.chdir subject; let dir = Sys.getcwd () in - let dir = if quoted then Filename.quote dir else dir in + let dir = if !trailing_slash then dir ^ "/" else dir in + let dir = if !quoted then Filename.quote dir else dir in Format.printf "%s%!" dir diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 01564e7f25..984ac4e527 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -74,7 +74,9 @@ fun '{{n, m, p}} => n + m + p fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: -The constructor D (in type J) expects 3 arguments. +Once notations are expanded, the resulting constructor D (in type J) is +expected to be applied to no arguments while it is actually applied to +1 argument. lem1 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k @@ -181,3 +183,51 @@ end File "stdin", line 253, characters 4-5: Warning: Unused variable B catches more than one case. [unused-pattern-matching-variable,pattern-matching] +The command has indeed failed with message: +Application of arguments to a recursive notation not supported in patterns. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 3 arguments. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 1 argument. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 4 arguments (or +6 arguments when including variables for local definitions) while it is +actually applied to 5 arguments. +fun x : J' bool (true, true) => +match x with +| D' _ _ _ m _ e => existT (fun x0 : nat => x0 = x0) m e +end + : J' bool (true, true) -> {x0 : nat & x0 = x0} +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ n _ p _ => n + p +end + : J' bool (true, true) -> nat +The command has indeed failed with message: +Application of arguments to a recursive notation not supported in patterns. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 3 arguments. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 1 argument. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 3 arguments (or +4 arguments when including variables for local definitions) while it is +actually applied to 2 arguments. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 3 arguments (or +4 arguments when including variables for local definitions) while it is +actually applied to 5 arguments. +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ _ m _ e => existT (fun x0 : nat => x0 = x0) m e +end + : J' bool (true, true) -> {x0 : nat & x0 = x0} +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ n _ p _ => (n, p) +end + : J' bool (true, true) -> nat * nat diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 2d8a8b359c..0cb3ac3ddc 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -254,3 +254,33 @@ Definition bar (f : foo) := end. End Wish12762. + +Module ConstructorArgumentsNumber. + +Arguments cons {A} _ _. + +Inductive J' A {B} (C:=(A*B)%type) (c:C) := D' : forall n {m}, let p := n+m in m=m -> J' A c. + +Unset Asymmetric Patterns. + +Fail Check fun x => match x with (y,z) w => y+z+w end. +Fail Check fun x => match x with cons y z w => 0 | nil => 0 end. +Fail Check fun x => match x with cons y => 0 | nil => 0 end. + +(* Missing a let-in to be in let-in mode *) +Fail Check fun x => match x with D' _ _ n p e => 0 end. +Check fun x : J' bool (true,true) => match x with D' _ _ n e => existT (fun x => eq x x) _ e end. +Check fun x : J' bool (true,true) => match x with D' _ _ _ n p e => n+p end. + +Set Asymmetric Patterns. + +Fail Check fun x => match x with (y,z) w => y+z+w end. +Fail Check fun x => match x with cons y z w => 0 | nil => 0 end. +Fail Check fun x => match x with cons y => 0 | nil => 0 end. + +Fail Check fun x => match x with D' n _ => 0 end. +Fail Check fun x => match x with D' n m p e _ => 0 end. +Check fun x : J' bool (true,true) => match x with D' n m e => existT (fun x => eq x x) m e end. +Check fun x : J' bool (true,true) => match x with D' n m p e => (n,p) end. + +End ConstructorArgumentsNumber. diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index eefa338f0d..ca8e1b58a8 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -1,7 +1,5 @@ 2%int63 : int -(2 + 2)%int63 - : int 2 : int 9223372036854775807 @@ -17,9 +15,9 @@ 427 : int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.Int63.int +Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.Int63.int +Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int 0 : int 0 @@ -32,13 +30,7 @@ The command has indeed failed with message: The reference x1 was not found in the current environment. The command has indeed failed with message: The reference x was not found in the current environment. -2 + 2 - : int -2 + 2 - : int - = 4 - : int - = 37151199385380486 +add 2 2 : int The command has indeed failed with message: int63 are only non-negative numbers. @@ -56,3 +48,11 @@ t = 2%i63 : nat 2 : int +(2 + 2)%int63 + : int +2 + 2 + : int + = 4 + : int + = 37151199385380486 + : int diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index c49616d918..6f1046f7a5 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -1,7 +1,6 @@ -Require Import Int63 Cyclic63. +Require Import PrimInt63. Check 2%int63. -Check (2 + 2)%int63. Open Scope int63_scope. Check 2. Check 9223372036854775807. @@ -18,10 +17,7 @@ Fail Check 0xg. Fail Check 0xG. Fail Check 00x1. Fail Check 0x. -Check (Int63.add 2 2). -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. +Check (PrimInt63.add 2 2). Fail Check -1. Fail Check 9223372036854775808. Open Scope nat_scope. @@ -36,3 +32,11 @@ Check 2. Close Scope nat_scope. Check 2. Close Scope int63_scope. + +Require Import Int63. + +Check (2 + 2)%int63. +Open Scope int63_scope. +Check (2+2). +Eval vm_compute in 2+2. +Eval vm_compute in 65675757 * 565675998. diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index bcb2468792..05712eaac7 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -62,7 +62,7 @@ Check `(∀ n p : A, n=p). Notation "'let'' f x .. y := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) - (f ident, x closed binder, y closed binder, at level 200, + (f name, x closed binder, y closed binder, at level 200, right associativity). Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. @@ -93,7 +93,7 @@ End A. Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) - (f ident, x closed binder, y closed binder, at level 200, + (f name, x closed binder, y closed binder, at level 200, right associativity). Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. @@ -104,7 +104,7 @@ Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. (* Old request mentioned again on coq-club 20/1/2012 *) Notation "# x : T => t" := (fun x : T => t) - (at level 0, t at level 200, x ident). + (at level 0, t at level 200, x name). Check # x : nat => x. Check # _ : nat => 2. @@ -116,7 +116,7 @@ Parameters (A : Set) (x y : A) (Q : A -> A -> Prop) (conj : Q x y). Check (exist (Q x) y conj). (* Check bug #4854 *) -Notation "% i" := (fun i : nat => i) (at level 0, i ident). +Notation "% i" := (fun i : nat => i) (at level 0, i name). Check %i. Check %j. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 04a91c14d9..6c714fc624 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -305,7 +305,7 @@ Module E. Inductive myex2 {A:Type} (P Q:A -> Prop) : Prop := myex_intro2 : forall x:A, P x -> Q x -> myex2 P Q. Notation "'myexists2' x : A , p & q" := (myex2 (A:=A) (fun x => p) (fun x => q)) - (at level 200, x ident, A at level 200, p at level 200, right associativity, + (at level 200, x name, A at level 200, p at level 200, right associativity, format "'[' 'myexists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. Check myex2 (fun x => let '(y,z) := x in y>z) (fun x => let '(y,z) := x in z>y). diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index df64ae2af3..3477a293e3 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -31,12 +31,6 @@ end : Expr -> Expr [(1 + 1)] : Expr -Let "x" e1 e2 - : expr -Let "x" e1 e2 - : expr -Let "x" e1 e2 : list string - : list string myAnd1 True True : Prop r 2 3 @@ -65,8 +59,6 @@ where |- Type] (pat, p0, p cannot be used) fun '{| |} => true : R -> bool -b = a - : Prop The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". The command has indeed failed with message: @@ -85,18 +77,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 226, characters 0-160: +File "stdin", line 184, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 239, characters 0-60: +File "stdin", line 197, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 243, characters 0-64: +File "stdin", line 201, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 248, characters 0-62: +File "stdin", line 206, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -105,10 +97,10 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 276, characters 0-61: +File "stdin", line 234, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 280, characters 0-63: +File "stdin", line 238, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] fun x : nat => U (S x) @@ -119,7 +111,7 @@ fun x : nat => V x : forall x : nat, nat * (?T -> ?T) where ?T : [x : nat x0 : ?T |- Type] (x0 cannot be used) -File "stdin", line 297, characters 0-30: +File "stdin", line 255, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index ebc1426fc8..ebad12af88 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -79,35 +79,7 @@ Check [1 + 1]. End C. -(* An example of interaction between coercion and notations from - Robbert Krebbers. *) - -Require Import String. - -Module D. - -Inductive expr := - | Var : string -> expr - | Lam : string -> expr -> expr - | App : expr -> expr -> expr. - -Notation Let x e1 e2 := (App (Lam x e2) e1). - -Parameter e1 e2 : expr. - -Check (Let "x" e1 e2). - -Coercion App : expr >-> Funclass. - -Check (Let "x" e1 e2). - -Axiom free_vars :> expr -> list string. - -Check (Let "x" e1 e2) : list string. - -End D. - -(* Fixing bugs reported by G. Gonthier in #9207 *) +(* Fixing overparenthesizing reported by G. Gonthier in #9207 (PR #9214, in 8.10)*) Module I. @@ -152,20 +124,6 @@ Check fun '{|n:=x|} => true. End EmptyRecordSyntax. -Module L. - -(* Testing regression #11053 *) - -Section Test. -Variables (A B : Type) (a : A) (b : B). -Variable c : A -> B. -Coercion c : A >-> B. -Notation COERCION := (c). -Check b = a. -End Test. - -End L. - Module M. (* Accept boxes around the end variables of a recursive notation (if equal boxes) *) @@ -327,6 +285,7 @@ Module P. Module NotationMixedTermBinderAsIdent. + Set Warnings "-deprecated-ident-entry". (* We do want ident! *) Notation "▢_ n P" := (pseudo_force n (fun n => P)) (at level 0, n ident, P at level 9, format "▢_ n P"). Check exists p, ▢_p (p >= 1). diff --git a/test-suite/output/NotationsCoercions.out b/test-suite/output/NotationsCoercions.out new file mode 100644 index 0000000000..56145e5fa5 --- /dev/null +++ b/test-suite/output/NotationsCoercions.out @@ -0,0 +1,22 @@ +Let "x" e1 e2 + : expr +Let "x" e1 e2 + : expr +Let "x" e1 e2 : list string + : list string +b = a + : Prop +foo + : (_ BitVec 32) +#[ r ] 0 + : nat +##[ r ] + : nat +##[ r ] + : nat +#[ r ] 0 + : nat +##[ r ] + : nat +##[ r ] + : nat diff --git a/test-suite/output/NotationsCoercions.v b/test-suite/output/NotationsCoercions.v new file mode 100644 index 0000000000..0524bed98c --- /dev/null +++ b/test-suite/output/NotationsCoercions.v @@ -0,0 +1,77 @@ +(* Tests about skipping a coercion vs using a notation involving a coercion *) + +Require Import String. + +(* Skipping a coercion vs using a notation for the application of the + coercion (from Robbert Krebbers, see PR #8890) *) + +Module A. + +Inductive expr := + | Var : string -> expr + | Lam : string -> expr -> expr + | App : expr -> expr -> expr. + +Notation Let x e1 e2 := (App (Lam x e2) e1). +Parameter e1 e2 : expr. +Check (Let "x" e1 e2). (* always printed the same *) +Coercion App : expr >-> Funclass. +Check (Let "x" e1 e2). (* printed the same from #8890, in 8.10 *) +Axiom free_vars :> expr -> list string. +Check (Let "x" e1 e2) : list string. (* printed the same from #11172, in 8.12 *) + +End A. + +(* Skipping a coercion vs using a notation for the coercion itself + (regression #11053 in 8.10 after PR #8890, addressed by PR #11090) *) + +Module B. + +Section Test. +Variables (A B : Type) (a : A) (b : B). +Variable c : A -> B. +Coercion c : A >-> B. +Notation COERCION := (c). +Check b = a. (* printed the same except in 8.10 *) +End Test. + +End B. + +Module C. + +Record word := { rep: Type }. +Coercion rep : word >-> Sortclass. +Axiom myword: word. +Axiom foo: myword. +Notation "'(_' 'BitVec' '32)'" := (rep myword). +Check foo. (* printed with Bitvec from #8890 in 8.10 and 8.11, regression due to #11172 in 8.12 *) + +End C. + +(* Examples involving coercions to funclass *) + +Module D. + +Record R := { f :> nat -> nat }. +Axiom r : R. +Notation "#[ x ]" := (f x). +Check #[ r ] 0. (* printed the same from 8.10 (due to #8890), but not 8.11 and 8.12 (due to #11090) *) +Notation "##[ x ]" := (f x 0). +Check ##[ r ]. (* printed the same from 8.10 *) +Check #[ r ] 0. (* printed ##[ r ] from 8.10 *) + +End D. + +(* Same examples with a parameter *) + +Module E. + +Record R A := { f :> A -> A }. +Axiom r : R nat. +Notation "#[ x ]" := (f nat x). +Check #[ r ] 0. (* printed the same from 8.10 (due to #8890), but not 8.11 and 8.12 (due to #11090) *) +Notation "##[ x ]" := (f nat x 0). +Check ##[ r ]. (* printed the same from 8.10 *) +Check #[ r ] 0. (* printed ##[ r ] from 8.10 *) + +End E. diff --git a/test-suite/output/RecordFieldErrors.out b/test-suite/output/RecordFieldErrors.out index 5b67f632c9..b80345108e 100644 --- a/test-suite/output/RecordFieldErrors.out +++ b/test-suite/output/RecordFieldErrors.out @@ -11,4 +11,4 @@ This record defines several times the field foo. The command has indeed failed with message: This record defines several times the field unit. The command has indeed failed with message: -unit: Not a projection of inductive t. +unit: Not a projection. diff --git a/test-suite/output/RecordFieldErrors.v b/test-suite/output/RecordFieldErrors.v index 27aa07822b..ff817c31aa 100644 --- a/test-suite/output/RecordFieldErrors.v +++ b/test-suite/output/RecordFieldErrors.v @@ -35,4 +35,4 @@ acceptable and seems an unlikely mistake. *) Fail Check {| foo := tt; unit := tt |}. -(* unit: Not a projection of inductive t. *) +(* unit: Not a projection. *) diff --git a/test-suite/output/StringSyntaxPrimitive.out b/test-suite/output/StringSyntaxPrimitive.out new file mode 100644 index 0000000000..131975c760 --- /dev/null +++ b/test-suite/output/StringSyntaxPrimitive.out @@ -0,0 +1,20 @@ +"abc" + : intList +"abc" + : intList +mk_intList [97%int63; 98%int63; 99%int63] + : intList +"abc" + : intArray +"abc" + : intArray + = "abc" + : nestArray +"abc" + : nestArray +"100" + : floatList +"100" + : floatList +mk_floatList [1%float; 0%float; 0%float] + : floatList diff --git a/test-suite/output/StringSyntaxPrimitive.v b/test-suite/output/StringSyntaxPrimitive.v new file mode 100644 index 0000000000..23ef082013 --- /dev/null +++ b/test-suite/output/StringSyntaxPrimitive.v @@ -0,0 +1,139 @@ +Require Import Coq.Lists.List. +Require Import Coq.Strings.String Coq.Strings.Byte Coq.Strings.Ascii. +Require Coq.Array.PArray Coq.Floats.PrimFloat. +Require Import Coq.Numbers.BinNums Coq.Numbers.Cyclic.Int63.Int63. + +Set Printing Depth 100000. +Set Printing Width 1000. + +Close Scope char_scope. +Close Scope string_scope. + +(* Notations for primitive integers inside polymorphic datatypes *) +Module Test1. + Inductive intList := mk_intList (_ : list int). + Definition i63_from_byte (b : byte) : int := Int63.of_Z (BinInt.Z.of_N (Byte.to_N b)). + Definition i63_to_byte (i : int) : byte := + match Byte.of_N (BinInt.Z.to_N (Int63.to_Z i)) with Some x => x | None => x00%byte end. + + Definition to_byte_list '(mk_intList a) := List.map i63_to_byte a. + + Definition from_byte_list (xs : list byte) : intList:= + mk_intList (List.map i63_from_byte xs). + + Declare Scope intList_scope. + Delimit Scope intList_scope with intList. + + String Notation intList from_byte_list to_byte_list : intList_scope. + + Open Scope intList_scope. + Import List.ListNotations. + Check mk_intList [97; 98; 99]%int63%list. + Check "abc"%intList. + + Definition int' := int. + Check mk_intList (@cons int' 97 [98; 99])%int63%list. +End Test1. + +Import PArray. + +(* Notations for primitive arrays *) +Module Test2. + Inductive intArray := mk_intArray (_ : array int). + + Definition i63_from_byte (b : byte) : Int63.int := Int63.of_Z (BinInt.Z.of_N (Byte.to_N b)). + Definition i63_to_byte (i : Int63.int) : byte := + match Byte.of_N (BinInt.Z.to_N (Int63.to_Z i)) with Some x => x | None => x00%byte end. + + Definition i63_to_nat x := BinInt.Z.to_nat (Int63.to_Z x). + Local Definition nat_length {X} (x : array X) :nat := i63_to_nat (length x). + + Local Fixpoint list_length_i63 {A} (xs : list A) :int := + match xs with + | nil => 0 + | cons _ xs => 1 + list_length_i63 xs + end. + + Definition to_byte_list '(mk_intArray a) := + ((fix go (n : nat) (i : Int63.int) (acc : list byte) := + match n with + | 0 => acc + | S n => go n (i - 1) (cons (i63_to_byte a.[i]) acc) + end) (nat_length a) (length a - 1) nil)%int63. + + Definition from_byte_list (xs : list byte) := + (let arr := make (list_length_i63 xs) 0 in + mk_intArray ((fix go i xs acc := + match xs with + | nil => acc + | cons x xs => go (i + 1) xs (acc.[i <- i63_from_byte x]) + end) 0 xs arr))%int63. + + Declare Scope intArray_scope. + Delimit Scope intArray_scope with intArray. + + String Notation intArray from_byte_list to_byte_list : intArray_scope. + + Open Scope intArray_scope. + Check mk_intArray ( [| 97; 98; 99 | 0|])%int63%array. + Check "abc"%intArray. + +End Test2. + +(* Primitive arrays inside primitive arrays *) +Module Test3. + + Inductive nestArray := mk_nestArray (_ : array (array int)). + Definition to_byte_list '(mk_nestArray a) := + ((fix go (n : nat) (i : Int63.int) (acc : list byte) := + match n with + | 0 => acc + | S n => go n (i - 1) (cons (Test2.i63_to_byte a.[i].[0]) acc) + end) (Test2.nat_length a) (length a - 1) nil)%int63. + + Definition from_byte_list (xs : list byte) := + (let arr := make (Test2.list_length_i63 xs) (make 0 0) in + mk_nestArray ((fix go i xs acc := + match xs with + | nil => acc + | cons x xs => go (i + 1) xs (acc.[i <- make 1 (Test2.i63_from_byte x)]) + end) 0 xs arr))%int63. + + Declare Scope nestArray_scope. + Delimit Scope nestArray_scope with nestArray. + + String Notation nestArray from_byte_list to_byte_list : nestArray_scope. + + Open Scope nestArray_scope. + Eval cbv in mk_nestArray ( [| make 1 97; make 1 98; make 1 99 | make 0 0|])%int63%array. + Check "abc"%nestArray. +End Test3. + + + +(* Notations for primitive floats inside polymorphic datatypes *) +Module Test4. + Import PrimFloat. + Inductive floatList := mk_floatList (_ : list float). + Definition float_from_byte (b : byte) : float := + if Byte.eqb b "0"%byte then PrimFloat.zero else PrimFloat.one. + Definition float_to_byte (f : float) : byte := + if PrimFloat.is_zero f then "0" else "1". + Definition to_byte_list '(mk_floatList a) := List.map float_to_byte a. + + Definition from_byte_list (xs : list byte) : floatList:= + mk_floatList (List.map float_from_byte xs). + + Declare Scope floatList_scope. + Delimit Scope floatList_scope with floatList. + + String Notation floatList from_byte_list to_byte_list : floatList_scope. + + Open Scope floatList_scope. + Import List.ListNotations. + Check mk_floatList [97; 0; 0]%float%list. + Check "100"%floatList. + + Definition float' := float. + Check mk_floatList (@cons float' 1 [0; 0])%float%list. +End Test4. diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out index 3f07261ca6..01bf727ebc 100644 --- a/test-suite/output/Tactics.out +++ b/test-suite/output/Tactics.out @@ -9,3 +9,4 @@ H is already used. a The command has indeed failed with message: This variable is used in hypothesis H. +Ltac test a b c d e := apply a, b in c as [], d, e as -> diff --git a/test-suite/output/Tactics.v b/test-suite/output/Tactics.v index 8526e43a23..845bccc548 100644 --- a/test-suite/output/Tactics.v +++ b/test-suite/output/Tactics.v @@ -38,3 +38,10 @@ Fail intros ((n,_),H). Abort. End IntroWildcard. + +Module ApplyIn. + +Ltac test a b c d e := apply a, b in c as [], d, e as ->. +Print test. + +End ApplyIn. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index d8d3f696b7..95b6c6ee95 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,61 +1,61 @@ -Inductive Empty@{u} : Type@{u} := -(* u |= *) -Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } -(* u |= *) +Inductive Empty@{uu} : Type@{uu} := +(* uu |= *) +Record PWrap (A : Type@{uu}) : Type@{uu} := pwrap { punwrap : A } +(* uu |= *) PWrap has primitive projections with eta conversion. Arguments PWrap _%type_scope Arguments pwrap _%type_scope _ -punwrap@{u} = -fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p - : forall A : Type@{u}, PWrap@{u} A -> A -(* u |= *) +punwrap@{uu} = +fun (A : Type@{uu}) (p : PWrap@{uu} A) => punwrap _ p + : forall A : Type@{uu}, PWrap@{uu} A -> A +(* uu |= *) Arguments punwrap _%type_scope _ -Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } -(* u |= *) +Record RWrap (A : Type@{uu}) : Type@{uu} := rwrap { runwrap : A } +(* uu |= *) Arguments RWrap _%type_scope Arguments rwrap _%type_scope _ -runwrap@{u} = -fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap - : forall A : Type@{u}, RWrap@{u} A -> A -(* u |= *) +runwrap@{uu} = +fun (A : Type@{uu}) (r : RWrap@{uu} A) => let (runwrap) := r in runwrap + : forall A : Type@{uu}, RWrap@{uu} A -> A +(* uu |= *) Arguments runwrap _%type_scope _ -Wrap@{u} = fun A : Type@{u} => A - : Type@{u} -> Type@{u} -(* u |= *) +Wrap@{uu} = fun A : Type@{uu} => A + : Type@{uu} -> Type@{uu} +(* uu |= *) Arguments Wrap _%type_scope -wrap@{u} = -fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap - : forall A : Type@{u}, Wrap@{u} A -> A -(* u |= *) +wrap@{uu} = +fun (A : Type@{uu}) (Wrap : Wrap@{uu} A) => Wrap + : forall A : Type@{uu}, Wrap@{uu} A -> A +(* uu |= *) Arguments wrap {A}%type_scope {Wrap} -bar@{u} = nat - : Wrap@{u} Set -(* u |= Set < u *) -foo@{u u0 v} = -Type@{u0} -> Type@{v} -> Type@{u} - : Type@{max(u+1,u0+1,v+1)} -(* u u0 v |= *) +bar@{uu} = nat + : Wrap@{uu} Set +(* uu |= Set < uu *) +foo@{uu u v} = +Type@{u} -> Type@{v} -> Type@{uu} + : Type@{max(uu+1,u+1,v+1)} +(* uu u v |= *) Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) = Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) -mono = Type@{mono.u} - : Type@{mono.u+1} -(* {mono.u} |= *) +mono = Type@{mono.uu} + : Type@{mono.uu+1} +(* {mono.uu} |= *) mono - : Type@{mono.u+1} -Type@{mono.u} - : Type@{mono.u+1} + : Type@{mono.uu+1} +Type@{mono.uu} + : Type@{mono.uu+1} The command has indeed failed with message: -Universe u already exists. +Universe uu already exists. monomono : Type@{MONOU+1} mono.monomono @@ -63,23 +63,23 @@ mono.monomono monomono : Type@{MONOU+1} mono - : Type@{mono.u+1} + : Type@{mono.uu+1} The command has indeed failed with message: -Universe u already exists. +Universe uu already exists. bobmorane = let tt := Type@{UnivBinders.32} in let ff := Type@{UnivBinders.34} in tt -> ff : Type@{max(UnivBinders.31,UnivBinders.33)} The command has indeed failed with message: -Universe u already bound. +Universe uu already bound. foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} : Type@{max(E+1,M+1,N+1)} (* E M N |= *) -foo@{u u0 v} = -Type@{u0} -> Type@{v} -> Type@{u} - : Type@{max(u+1,u0+1,v+1)} -(* u u0 v |= *) +foo@{uu u v} = +Type@{u} -> Type@{v} -> Type@{uu} + : Type@{max(uu+1,u+1,v+1)} +(* uu u v |= *) Inductive Empty@{E} : Type@{E} := (* E |= *) Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } @@ -103,45 +103,38 @@ The command has indeed failed with message: This object does not support universe names. The command has indeed failed with message: Cannot enforce v < u because u < gU < gV < v -bind_univs.mono = -Type@{bind_univs.mono.u} - : Type@{bind_univs.mono.u+1} -(* {bind_univs.mono.u} |= *) -bind_univs.poly@{u} = Type@{u} - : Type@{u+1} -(* u |= *) -insec@{v} = Type@{u} -> Type@{v} - : Type@{max(u+1,v+1)} +insec@{v} = Type@{uu} -> Type@{v} + : Type@{max(uu+1,v+1)} (* v |= *) Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} (* k |= *) Arguments inseccstr _%type_scope -insec@{u v} = Type@{u} -> Type@{v} - : Type@{max(u+1,v+1)} -(* u v |= *) -Inductive insecind@{u k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{u k} -(* u k |= *) +insec@{uu v} = Type@{uu} -> Type@{v} + : Type@{max(uu+1,v+1)} +(* uu v |= *) +Inductive insecind@{uu k} : Type@{k+1} := + inseccstr : Type@{k} -> insecind@{uu k} +(* uu k |= *) Arguments inseccstr _%type_scope insec2@{u} = Prop : Type@{Set+1} (* u |= *) -inmod@{u} = Type@{u} - : Type@{u+1} -(* u |= *) -SomeMod.inmod@{u} = Type@{u} - : Type@{u+1} -(* u |= *) -inmod@{u} = Type@{u} - : Type@{u+1} -(* u |= *) -Applied.infunct@{u v} = -inmod@{u} -> Type@{v} - : Type@{max(u+1,v+1)} -(* u v |= *) +inmod@{uu} = Type@{uu} + : Type@{uu+1} +(* uu |= *) +SomeMod.inmod@{uu} = Type@{uu} + : Type@{uu+1} +(* uu |= *) +inmod@{uu} = Type@{uu} + : Type@{uu+1} +(* uu |= *) +Applied.infunct@{uu v} = +inmod@{uu} -> Type@{v} + : Type@{max(uu+1,v+1)} +(* uu v |= *) axfoo@{i u u0} : Type@{u} -> Type@{i} (* i u u0 |= *) @@ -166,3 +159,16 @@ Arguments axbar' _%type_scope Expands to: Constant UnivBinders.axbar' The command has indeed failed with message: When declaring multiple axioms in one command, only the first is allowed a universe binder (which will be shared by the whole block). +foo@{i} = Type@{M.i} -> Type@{i} + : Type@{max(M.i+1,i+1)} +(* i |= *) +Type@{u0} -> Type@{UnivBinders.64} + : Type@{max(u0+1,UnivBinders.64+1)} +(* {UnivBinders.64} |= *) +bind_univs.mono = +Type@{bind_univs.mono.u} + : Type@{bind_univs.mono.u+1} +(* {bind_univs.mono.u} |= *) +bind_univs.poly@{u} = Type@{u} + : Type@{u+1} +(* u |= *) diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index 582a5e969a..9539e34cfe 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -5,32 +5,32 @@ Set Printing Universes. (* Unset Strict Universe Declaration. *) (* universe binders on inductive types and record projections *) -Inductive Empty@{u} : Type@{u} := . +Inductive Empty@{uu} : Type@{uu} := . Print Empty. Set Primitive Projections. -Record PWrap@{u} (A:Type@{u}) := pwrap { punwrap : A }. +Record PWrap@{uu} (A:Type@{uu}) := pwrap { punwrap : A }. Print PWrap. Print punwrap. Unset Primitive Projections. -Record RWrap@{u} (A:Type@{u}) := rwrap { runwrap : A }. +Record RWrap@{uu} (A:Type@{uu}) := rwrap { runwrap : A }. Print RWrap. Print runwrap. (* universe binders also go on the constants for operational typeclasses. *) -Class Wrap@{u} (A:Type@{u}) := wrap : A. +Class Wrap@{uu} (A:Type@{uu}) := wrap : A. Print Wrap. Print wrap. (* Instance in lemma mode used to ignore the binders. *) -Instance bar@{u} : Wrap@{u} Set. Proof. exact nat. Qed. +Instance bar@{uu} : Wrap@{uu} Set. Proof. exact nat. Qed. Print bar. Unset Strict Universe Declaration. (* The universes in the binder come first, then the extra universes in order of appearance. *) -Definition foo@{u +} := Type -> Type@{v} -> Type@{u}. +Definition foo@{uu +} := Type -> Type@{v} -> Type@{uu}. Print foo. Check Type@{i} -> Type@{j}. @@ -40,13 +40,13 @@ Eval cbv in Type@{i} -> Type@{j}. Set Strict Universe Declaration. (* Binders even work with monomorphic definitions! *) -Monomorphic Definition mono@{u} := Type@{u}. +Monomorphic Definition mono@{uu} := Type@{uu}. Print mono. Check mono. -Check Type@{mono.u}. +Check Type@{mono.uu}. Module mono. - Fail Monomorphic Universe u. + Fail Monomorphic Universe uu. Monomorphic Universe MONOU. Monomorphic Definition monomono := Type@{MONOU}. @@ -60,28 +60,28 @@ Import mono. Check monomono. (* unqualified MONOU *) Check mono. (* still qualified mono.u *) -Monomorphic Constraint Set < UnivBinders.mono.u. +Monomorphic Constraint Set < UnivBinders.mono.uu. Module mono2. - Monomorphic Universe u. + Monomorphic Universe uu. End mono2. -Fail Monomorphic Definition mono2@{u} := Type@{u}. +Fail Monomorphic Definition mono2@{uu} := Type@{uu}. Module SecLet. Unset Universe Polymorphism. Section foo. - (* Fail Let foo@{} := Type@{u}. (* doesn't parse: Let foo@{...} doesn't exist *) *) + (* Fail Let foo@{} := Type@{uu}. (* doesn't parse: Let foo@{...} doesn't exist *) *) Unset Strict Universe Declaration. - Let tt : Type@{u} := Type@{v}. (* names disappear in the ether *) - Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* names disappear into space *) + Let tt : Type@{uu} := Type@{v}. (* names disappear in the ether *) + Let ff : Type@{uu}. Proof. exact Type@{v}. Qed. (* names disappear into space *) Definition bobmorane := tt -> ff. End foo. Print bobmorane. End SecLet. (* fun x x => foo is nonsense with local binders *) -Fail Definition fo@{u u} := Type@{u}. +Fail Definition fo@{uu uu} := Type@{uu}. (* Using local binders for printing. *) Print foo@{E M N}. @@ -106,14 +106,9 @@ Fail Print Coq.Init.Logic@{E}. Monomorphic Universes gU gV. Monomorphic Constraint gU < gV. Fail Lemma foo@{u v|u < gU, gV < v, v < u} : nat. -(* Universe binders survive through compilation, sections and modules. *) -Require TestSuite.bind_univs. -Print bind_univs.mono. -Print bind_univs.poly. - Section SomeSec. - Universe u. - Definition insec@{v} := Type@{u} -> Type@{v}. + Universe uu. + Definition insec@{v} := Type@{uu} -> Type@{v}. Print insec. Inductive insecind@{k} := inseccstr : Type@{k} -> insecind. @@ -129,7 +124,7 @@ End SomeSec2. Print insec2. Module SomeMod. - Definition inmod@{u} := Type@{u}. + Definition inmod@{uu} := Type@{uu}. Print inmod. End SomeMod. Print SomeMod.inmod. @@ -138,7 +133,7 @@ Print inmod. Module Type SomeTyp. Definition inmod := Type. End SomeTyp. Module SomeFunct (In : SomeTyp). - Definition infunct@{u v} := In.inmod@{u} -> Type@{v}. + Definition infunct@{uu v} := In.inmod@{uu} -> Type@{v}. End SomeFunct. Module Applied := SomeFunct(SomeMod). Print Applied.infunct. @@ -147,7 +142,7 @@ Print Applied.infunct. In polymorphic mode the domain Type gets separate universes for the different axioms, but all axioms have to declare all universes. In - polymorphic mode they get the same universes, ie the type is only + monomorphic mode they get the same universes, ie the type is only interpd once. *) Axiom axfoo@{i+} axbar : Type -> Type@{i}. Monomorphic Axiom axfoo'@{i+} axbar' : Type -> Type@{i}. @@ -155,3 +150,28 @@ Monomorphic Axiom axfoo'@{i+} axbar' : Type -> Type@{i}. About axfoo. About axbar. About axfoo'. About axbar'. Fail Axiom failfoo failbar@{i} : Type. + +(* Notation interaction *) +Module Notas. + Unset Universe Polymorphism. + Module Import M. Universe i. End M. + + Polymorphic Definition foo@{i} := Type@{M.i} -> Type@{i}. + Print foo. (* must not print Type@{i} -> Type@{i} *) + +End Notas. + +Module NoAutoNames. + Monomorphic Universe u0. + + (* The anonymous universe doesn't get a name (names are only + invented at the end of a definition/inductive) so no need to + qualify u0. *) + Check (Type@{u0} -> Type). + +End NoAutoNames. + +(* Universe binders survive through compilation, sections and modules. *) +Require TestSuite.bind_univs. +Print bind_univs.mono. +Print bind_univs.poly. diff --git a/test-suite/output/bug_12908.v b/test-suite/output/bug_12908.v index 6f7be22fa0..7ab218a27a 100644 --- a/test-suite/output/bug_12908.v +++ b/test-suite/output/bug_12908.v @@ -7,7 +7,7 @@ Check forall m n, mult' m n = Nat.mul (Nat.mul 2 m) n. End A. Module B. -(* Test that an overriden scoped notation is deactivated *) +(* Test that an overridden scoped notation is deactivated *) Infix "*" := mult' : nat_scope. Check forall m n, mult' m n = Nat.mul (Nat.mul 2 m) n. End B. diff --git a/test-suite/output/bug_13595.out b/test-suite/output/bug_13595.out new file mode 100644 index 0000000000..2423b77b55 --- /dev/null +++ b/test-suite/output/bug_13595.out @@ -0,0 +1,4 @@ +The command has indeed failed with message: +Tactic failure: Goal is solvable by congruence but some arguments are missing. + Try "congruence with ((Triple a _ _)) ((Triple d c _))", + replacing metavariables by arbitrary terms. diff --git a/test-suite/output/bug_13595.v b/test-suite/output/bug_13595.v new file mode 100644 index 0000000000..27a9ebe15d --- /dev/null +++ b/test-suite/output/bug_13595.v @@ -0,0 +1,8 @@ +Inductive Cube:Set :=| Triple: nat -> nat -> nat -> Cube. + +Theorem incomplete :forall a b c d : nat,Triple a = Triple b->Triple d c = Triple d b->a = c. +Proof. + Fail congruence. + intros. + congruence with ((Triple a a a)) ((Triple d c a)). +Qed. diff --git a/test-suite/output/ssr_pred.out b/test-suite/output/ssr_pred.out new file mode 100644 index 0000000000..f00111ff97 --- /dev/null +++ b/test-suite/output/ssr_pred.out @@ -0,0 +1,3 @@ +in1W + : forall (T1 : predArgType) (D1 : {pred T1}) (P1 : T1 -> Prop), + (forall x : T1, P1 x) -> {in D1, forall x : T1, P1 x} diff --git a/test-suite/output/ssr_pred.v b/test-suite/output/ssr_pred.v new file mode 100644 index 0000000000..bd88af80a3 --- /dev/null +++ b/test-suite/output/ssr_pred.v @@ -0,0 +1,3 @@ +Require Import ssreflect ssrfun ssrbool. + +Check @in1W. diff --git a/test-suite/primitive/uint63/addcarryc.v b/test-suite/primitive/uint63/addcarryc.v index a4430769ca..7ab3af51d8 100644 --- a/test-suite/primitive/uint63/addcarryc.v +++ b/test-suite/primitive/uint63/addcarryc.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/primitive/uint63/addmuldiv.v b/test-suite/primitive/uint63/addmuldiv.v index 72b0164b49..e3aded6c96 100644 --- a/test-suite/primitive/uint63/addmuldiv.v +++ b/test-suite/primitive/uint63/addmuldiv.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/primitive/uint63/diveucl.v b/test-suite/primitive/uint63/diveucl.v index 8f88a0f356..43a0741ffe 100644 --- a/test-suite/primitive/uint63/diveucl.v +++ b/test-suite/primitive/uint63/diveucl.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/primitive/uint63/head0.v b/test-suite/primitive/uint63/head0.v index f4234d2605..30cbce4537 100644 --- a/test-suite/primitive/uint63/head0.v +++ b/test-suite/primitive/uint63/head0.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/primitive/uint63/subcarryc.v b/test-suite/primitive/uint63/subcarryc.v index e81b6536b2..6a773dde5d 100644 --- a/test-suite/primitive/uint63/subcarryc.v +++ b/test-suite/primitive/uint63/subcarryc.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/primitive/uint63/tail0.v b/test-suite/primitive/uint63/tail0.v index c9d426087a..1f91e4106c 100644 --- a/test-suite/primitive/uint63/tail0.v +++ b/test-suite/primitive/uint63/tail0.v @@ -1,4 +1,4 @@ -Require Import Int63. +Require Import PrimInt63. Set Implicit Arguments. diff --git a/test-suite/ssr/ipat_dup.v b/test-suite/ssr/ipat_dup.v index b1936df31d..61666959c4 100644 --- a/test-suite/ssr/ipat_dup.v +++ b/test-suite/ssr/ipat_dup.v @@ -2,6 +2,8 @@ Require Import ssreflect. Section Dup. +Section withP. + Variable P : nat -> Prop. Lemma test_dup1 : forall n : nat, P n. @@ -10,4 +12,18 @@ Proof. move=> /[dup] m n; suff: P n by []. Abort. Lemma test_dup2 : let n := 1 in False. Proof. move=> /[dup] m n; have : m = n := eq_refl. Abort. +End withP. + +Lemma test_dup_plus P Q : P -> Q -> False. +Proof. +move=> + /[dup] q. +suff: P -> Q -> False by []. +Abort. + +Lemma test_dup_plus2 P : P -> let x := 0 in False. +Proof. +move=> + /[dup] y. +suff: P -> let x := 0 in False by []. +Abort. + End Dup. diff --git a/test-suite/ssr/ipat_swap.v b/test-suite/ssr/ipat_swap.v index 1d78a2a009..a06dae1264 100644 --- a/test-suite/ssr/ipat_swap.v +++ b/test-suite/ssr/ipat_swap.v @@ -7,7 +7,19 @@ Definition P n := match n with 1 => true | _ => false end. Lemma test_swap1 : forall (n : nat) (b : bool), P n = b. Proof. move=> /[swap] b n; suff: P n = b by []. Abort. -Lemma test_swap1 : let n := 1 in let b := true in False. +Lemma test_swap2 : let n := 1 in let b := true in False. Proof. move=> /[swap] b n; have : P n = b := eq_refl. Abort. +Lemma test_swap_plus P Q R : P -> Q -> R -> False. +Proof. +move=> + /[swap]. +suff: P -> R -> Q -> False by []. +Abort. + +Lemma test_swap_plus2 P : P -> let x := 0 in let y := 1 in False. +Proof. +move=> + /[swap]. +suff: P -> let y := 1 in let x := 0 in False by []. +Abort. + End Swap. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index 465b3eb8c0..90c1b308f2 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -89,3 +89,16 @@ Check fun x:Ind bool nat => match x in Ind _ X Y Z return Z with | y => (true,0) end. + +(* A check that multi-implicit arguments work *) + +Check fun x : {True}+{False} => match x with left _ _ => 0 | right _ _ => 1 end. +Check fun x : {True}+{False} => match x with left _ => 0 | right _ => 1 end. + +(* Check that Asymmetric Patterns does not apply to the in clause *) + +Inductive expr {A} : A -> Type := intro : forall {n:nat} (a:A), n=n -> expr a. +Check fun (x:expr true) => match x in expr n return n=n with intro _ _ => eq_refl end. +Set Asymmetric Patterns. +Check fun (x:expr true) => match x in expr n return n=n with intro _ a _ => eq_refl a end. +Unset Asymmetric Patterns. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index 232ac17cbf..e678fc7882 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1882,3 +1882,60 @@ Check match O in nat return nat with O => O | _ => O end. (* Checking that aliases are substituted in the correct order *) Check match eq_refl (1,0) in _ = (y as z, y' as z) return z = z with eq_refl => eq_refl end : 0=0. + +(* Checking use of argument scopes *) + +Module Intern. + +Inductive I (A:Type) := C : nat -> let a:=0 in bool -> list bool -> bool -> I A. + +Close Scope nat_scope. +Notation "0" := true : bool_scope. +Notation "0" := nil : list_scope. +Notation C' := @C (only parsing). +Notation C'' := C (only parsing). +Notation C''' := (C _ 0) (only parsing). + +Set Asymmetric Patterns. + +Check fun x => match x with C 0 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C 0 _ 0 0 0 => O | _ => O end. (* was not supported *) + +Check fun x => match x with C' 0 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C' _ 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C' 0 _ 0 0 0 => O | _ => O end. (* was not supported *) +Check fun x => match x with C' _ _ 0 0 0 => O | _ => O end. (* was pre 8.5 bug *) + +Check fun x => match x with C'' 0 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C'' _ 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C'' 0 _ 0 0 0 => O | _ => O end. (* was not supported *) +Check fun x => match x with C'' _ _ 0 0 0 => O | _ => O end. (* was pre 8.5 bug *) + +Check fun x => match x with C''' 0 0 0 => O | _ => O end. (* 8.5 regression *) +Check fun x => match x with C''' _ 0 0 0 => O | _ => O end. (* was not supported *) + +Unset Asymmetric Patterns. +Arguments C {A} _ {x} _ _. + +Check fun x => match x with C 0 0 0 => O | _ => O end. (* was ok *) +Check fun x => match x with C 0 _ 0 0 => O | _ => O end. (* was wrong scope on last argument with let-in *) + +Check fun x => match x with C' _ 0 _ 0 0 => O | _ => O end. (* was wrong scope *) +Check fun x => match x with C' _ 0 _ 0 0 0 => O | _ => O end. (* was wrong scope *) + +Check fun x => match x with C'' _ 0 0 => O | _ => O end. (* was ok *) +Check fun x => match x with C'' _ _ 0 0 => O | _ => O end. (* was wrong scope *) + +Check fun x => match x with C''' 0 0 => O | _ => O end. (* was wrong scope *) +Check fun x => match x with C''' _ 0 0 => O | _ => O end. (* works by miscount compensating *) + +Check fun x => match x with (@C _ 0) _ 0 0 => O | _ => O end. (* was wrong scope *) +Check fun x => match x with (@C _ 0) _ _ 0 0 => O | _ => O end. (* was wrong scope *) + +Check fun x => match x with @C _ 0 _ 0 0 => O | _ => O end. (* was ok *) +Check fun x => match x with @C _ 0 _ _ 0 0 => O | _ => O end. (* was wrong scope *) + +Check fun x => match x with (@C) _ O _ 0 0 => O | _ => O end. (* was wrong scope *) +Check fun x => match x with (@C) _ O _ _ 0 0 => O | _ => O end. (* was wrong scope *) + +End Intern. diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index 97b4e39168..f1dad301fd 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.13") -*- *) +(* -*- coq-prog-args: ("-compat" "8.14") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq813. +Import Coq.Compat.Coq814. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index c06dd6e450..a737e0c98e 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.11") -*- *) +(* -*- coq-prog-args: ("-compat" "8.12") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq814. Import Coq.Compat.Coq813. Import Coq.Compat.Coq812. -Import Coq.Compat.Coq811. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..f4cf703ec7 --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.11") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq814. +Import Coq.Compat.Coq813. +Import Coq.Compat.Coq812. +Import Coq.Compat.Coq811. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index 83010f2149..07d5fcd3ab 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.12") -*- *) +(* -*- coq-prog-args: ("-compat" "8.13") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq814. Import Coq.Compat.Coq813. -Import Coq.Compat.Coq812. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index e1df9ba84a..8c4b567106 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -530,6 +530,16 @@ rewrite H0. change (x+0=0). Abort. +Goal (forall x y, x <= y -> y + x = 0 /\ True) -> exists x y, (x <= 0 -> y <= 1 -> 0 = 0 /\ 1 = 0). +intros. +do 2 eexists. +intros. +eapply H in H0 as (H0,_), H1 as (H1,_). +split. +- exact H0. +- exact H1. +Qed. + (* 2nd order apply used to have delta on local definitions even though it does not have delta on global definitions; keep it by compatibility while finding a more uniform way to proceed. *) @@ -582,3 +592,22 @@ intros. eexists ?[p]. split. rewrite H. reflexivity. exact H0. Qed. + +(* apply and side conditions: we check that apply in iterates only on + the main subgoals *) + +Goal (forall x, x=0 -> x>=0 -> x<=0 \/ x<=1) -> 0>=0 -> 1>=0 -> 1=0 -> True. +intros f H H0 H1. +apply f in H as [], H0 as []. +1-3: change (0 <= 0) in H. +4-6: change (0 <= 1) in H. +1: change (1 <= 0) in H0. +4: change (1 <= 0) in H0. +2: change (1 <= 1) in H0. +5: change (1 <= 1) in H0. +1-2,4-5: exact I. +1,2: exact H1. +change (0 >= 0) in H. +change (1 >= 0) in H0. +exact (eq_refl 0). +Qed. diff --git a/test-suite/success/cbv_let.v b/test-suite/success/cbv_let.v new file mode 100644 index 0000000000..861a73a64e --- /dev/null +++ b/test-suite/success/cbv_let.v @@ -0,0 +1,34 @@ +Record T : Type := Build_T { f : unit; g := pair f f; }. + +Definition t : T := {| f := tt; |}. + +Goal match t return unit with Build_T f g => f end = tt. +Proof. +cbv. +reflexivity. +Qed. + +Goal match t return prod unit unit with Build_T f g => g end = pair tt tt. +Proof. +cbv. +reflexivity. +Qed. + +Goal forall (x : T), + match x return prod unit unit with Build_T f g => g end = + pair match x return unit with Build_T f g => fst g end match x return unit with Build_T f g => snd g end. +Proof. +cbv. +destruct x. +reflexivity. +Qed. + +Record U : Type := Build_U { h := tt }. + +Definition u : U := Build_U. + +Goal match u with Build_U h => h end = tt. +Proof. +cbv. +reflexivity. +Qed. diff --git a/test-suite/success/change_case.v b/test-suite/success/change_case.v new file mode 100644 index 0000000000..490e4f4b6c --- /dev/null +++ b/test-suite/success/change_case.v @@ -0,0 +1,20 @@ +Inductive box (A : Type) := Box : A -> box A. + +Axiom PRED : unit -> Prop. +Axiom FUN : forall (u : unit), box (PRED u). + +Axiom U : unit. +Definition V := U. + +Goal match FUN U with Box _ _ => True end. +Proof. +repeat match goal with +| [ |- context G[ U ] ] => + let e := context G [ V ] in + change e +end. +set (Z := V). +clearbody Z. (* This fails if change misses the case parameters *) +destruct (FUN Z). +constructor. +Qed. diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index 253b48e4d9..2308656f7c 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -426,3 +426,12 @@ Abort. (* (reported as bug #7356) *) Check fun (P : nat -> Prop) (x:nat) (h:P x) => exist _ ?[z] (h : P ?z). + +(* A printing check in passing *) + +Axiom abs : forall T, T. +Fail Type let x := _ in + ltac:( + let t := type of x in + unify x (abs t); + exact 0). diff --git a/test-suite/success/rewrite_in.v b/test-suite/success/rewrite_in.v index 29fe915ff4..3433866239 100644 --- a/test-suite/success/rewrite_in.v +++ b/test-suite/success/rewrite_in.v @@ -5,4 +5,10 @@ Goal forall (P Q : Prop) (f:P->Prop) (p:P), (P<->Q) -> f p -> True. rewrite H in p || trivial. Qed. - +Goal 1 = 0 -> 0 = 1. + intro H. + Fail rewrite H at 1 2 3. (* bug #13566 *) + Fail rewrite H at 0. + rewrite H at 1. + reflexivity. +Qed. diff --git a/test-suite/success/typing_flags.v b/test-suite/success/typing_flags.v index bd20d9c804..4af2028e38 100644 --- a/test-suite/success/typing_flags.v +++ b/test-suite/success/typing_flags.v @@ -1,4 +1,51 @@ +From Coq Require Import Program.Tactics. +(* Part using attributes *) + +#[bypass_check(guard)] Fixpoint att_f' (n : nat) : nat := att_f' n. +#[bypass_check(guard)] Program Fixpoint p_att_f' (n : nat) : nat := p_att_f' n. + +#[bypass_check(universes)] Definition att_T := let t := Type in (t : t). +#[bypass_check(universes)] Program Definition p_att_T := let t := Type in (t : t). + +#[bypass_check(positivity)] +Inductive att_Cor := +| att_Over : att_Cor +| att_Next : ((att_Cor -> list nat) -> list nat) -> att_Cor. + +Fail #[bypass_check(guard=no)] Fixpoint f_att_f' (n : nat) : nat := f_att_f' n. +Fail #[bypass_check(universes=no)] Definition f_att_T := let t := Type in (t : t). + +Fail #[bypass_check(positivity=no)] +Inductive f_att_Cor := +| f_att_Over : f_att_Cor +| f_att_Next : ((f_att_Cor -> list nat) -> list nat) -> f_att_Cor. + +Print Assumptions att_f'. +Print Assumptions att_T. +Print Assumptions att_Cor. + +(* Interactive + atts *) +#[bypass_check(universes=yes)] Definition i_att_T' : Type. Proof. exact (let t := Type in (t : t)). Defined. +#[bypass_check(universes=yes)] Definition d_att_T' : Type. Proof. exact (let t := Type in (t : t)). Qed. +#[bypass_check(universes=yes)] Program Definition pi_att_T' : Type. Proof. exact (let t := Type in (t : t)). Qed. + +(* Note: be aware of tactics invoking [Global.env()] if this test fails. *) +#[bypass_check(guard=yes)] Fixpoint i_att_f' (n : nat) : nat. +Proof. exact (i_att_f' n). Defined. + +#[bypass_check(guard=yes)] Fixpoint d_att_f' (n : nat) : nat. +Proof. exact (d_att_f' n). Qed. + +(* check regular mode is still safe *) +Fail Fixpoint f_att_f' (n : nat) : nat := f_att_f' n. +Fail Definition f_att_T := let t := Type in (t : t). + +Fail Inductive f_att_Cor := +| f_att_Over : f_att_Cor +| f_att_Next : ((f_att_Cor -> list nat) -> list nat) -> f_att_Cor. + +(* Part using Set/Unset *) Print Typing Flags. Unset Guard Checking. Fixpoint f' (n : nat) : nat := f' n. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 7ff5571ffb..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --release || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 236d35b68e..c489d82d0b 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -236,8 +236,6 @@ Hint Resolve irreflexivity : ord. Unset Implicit Arguments. -(** A HintDb for crelations. *) - Ltac solve_crelation := match goal with | [ |- ?R ?x ?x ] => reflexivity diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 54ee06343a..353496dfba 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -235,8 +235,6 @@ Hint Resolve irreflexivity : ord. Unset Implicit Arguments. -(** A HintDb for relations. *) - Ltac solve_relation := match goal with | [ |- ?R ?x ?x ] => reflexivity diff --git a/theories/Compat/Coq813.v b/theories/Compat/Coq813.v index 92544c6ed9..fe7431dcd3 100644 --- a/theories/Compat/Coq813.v +++ b/theories/Compat/Coq813.v @@ -9,3 +9,5 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.13 *) + +Require Export Coq.Compat.Coq814. diff --git a/theories/Compat/Coq814.v b/theories/Compat/Coq814.v new file mode 100644 index 0000000000..94948dd280 --- /dev/null +++ b/theories/Compat/Coq814.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.14 *) diff --git a/theories/Floats/PrimFloat.v b/theories/Floats/PrimFloat.v index ed7947aa63..4c818a7e52 100644 --- a/theories/Floats/PrimFloat.v +++ b/theories/Floats/PrimFloat.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Int63 FloatClass. +Require Import PrimInt63 FloatClass. (** * Definition of the interface for primitive floating-point arithmetic diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 023705e169..5247c7b56a 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -309,9 +309,9 @@ Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) : type_scope. Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) - (at level 200, x ident, p at level 200, right associativity) : type_scope. + (at level 200, x name, p at level 200, right associativity) : type_scope. Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) - (at level 200, x ident, A at level 200, p at level 200, right associativity, + (at level 200, x name, A at level 200, p at level 200, right associativity, format "'[' 'exists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. @@ -489,18 +489,18 @@ Module EqNotations. := (match H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, + (at level 10, H' at level 10, y name, p name, format "'[' 'rew' 'dependent' [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' -> [ 'fun' y p => P ] H 'in' H'" := (match H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, only parsing). + (at level 10, H' at level 10, y name, p name, only parsing). Notation "'rew' 'dependent' <- [ 'fun' y p => P ] H 'in' H'" := (match eq_sym H as p in (_ = y) return P with | eq_refl => H' end) - (at level 10, H' at level 10, y ident, p ident, + (at level 10, H' at level 10, y name, p name, format "'[' 'rew' 'dependent' <- [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' [ P ] H 'in' H'" := (match H as p in (_ = y) return P y p with diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 84d40035bf..1a2c4ba171 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -96,19 +96,19 @@ Module Generic. (* begin hide *) (* Notations used in the proof. Hidden in coqdoc. *) -Reserved Notation "'∀₁' x : A , B" (at level 200, x ident, A at level 200,right associativity). +Reserved Notation "'∀₁' x : A , B" (at level 200, x name, A at level 200,right associativity). Reserved Notation "A '⟶₁' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₁' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'λ₁' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₁' x" (at level 5, left associativity). -Reserved Notation "'∀₂' A , F" (at level 200, A ident, right associativity). -Reserved Notation "'λ₂' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'∀₂' A , F" (at level 200, A name, right associativity). +Reserved Notation "'λ₂' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity). -Reserved Notation "'∀₀' x : A , B" (at level 200, x ident, A at level 200,right associativity). +Reserved Notation "'∀₀' x : A , B" (at level 200, x name, A at level 200,right associativity). Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₀' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'λ₀' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₀' x" (at level 5, left associativity). -Reserved Notation "'∀₀¹' A : U , F" (at level 200, A ident, right associativity). -Reserved Notation "'λ₀¹' x , u" (at level 200, x ident, right associativity). +Reserved Notation "'∀₀¹' A : U , F" (at level 200, A name, right associativity). +Reserved Notation "'λ₀¹' x , u" (at level 200, x name, right associativity). Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity). (* end hide *) diff --git a/theories/Numbers/Cyclic/Abstract/CarryType.v b/theories/Numbers/Cyclic/Abstract/CarryType.v new file mode 100644 index 0000000000..a21a1c8022 --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/CarryType.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +Set Implicit Arguments. + +#[universes(template)] +Variant carry (A : Type) := +| C0 : A -> carry A +| C1 : A -> carry A. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index 165f9893ca..e399bcfc0f 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -13,15 +13,15 @@ Set Implicit Arguments. Require Import BinInt. +Require Import CarryType. Local Open Scope Z_scope. Definition base digits := Z.pow 2 (Zpos digits). Arguments base digits: simpl never. -#[universes(template)] -Variant carry (A : Type) := -| C0 : A -> carry A -| C1 : A -> carry A. +Notation carry := carry (only parsing). +Notation C0 := C0 (only parsing). +Notation C1 := C1 (only parsing). Definition interp_carry {A} (sign:Z)(B:Z)(interp:A -> Z) c := match c with diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index dbca2f0947..c469a49903 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -17,55 +17,25 @@ Require Import Zpow_facts. Require Import Zgcd_alt. Require ZArith. Import Znumtheory. - -Register bool as kernel.ind_bool. -Register prod as kernel.ind_pair. -Register carry as kernel.ind_carry. -Register comparison as kernel.ind_cmp. +Require Export PrimInt63. Definition size := 63%nat. -Primitive int := #int63_type. -Register int as num.int63.type. -Declare Scope int63_scope. -Definition id_int : int -> int := fun x => x. -Declare ML Module "int63_syntax_plugin". - -Module Import Int63NotationsInternalA. -Delimit Scope int63_scope with int63. -Bind Scope int63_scope with int. -End Int63NotationsInternalA. - -(* Logical operations *) -Primitive lsl := #int63_lsl. - -Primitive lsr := #int63_lsr. - -Primitive land := #int63_land. - -Primitive lor := #int63_lor. - -Primitive lxor := #int63_lxor. - -(* Arithmetic modulo operations *) -Primitive add := #int63_add. - -Primitive sub := #int63_sub. - -Primitive mul := #int63_mul. - -Primitive mulc := #int63_mulc. - -Primitive div := #int63_div. - -Primitive mod := #int63_mod. - -(* Comparisons *) -Primitive eqb := #int63_eq. - -Primitive ltb := #int63_lt. - -Primitive leb := #int63_le. +Notation int := int (only parsing). +Notation lsl := lsl (only parsing). +Notation lsr := lsr (only parsing). +Notation land := land (only parsing). +Notation lor := lor (only parsing). +Notation lxor := lxor (only parsing). +Notation add := add (only parsing). +Notation sub := sub (only parsing). +Notation mul := mul (only parsing). +Notation mulc := mulc (only parsing). +Notation div := div (only parsing). +Notation mod := mod (only parsing). +Notation eqb := eqb (only parsing). +Notation ltb := ltb (only parsing). +Notation leb := leb (only parsing). Local Open Scope int63_scope. @@ -139,34 +109,29 @@ Register Inline subcarry. Definition addc_def x y := let r := x + y in if r <? x then C1 r else C0 r. -(* the same but direct implementation for efficiency *) -Primitive addc := #int63_addc. +Notation addc := addc (only parsing). Definition addcarryc_def x y := let r := addcarry x y in if r <=? x then C1 r else C0 r. -(* the same but direct implementation for efficiency *) -Primitive addcarryc := #int63_addcarryc. +Notation addcarryc := addcarryc (only parsing). Definition subc_def x y := if y <=? x then C0 (x - y) else C1 (x - y). -(* the same but direct implementation for efficiency *) -Primitive subc := #int63_subc. +Notation subc := subc (only parsing). Definition subcarryc_def x y := if y <? x then C0 (x - y - 1) else C1 (x - y - 1). -(* the same but direct implementation for efficiency *) -Primitive subcarryc := #int63_subcarryc. +Notation subcarryc := subcarryc (only parsing). Definition diveucl_def x y := (x/y, x mod y). -(* the same but direct implementation for efficiency *) -Primitive diveucl := #int63_diveucl. +Notation diveucl := diveucl (only parsing). -Primitive diveucl_21 := #int63_div21. +Notation diveucl_21 := diveucl_21 (only parsing). Definition addmuldiv_def p x y := (x << p) lor (y >> (digits - p)). -Primitive addmuldiv := #int63_addmuldiv. +Notation addmuldiv := addmuldiv (only parsing). Module Import Int63NotationsInternalC. Notation "- x" := (opp x) : int63_scope. @@ -188,7 +153,7 @@ Definition compare_def x y := if x <? y then Lt else if (x =? y) then Eq else Gt. -Primitive compare := #int63_compare. +Notation compare := compare (only parsing). Import Bool ZArith. (** Translation to Z *) @@ -371,8 +336,8 @@ Axiom leb_spec : forall x y, (x <=? y)%int63 = true <-> φ x <= φ y. (** Exotic operations *) (** I should add the definition (like for compare) *) -Primitive head0 := #int63_head0. -Primitive tail0 := #int63_tail0. +Notation head0 := head0 (only parsing). +Notation tail0 := tail0 (only parsing). (** Axioms on operations which are just short cut *) @@ -1950,7 +1915,6 @@ Module Export Int63Notations. Notation "m <= n" := (m <=? n) : int63_scope. #[deprecated(since="8.13",note="use infix ≤? instead")] Notation "m ≤ n" := (m <=? n) (at level 70, no associativity) : int63_scope. - Export Int63NotationsInternalA. Export Int63NotationsInternalB. Export Int63NotationsInternalC. Export Int63NotationsInternalD. diff --git a/theories/Numbers/Cyclic/Int63/PrimInt63.v b/theories/Numbers/Cyclic/Int63/PrimInt63.v new file mode 100644 index 0000000000..64c1b862c7 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/PrimInt63.v @@ -0,0 +1,82 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Export CarryType. + +Register bool as kernel.ind_bool. +Register prod as kernel.ind_pair. +Register carry as kernel.ind_carry. +Register comparison as kernel.ind_cmp. + +Primitive int := #int63_type. +Register int as num.int63.type. +Declare Scope int63_scope. +Definition id_int : int -> int := fun x => x. +Declare ML Module "int63_syntax_plugin". + +Module Export Int63NotationsInternalA. +Delimit Scope int63_scope with int63. +Bind Scope int63_scope with int. +End Int63NotationsInternalA. + +(* Logical operations *) +Primitive lsl := #int63_lsl. + +Primitive lsr := #int63_lsr. + +Primitive land := #int63_land. + +Primitive lor := #int63_lor. + +Primitive lxor := #int63_lxor. + +(* Arithmetic modulo operations *) +Primitive add := #int63_add. + +Primitive sub := #int63_sub. + +Primitive mul := #int63_mul. + +Primitive mulc := #int63_mulc. + +Primitive div := #int63_div. + +Primitive mod := #int63_mod. + +(* Comparisons *) +Primitive eqb := #int63_eq. + +Primitive ltb := #int63_lt. + +Primitive leb := #int63_le. + +(** Exact arithmetic operations *) + +Primitive addc := #int63_addc. + +Primitive addcarryc := #int63_addcarryc. + +Primitive subc := #int63_subc. + +Primitive subcarryc := #int63_subcarryc. + +Primitive diveucl := #int63_diveucl. + +Primitive diveucl_21 := #int63_div21. + +Primitive addmuldiv := #int63_addmuldiv. + +(** Comparison *) +Primitive compare := #int63_compare. + +(** Exotic operations *) + +Primitive head0 := #int63_head0. +Primitive tail0 := #int63_tail0. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index 9c8508bf39..b2bdd8099a 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -18,7 +18,7 @@ Set Implicit Arguments. Notation "{ ( x , y ) : A | P }" := (sig (fun anonymous : A => let (x,y) := anonymous in P)) - (x ident, y ident, at level 10) : type_scope. + (x name, y name, at level 10) : type_scope. Declare Scope program_scope. Delimit Scope program_scope with prg. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index ef09188c33..8b78f73d2e 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -128,19 +128,37 @@ Proof. elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)). Qed. -Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x. -Proof. - intros; apply Rplus_lt_reg_l with (- exp 0); rewrite <- (Rplus_comm (exp x)); - assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; - intros; elim H1; intros; unfold Rminus in H2; rewrite H2; - rewrite Ropp_0; rewrite Rplus_0_r; - replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0). - rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; - pattern x at 1; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0)); - apply Rmult_lt_compat_l. - apply H. - rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption. - symmetry ; apply derive_pt_eq_0; apply derivable_pt_lim_exp. +Lemma exp_ineq1 : forall x : R, x <> 0 -> 1 + x < exp x. +Proof. + assert (Hd : forall c : R, + derivable_pt_lim (fun x : R => exp x - (x + 1)) c (exp c - 1)). + intros. + apply derivable_pt_lim_minus; [apply derivable_pt_lim_exp | ]. + replace (1) with (1 + 0) at 1 by lra. + apply derivable_pt_lim_plus; + [apply derivable_pt_lim_id | apply derivable_pt_lim_const]. + intros x xdz; destruct (Rtotal_order x 0) as [xlz|[xez|xgz]]. + - destruct (MVT_cor2 _ _ x 0 xlz (fun c _ => Hd c)) as [c [HH1 HH2]]. + rewrite exp_0 in HH1. + assert (H1 : 0 < x * exp c - x); [| lra]. + assert (H2 : x * exp 0 < x * exp c); [| rewrite exp_0 in H2; lra]. + apply Rmult_lt_gt_compat_neg_l; auto. + now apply exp_increasing. + - now case xdz. + - destruct (MVT_cor2 _ _ 0 x xgz (fun c _ => Hd c)) as [c [HH1 HH2]]. + rewrite exp_0 in HH1. + assert (H1 : 0 < x * exp c - x); [| lra]. + assert (H2 : x * exp 0 < x * exp c); [| rewrite exp_0 in H2; lra]. + apply Rmult_lt_compat_l; auto. + now apply exp_increasing. +Qed. + +Lemma exp_ineq1_le (x : R) : 1 + x <= exp x. +Proof. + destruct (Req_EM_T x 0) as [xeq|?]. + - rewrite xeq, exp_0; lra. + - left. + now apply exp_ineq1. Qed. Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }. @@ -159,7 +177,7 @@ Proof. unfold f; apply Rplus_le_reg_l with y; left; apply Rlt_trans with (1 + y). rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1. - replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | ring ]. + replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y); lra | ring ]. unfold f; change (continuity (exp - fct_cte y)); apply continuity_minus; [ apply derivable_continuous; apply derivable_exp diff --git a/theories/micromega/MExtraction.v b/theories/micromega/MExtraction.v index fcb07c4774..a02d7adfa2 100644 --- a/theories/micromega/MExtraction.v +++ b/theories/micromega/MExtraction.v @@ -53,12 +53,13 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) -(*Extraction "micromega.ml" +(* +Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula Tauto.abst_form ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + denorm QArith_base.Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index ce12b02359..515372466a 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -611,13 +611,15 @@ Section S. let '(e1 , t1) := (RXCNF (negb polarity) e1) in if polarity then - if is_cnf_ff e1 - then - RXCNF polarity e2 - else (* compute disjunction *) - let '(e2 , t2) := (RXCNF polarity e2) in - let (f',t') := ror_cnf_opt e1 e2 in - (f', t1 +++ t2 +++ t') (* record the hypothesis *) + if is_cnf_tt e1 + then (e1,t1) + else if is_cnf_ff e1 + then + RXCNF polarity e2 + else (* compute disjunction *) + let '(e2 , t2) := (RXCNF polarity e2) in + let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') (* record the hypothesis *) else let '(e2 , t2) := (RXCNF polarity e2) in (and_cnf_opt e1 e2, t1 +++ t2). @@ -1349,6 +1351,7 @@ Section S. reflexivity. Qed. + Lemma rxcnf_impl_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) @@ -1366,9 +1369,15 @@ Section S. simpl in *. subst. destruct pol;auto. - generalize (is_cnf_ff_inv (xcnf (negb true) f1)). + generalize (is_cnf_tt_inv (xcnf (negb true) f1)). + destruct (is_cnf_tt (xcnf (negb true) f1)). + + intros. + rewrite H by auto. + reflexivity. + + + generalize (is_cnf_ff_inv (xcnf (negb true) f1)). destruct (is_cnf_ff (xcnf (negb true) f1)). - + intros H. + * intros. rewrite H by auto. unfold or_cnf_opt. simpl. @@ -1377,16 +1386,13 @@ Section S. destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. apply is_cnf_ff_inv in EQ1. congruence. reflexivity. - + + * rewrite <- ror_opt_cnf_cnf. destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). intros. reflexivity. Qed. - - - Lemma rxcnf_iff_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 935757f30a..1616b5a2a4 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -296,6 +296,9 @@ Qed. Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. Declare Equivalent Keys psub RingMicromega.psub. +Definition popp := popp Z.opp. +Declare Equivalent Keys popp RingMicromega.popp. + Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. @@ -608,16 +611,18 @@ Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof +| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof | ExProof : positive -> ZArithProof -> ZArithProof (*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) . -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) + Register ZArithProof as micromega.ZArithProof.type. Register DoneProof as micromega.ZArithProof.DoneProof. Register RatProof as micromega.ZArithProof.RatProof. Register CutProof as micromega.ZArithProof.CutProof. +Register SplitProof as micromega.ZArithProof.SplitProof. Register EnumProof as micromega.ZArithProof.EnumProof. Register ExProof as micromega.ZArithProof.ExProof. @@ -1042,13 +1047,14 @@ Fixpoint max_var_prf (w : ZArithProof) : positive := match w with | DoneProof => xH | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf) - | EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l - (Pos.max (max_var_psatz w1) (max_var_psatz w2)) + | SplitProof p pf1 pf2 => Pos.max (max_var xH p) (Pos.max (max_var_prf pf1) (max_var_prf pf1)) + | EnumProof w1 w2 l => List.fold_left + (fun acc prf => Pos.max acc (max_var_prf prf)) l + (Pos.max (max_var_psatz w1) (max_var_psatz w2)) | ExProof _ pf => max_var_prf pf end. - Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false @@ -1068,6 +1074,14 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end + | SplitProof p pf1 pf2 => + match genCuttingPlane (p,NonStrict) , genCuttingPlane (popp p, NonStrict) with + | None , _ | _ , None => false + | Some cp1 , Some cp2 => + ZChecker (nformula_of_cutting_plane cp1::l) pf1 + && + ZChecker (nformula_of_cutting_plane cp2::l) pf2 + end | ExProof x prf => let fr := max_var_nformulae l in if Pos.leb x fr then @@ -1105,6 +1119,7 @@ Fixpoint bdepth (pf : ZArithProof) : nat := | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) + | SplitProof _ p1 p2 => S (Nat.max (bdepth p1) (bdepth p2)) | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) | ExProof _ p => S (bdepth p) end. @@ -1140,6 +1155,26 @@ Proof. apply Nat.le_max_r. Qed. +Lemma ltof_bdepth_split_l : + forall p pf1 pf2, + ltof ZArithProof bdepth pf1 (SplitProof p pf1 pf2). +Proof. + intros. + unfold ltof. simpl. + rewrite Nat.lt_succ_r. + apply Nat.le_max_l. +Qed. + +Lemma ltof_bdepth_split_r : + forall p pf1 pf2, + ltof ZArithProof bdepth pf2 (SplitProof p pf1 pf2). +Proof. + intros. + unfold ltof. simpl. + rewrite Nat.lt_succ_r. + apply Nat.le_max_r. +Qed. + Lemma eval_Psatz_sound : forall env w l f', make_conj (eval_nformula env) l -> @@ -1470,11 +1505,23 @@ Ltac pos_tac := apply (Pos2Z.pos_le_pos X Y) in H end. +Lemma eval_nformula_split : forall env p, + eval_nformula env (p,NonStrict) \/ eval_nformula env (popp p,NonStrict). +Proof. + unfold popp. + simpl. intros. rewrite (eval_pol_opp Zsor ZSORaddon). + rewrite Z.opp_nonneg_nonpos. + apply Z.le_ge_cases. +Qed. + + + + Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w as [ | w pf | w pf | w1 w2 pf | x pf]. + destruct w as [ | w pf | w pf | p pf1 pf2 | w1 w2 pf | x pf]. - (* DoneProof *) simpl. discriminate. - (* RatProof *) @@ -1527,6 +1574,26 @@ Proof. intros. apply eval_Psatz_sound with (2:= Hlc) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. + - (* SplitProof *) + intros l. + cbn - [genCuttingPlane]. + case_eq (genCuttingPlane (p, NonStrict)) ; [| discriminate]. + case_eq (genCuttingPlane (popp p, NonStrict)) ; [| discriminate]. + intros cp1 GCP1 cp2 GCP2 ZC1 env. + flatten_bool. + destruct (eval_nformula_split env p). + + apply H with (env:=env) in H0. + rewrite <- make_conj_impl in *. + intro ; apply H0. + rewrite make_conj_cons. split; auto. + apply cutting_plane_sound with (f:= (p,NonStrict)) ; auto. + apply ltof_bdepth_split_l. + + apply H with (env:=env) in H1. + rewrite <- make_conj_impl in *. + intro ; apply H1. + rewrite make_conj_cons. split; auto. + apply cutting_plane_sound with (f:= (popp p,NonStrict)) ; auto. + apply ltof_bdepth_split_r. - (* EnumProof *) intros l. simpl. @@ -1758,6 +1825,7 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt + | SplitProof p pt1 pt2 => xhyps_of_pt (S base) (xhyps_of_pt (S base) acc pt1) pt2 | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index d1cefeb552..d8eb005ab2 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -335,19 +335,19 @@ Reserved Notation "[ 'predType' 'of' T ]" (at level 0, Reserved Notation "[ 'pred' : T | E ]" (at level 0, format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x | E ]" (at level 0, x name, format "'[hv' [ 'pred' x | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x name, format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). -Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). -Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x name, format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, @@ -363,17 +363,17 @@ Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). -Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x name, y name, format "'[hv' [ 'rel' x y 'in' A ] ']'"). Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). @@ -1944,7 +1944,121 @@ Proof. by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. Qed. +Lemma in_on1P : {in D1, {on D2, allQ1 f}} <-> + {in [pred x in D1 | f x \in D2], allQ1 f}. +Proof. +split => allf x; have := allf x; rewrite inE => Q1f; first by case/andP. +by move=> ? ?; apply: Q1f; apply/andP. +Qed. + +Lemma in_on1lP : {in D1, {on D2, allQ1l f & h}} <-> + {in [pred x in D1 | f x \in D2], allQ1l f h}. +Proof. +split => allf x; have := allf x; rewrite inE => Q1f; first by case/andP. +by move=> ? ?; apply: Q1f; apply/andP. +Qed. + +Lemma in_on2P : {in D1 &, {on D2 &, allQ2 f}} <-> + {in [pred x in D1 | f x \in D2] &, allQ2 f}. +Proof. +split => allf x y; have := allf x y; rewrite !inE => Q2f. + by move=> /andP[? ?] /andP[? ?]; apply: Q2f. +by move=> ? ? ? ?; apply: Q2f; apply/andP. +Qed. + +Lemma on1W_in : {in D1, allQ1 f} -> {in D1, {on D2, allQ1 f}}. +Proof. by move=> D1f ? /D1f. Qed. + +Lemma on1lW_in : {in D1, allQ1l f h} -> {in D1, {on D2, allQ1l f & h}}. +Proof. by move=> D1f ? /D1f. Qed. + +Lemma on2W_in : {in D1 &, allQ2 f} -> {in D1 &, {on D2 &, allQ2 f}}. +Proof. by move=> D1f ? ? ? ? ? ?; apply: D1f. Qed. + +Lemma in_on1W : allQ1 f -> {in D1, {on D2, allQ1 f}}. +Proof. by move=> allf ? ? ?; apply: allf. Qed. + +Lemma in_on1lW : allQ1l f h -> {in D1, {on D2, allQ1l f & h}}. +Proof. by move=> allf ? ? ?; apply: allf. Qed. + +Lemma in_on2W : allQ2 f -> {in D1 &, {on D2 &, allQ2 f}}. +Proof. by move=> allf ? ? ? ? ? ?; apply: allf. Qed. + +Lemma on1S : (forall x, f x \in D2) -> {on D2, allQ1 f} -> allQ1 f. +Proof. by move=> ? fD1 ?; apply: fD1. Qed. + +Lemma on1lS : (forall x, f x \in D2) -> {on D2, allQ1l f & h} -> allQ1l f h. +Proof. by move=> ? fD1 ?; apply: fD1. Qed. + +Lemma on2S : (forall x, f x \in D2) -> {on D2 &, allQ2 f} -> allQ2 f. +Proof. by move=> ? fD1 ? ?; apply: fD1. Qed. + +Lemma on1S_in : {homo f : x / x \in D1 >-> x \in D2} -> + {in D1, {on D2, allQ1 f}} -> {in D1, allQ1 f}. +Proof. by move=> fD fD1 ? ?; apply/fD1/fD. Qed. + +Lemma on1lS_in : {homo f : x / x \in D1 >-> x \in D2} -> + {in D1, {on D2, allQ1l f & h}} -> {in D1, allQ1l f h}. +Proof. by move=> fD fD1 ? ?; apply/fD1/fD. Qed. + +Lemma on2S_in : {homo f : x / x \in D1 >-> x \in D2} -> + {in D1 &, {on D2 &, allQ2 f}} -> {in D1 &, allQ2 f}. +Proof. by move=> fD fD1 ? ? ? ?; apply: fD1 => //; apply: fD. Qed. + +Lemma in_on1S : (forall x, f x \in D2) -> {in T1, {on D2, allQ1 f}} -> allQ1 f. +Proof. by move=> fD2 fD1 ?; apply: fD1. Qed. + +Lemma in_on1lS : (forall x, f x \in D2) -> + {in T1, {on D2, allQ1l f & h}} -> allQ1l f h. +Proof. by move=> fD2 fD1 ?; apply: fD1. Qed. + +Lemma in_on2S : (forall x, f x \in D2) -> + {in T1 &, {on D2 &, allQ2 f}} -> allQ2 f. +Proof. by move=> fD2 fD1 ? ?; apply: fD1. Qed. + End LocalGlobal. +Arguments in_on1P {T1 T2 D1 D2 f Q1}. +Arguments in_on1lP {T1 T2 T3 D1 D2 f h Q1l}. +Arguments in_on2P {T1 T2 D1 D2 f Q2}. +Arguments on1W_in {T1 T2 D1} D2 {f Q1}. +Arguments on1lW_in {T1 T2 T3 D1} D2 {f h Q1l}. +Arguments on2W_in {T1 T2 D1} D2 {f Q2}. +Arguments in_on1W {T1 T2} D1 D2 {f Q1}. +Arguments in_on1lW {T1 T2 T3} D1 D2 {f h Q1l}. +Arguments in_on2W {T1 T2} D1 D2 {f Q2}. +Arguments on1S {T1 T2} D2 {f Q1}. +Arguments on1lS {T1 T2 T3} D2 {f h Q1l}. +Arguments on2S {T1 T2} D2 {f Q2}. +Arguments on1S_in {T1 T2 D1} D2 {f Q1}. +Arguments on1lS_in {T1 T2 T3 D1} D2 {f h Q1l}. +Arguments on2S_in {T1 T2 D1} D2 {f Q2}. +Arguments in_on1S {T1 T2} D2 {f Q1}. +Arguments in_on1lS {T1 T2 T3} D2 {f h Q1l}. +Arguments in_on2S {T1 T2} D2 {f Q2}. + +Section in_sig. + +Variables T1 T2 T3 : Type. +Variables (D1 : {pred T1}) (D2 : {pred T2}) (D3 : {pred T3}). +Variable P1 : T1 -> Prop. +Variable P2 : T1 -> T2 -> Prop. +Variable P3 : T1 -> T2 -> T3 -> Prop. + +Lemma in1_sig : {in D1, {all1 P1}} -> forall x : sig D1, P1 (sval x). +Proof. by move=> DP [x Dx]; have := DP _ Dx. Qed. + +Lemma in2_sig : {in D1 & D2, {all2 P2}} -> + forall (x : sig D1) (y : sig D2), P2 (sval x) (sval y). +Proof. by move=> DP [x Dx] [y Dy]; have := DP _ _ Dx Dy. Qed. + +Lemma in3_sig : {in D1 & D2 & D3, {all3 P3}} -> + forall (x : sig D1) (y : sig D2) (z : sig D3), P3 (sval x) (sval y) (sval z). +Proof. by move=> DP [x Dx] [y Dy] [z Dz]; have := DP _ _ _ Dx Dy Dz. Qed. + +End in_sig. +Arguments in1_sig {T1 D1 P1}. +Arguments in2_sig {T1 T2 D1 D2 P2}. +Arguments in3_sig {T1 T2 T3 D1 D2 D3 P3}. Lemma sub_in2 T d d' (P : T -> T -> Prop) : sub_mem d d' -> forall Ph : ph {all2 P}, prop_in2 d' Ph -> prop_in2 d Ph. diff --git a/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v index d0508bef2e..db572d25d8 100644 --- a/theories/ssr/ssreflect.v +++ b/theories/ssr/ssreflect.v @@ -110,7 +110,7 @@ Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, c, R, vT, vF at level 200). Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, - c, R, vT, vF at level 200, x ident). + c, R, vT, vF at level 200, x name). Reserved Notation "x : T" (at level 100, right associativity, format "'[hv' x '/ ' : T ']'"). @@ -671,43 +671,32 @@ Module Export ipat. Notation "'[' 'apply' ']'" := (ltac:(let f := fresh "_top_" in move=> f {}/f)) (at level 0, only parsing) : ssripat_scope. -(** We try to preserve the naming by matching the names from the goal. - We do 'move' to perform a hnf before trying to match. **) +(* we try to preserve the naming by matching the names from the goal *) +(* we do move to perform a hnf before trying to match *) Notation "'[' 'swap' ']'" := (ltac:(move; - lazymatch goal with - | |- forall (x : _), _ => let x := fresh x in move=> x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - | |- let x := _ in _ => let x := fresh x in move => x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - | _ => let x := fresh "_top_" in let x := fresh x in move=> x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - end)) + let x := lazymatch goal with + | |- forall (x : _), _ => fresh x | |- let x := _ in _ => fresh x | _ => fresh "_top_" + end in intro x; move; + let y := lazymatch goal with + | |- forall (y : _), _ => fresh y | |- let y := _ in _ => fresh y | _ => fresh "_top_" + end in intro y; revert x; revert y)) (at level 0, only parsing) : ssripat_scope. + +(* we try to preserve the naming by matching the names from the goal *) +(* we do move to perform a hnf before trying to match *) Notation "'[' 'dup' ']'" := (ltac:(move; lazymatch goal with | |- forall (x : _), _ => - let x := fresh x in move=> x; - let copy := fresh x in have copy := x; move: copy x + let x := fresh x in intro x; + let copy := fresh x in have copy := x; revert x; revert copy | |- let x := _ in _ => - let x := fresh x in move=> x; + let x := fresh x in intro x; let copy := fresh x in pose copy := x; - do [unfold x in (value of copy)]; move: @copy @x + do [unfold x in (value of copy)]; revert x; revert copy | |- _ => let x := fresh "_top_" in move=> x; - let copy := fresh "_top" in have copy := x; move: copy x + let copy := fresh "_top" in have copy := x; revert x; revert copy end)) (at level 0, only parsing) : ssripat_scope. diff --git a/theories/ssr/ssrfun.v b/theories/ssr/ssrfun.v index e1442e1da2..ba66e04e4a 100644 --- a/theories/ssr/ssrfun.v +++ b/theories/ssr/ssrfun.v @@ -236,19 +236,19 @@ Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). Reserved Notation "[ 'fun' : T => E ]" (at level 0, format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). + x name, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x : T => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). + x name, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). + x name, y name, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, - x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + x name, y name, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). Reserved Notation "f =1 g" (at level 70, no associativity). Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). @@ -259,33 +259,33 @@ Reserved Notation "f \; g" (at level 60, right associativity, format "f \; '/ ' g"). Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a >-> r }"). + x name, format "{ 'morph' f : x / a >-> r }"). Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a }"). + x name, format "{ 'morph' f : x / a }"). Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). + x name, y name, format "{ 'morph' f : x y / a >-> r }"). Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a }"). + x name, y name, format "{ 'morph' f : x y / a }"). Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a >-> r }"). + x name, format "{ 'homo' f : x / a >-> r }"). Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a }"). + x name, format "{ 'homo' f : x / a }"). Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). + x name, y name, format "{ 'homo' f : x y / a >-> r }"). Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a }"). + x name, y name, format "{ 'homo' f : x y / a }"). Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y /~ a }"). + x name, y name, format "{ 'homo' f : x y /~ a }"). Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a >-> r }"). + x name, format "{ 'mono' f : x / a >-> r }"). Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a }"). + x name, format "{ 'mono' f : x / a }"). Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). + x name, y name, format "{ 'mono' f : x y / a >-> r }"). Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a }"). + x name, y name, format "{ 'mono' f : x y / a }"). Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y /~ a }"). + x name, y name, format "{ 'mono' f : x y /~ a }"). Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 0cbfd46e80..07550b67e3 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -216,7 +216,7 @@ let generate_conf_coq_config oc = section oc "Coq configuration."; let src_dirs = Coq_config.all_src_dirs in Envars.print_config ~prefix_var_name:"COQMF_" oc src_dirs; - fprintf oc "COQMF_WINDRIVE=%s\n" (windrive Coq_config.coqlib) + fprintf oc "COQMF_WINDRIVE=%s\n" (windrive (Envars.coqlib())) ;; let generate_conf_files oc diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index ec339c69c6..fbf3b4873b 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -261,6 +261,7 @@ let get_native_name s = with _ -> "" let get_compat_file = function + | "8.14" -> "Coq.Compat.Coq814" | "8.13" -> "Coq.Compat.Coq813" | "8.12" -> "Coq.Compat.Coq812" | "8.11" -> "Coq.Compat.Coq811" diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index 1ec55c78c3..59e10b09a0 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -8,13 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let rec parse = function - | "--xml_format=Ppcmds" :: rest -> parse rest - | x :: rest -> x :: parse rest - | [] -> [] - let worker_parse_extra ~opts extra_args = - (), parse extra_args + (), extra_args let worker_init init () ~opts = Flags.quiet := true; diff --git a/user-contrib/Ltac2/Ltac1.v b/user-contrib/Ltac2/Ltac1.v index 1a69708a7d..fd1555c2fb 100644 --- a/user-contrib/Ltac2/Ltac1.v +++ b/user-contrib/Ltac2/Ltac1.v @@ -25,6 +25,12 @@ Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". (** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning anything. *) +Ltac2 @ external lambda : (t -> t) -> t := "ltac2" "ltac1_lambda". +(** Embed an Ltac2 function into Ltac1 values. Contrarily to the ltac1:(...) + quotation, this function allows both to capture an Ltac2 context inside the + closure and to return an Ltac1 value. Returning values in Ltac1 is a + intrepid endeavour prone to weird runtime semantics. *) + Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". (** Applies an Ltac1 value to a list of arguments, and provides the result in CPS style. It does **not** run the returned value. *) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 5d49d1635c..8663691c0a 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1100,7 +1100,7 @@ let interp_constr flags ist c = let () = let intern = intern_constr in let interp ist c = interp_constr constr_flags ist c in - let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let print env sigma c = str "constr:(" ++ Printer.pr_lglob_constr_env env sigma c ++ str ")" in let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { ml_intern = intern; @@ -1113,7 +1113,7 @@ let () = let () = let intern = intern_constr in let interp ist c = interp_constr open_constr_no_classes_flags ist c in - let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let print env sigma c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env sigma c ++ str ")" in let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { ml_intern = intern; @@ -1125,7 +1125,7 @@ let () = let () = let interp _ id = return (Value.of_ident id) in - let print _ id = str "ident:(" ++ Id.print id ++ str ")" in + let print _ _ id = str "ident:(" ++ Id.print id ++ str ")" in let obj = { ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); ml_interp = interp; @@ -1147,7 +1147,7 @@ let () = let sigma = Evd.from_env env in Patternops.subst_pattern env sigma subst c in - let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in + let print env sigma pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env sigma pat ++ str ")" in let interp _ c = return (Value.of_pattern c) in let obj = { ml_intern = intern; @@ -1169,7 +1169,7 @@ let () = return (Value.of_ext val_preterm c) in let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in - let print env c = str "preterm:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let print env sigma c = str "preterm:(" ++ Printer.pr_lglob_constr_env env sigma c ++ str ")" in let obj = { ml_intern = (fun _ _ e -> Empty.abort e); ml_interp = interp; @@ -1193,7 +1193,7 @@ let () = in let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in - let print _ = function + let print _ _ = function | GlobRef.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" in @@ -1241,7 +1241,7 @@ let () = return (Tac2ffi.of_closure (Tac2ffi.abstract len clos)) in let subst s (ids, tac) = (ids, Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac) in - let print env (ids, tac) = + let print env sigma (ids, tac) = let ids = if List.is_empty ids then mt () else pr_sequence Id.print ids ++ spc () ++ str "|-" ++ spc () @@ -1290,7 +1290,7 @@ let () = return (Tac2ffi.of_closure (Tac2ffi.abstract len clos)) in let subst s (ids, tac) = (ids, Genintern.substitute Tacarg.wit_tactic s tac) in - let print env (ids, tac) = + let print env sigma (ids, tac) = let ids = if List.is_empty ids then mt () else pr_sequence Id.print ids ++ str " |- " @@ -1365,10 +1365,44 @@ let () = let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (Some "ltac2", in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) -(* Ltac1 runtime representation of Ltac2 closure quotations *) -let typ_ltac2 : (Id.t list * glb_tacexpr) Geninterp.Val.typ = +(* Ltac1 runtime representation of Ltac2 closures. *) +let typ_ltac2 : valexpr Geninterp.Val.typ = Geninterp.Val.create "ltac2:ltac2_eval" +let cast_typ (type a) (tag : a Geninterp.Val.typ) (v : Geninterp.Val.t) : a = + let Geninterp.Val.Dyn (tag', v) = v in + match Geninterp.Val.eq tag tag' with + | None -> assert false + | Some Refl -> v + +let () = + let open Ltac_plugin in + (* This is a hack similar to Tacentries.ml_val_tactic_extend *) + let intern_fun _ e = Empty.abort e in + let subst_fun s v = v in + let () = Genintern.register_intern0 wit_ltac2_val intern_fun in + let () = Genintern.register_subst0 wit_ltac2_val subst_fun in + (* These are bound names and not relevant *) + let tac_id = Id.of_string "F" in + let arg_id = Id.of_string "X" in + let interp_fun ist () = + let tac = cast_typ typ_ltac2 @@ Id.Map.get tac_id ist.Tacinterp.lfun in + let arg = Id.Map.get arg_id ist.Tacinterp.lfun in + let tac = Tac2ffi.to_closure tac in + Tac2ffi.apply tac [of_ltac1 arg] >>= fun ans -> + let ans = Tac2ffi.to_ext val_ltac1 ans in + Ftactic.return ans + in + let () = Geninterp.register_interp0 wit_ltac2_val interp_fun in + define1 "ltac1_lambda" valexpr begin fun f -> + let body = Tacexpr.TacGeneric (Some "ltac2", in_gen (glbwit wit_ltac2_val) ()) in + let clos = Tacexpr.TacFun ([Name arg_id], Tacexpr.TacArg (CAst.make body)) in + let f = Geninterp.Val.inject (Geninterp.Val.Base typ_ltac2) f in + let lfun = Id.Map.singleton tac_id f in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun } in + Proofview.tclUNIT (of_ltac1 (Tacinterp.Value.of_closure ist clos)) + end + let ltac2_eval = let open Ltac_plugin in let ml_name = { @@ -1380,17 +1414,10 @@ let ltac2_eval = | tac :: args -> (* By convention the first argument is the tactic being applied, the rest being the arguments it should be fed with *) - let Geninterp.Val.Dyn (tag, tac) = tac in - let (ids, tac) : Id.t list * glb_tacexpr = match Geninterp.Val.eq tag typ_ltac2 with - | None -> assert false - | Some Refl -> tac - in - let fold accu id = match Id.Map.find id ist.Geninterp.lfun with - | v -> Id.Map.add id (Tac2ffi.of_ext val_ltac1 v) accu - | exception Not_found -> assert false - in - let env_ist = List.fold_left fold Id.Map.empty ids in - Proofview.tclIGNORE (Tac2interp.interp { env_ist } tac) + let tac = cast_typ typ_ltac2 tac in + let tac = Tac2ffi.to_closure tac in + let args = List.map (fun arg -> Tac2ffi.of_ext val_ltac1 arg) args in + Proofview.tclIGNORE (Tac2ffi.apply tac args) in let () = Tacenv.register_ml_tactic ml_name [|eval_fun|] in { Tacexpr.mltac_name = ml_name; mltac_index = 0 } @@ -1398,7 +1425,7 @@ let ltac2_eval = let () = let open Ltac_plugin in let open Tacinterp in - let interp ist (ids, tac as self) = match ids with + let interp ist (ids, tac) = match ids with | [] -> (* Evaluate the Ltac2 quotation eagerly *) let idtac = Value.of_closure { ist with lfun = Id.Map.empty } (Tacexpr.TacId []) in @@ -1413,6 +1440,8 @@ let () = let mk_arg id = Tacexpr.Reference (Locus.ArgVar (CAst.make id)) in let args = List.map mk_arg ids in let clos = Tacexpr.TacFun (nas, Tacexpr.TacML (CAst.make (ltac2_eval, mk_arg self_id :: args))) in + let self = GTacFun (List.map (fun id -> Name id) ids, tac) in + let self = Tac2interp.interp_value { env_ist = Id.Map.empty } self in let self = Geninterp.Val.inject (Geninterp.Val.Base typ_ltac2) self in let ist = { ist with lfun = Id.Map.singleton self_id self } in Ftactic.return (Value.of_closure ist clos) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index eebd6635fa..d0655890a7 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -853,8 +853,10 @@ let pr_frame = function str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" | FrExtn (tag, arg) -> let obj = Tac2env.interp_ml_object tag in + let env = Global.env () in + let sigma = Evd.from_env env in str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ - obj.Tac2env.ml_print (Global.env ()) arg + obj.Tac2env.ml_print env sigma arg let () = register_handler begin function | Tac2interp.LtacError (kn, args) -> diff --git a/user-contrib/Ltac2/tac2env.ml b/user-contrib/Ltac2/tac2env.ml index 6c2133f8f2..5479ba0d54 100644 --- a/user-contrib/Ltac2/tac2env.ml +++ b/user-contrib/Ltac2/tac2env.ml @@ -253,7 +253,7 @@ type ('a, 'b) ml_object = { ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; + ml_print : Environ.env -> Evd.evar_map -> 'b -> Pp.t; } module MLTypeObj = @@ -288,7 +288,8 @@ let ltac1_prefix = (** Generic arguments *) -let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2 = Genarg.make0 "ltac2:tactic" +let wit_ltac2_val = Genarg.make0 "ltac2:value" let wit_ltac2_constr = Genarg.make0 "ltac2:in-constr" let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" let () = Geninterp.register_val0 wit_ltac2 None diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli index 2468959810..95dcdd7e1b 100644 --- a/user-contrib/Ltac2/tac2env.mli +++ b/user-contrib/Ltac2/tac2env.mli @@ -122,7 +122,7 @@ type ('a, 'b) ml_object = { ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; + ml_print : Environ.env -> Evd.evar_map -> 'b -> Pp.t; } val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit @@ -144,6 +144,10 @@ val ltac1_prefix : ModPath.t val wit_ltac2 : (Id.t CAst.t list * raw_tacexpr, Id.t list * glb_tacexpr, Util.Empty.t) genarg_type (** Ltac2 quotations in Ltac1 code *) +val wit_ltac2_val : (Util.Empty.t, unit, Util.Empty.t) genarg_type +(** Embedding Ltac2 closures of type [Ltac1.t -> Ltac1.t] inside Ltac1. There is + no relevant data because arguments are passed by conventional names. *) + val wit_ltac2_constr : (raw_tacexpr, Id.Set.t * glb_tacexpr, Util.Empty.t) genarg_type (** Ltac2 quotations in Gallina terms *) diff --git a/user-contrib/Ltac2/tac2interp.ml b/user-contrib/Ltac2/tac2interp.ml index ed783afce7..8027a22e01 100644 --- a/user-contrib/Ltac2/tac2interp.ml +++ b/user-contrib/Ltac2/tac2interp.ml @@ -223,6 +223,8 @@ and eval_pure_args bnd args = let map e = eval_pure bnd None e in Array.map_of_list map args +let interp_value ist tac = + eval_pure ist.env_ist None tac (** Cross-boundary hacks. *) diff --git a/user-contrib/Ltac2/tac2interp.mli b/user-contrib/Ltac2/tac2interp.mli index e466c65224..ae7b2ea86d 100644 --- a/user-contrib/Ltac2/tac2interp.mli +++ b/user-contrib/Ltac2/tac2interp.mli @@ -18,6 +18,9 @@ val empty_environment : environment val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic +val interp_value : environment -> glb_tacexpr -> valexpr +(** Same as [interp] but assumes that the argument is a syntactic value. *) + (* val interp_app : closure -> ml_tactic *) (** {5 Cross-boundary encodings} *) diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml index a37fe2f7a5..fe62de1fb3 100644 --- a/user-contrib/Ltac2/tac2print.ml +++ b/user-contrib/Ltac2/tac2print.ml @@ -274,7 +274,9 @@ let pr_glbexpr_gen lvl c = paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) | GTacExt (tag, arg) -> let tpe = interp_ml_object tag in - hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) + let env = Global.env() in + let sigma = Evd.from_env env in + hov 0 (tpe.ml_print env sigma arg) (* FIXME *) | GTacPrm (prm, args) -> let args = match args with | [] -> mt () diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 9ca38d64df..69758b3f37 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -106,7 +106,7 @@ let apply adv ev cb cl = | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb | Some (id, cl) -> let cl = Option.map mk_intro_pattern cl in - Tactics.apply_delayed_in adv ev id cb cl + Tactics.apply_delayed_in adv ev id cb cl Tacticals.New.tclIDTAC let mk_destruction_arg = function | ElimOnConstr c -> diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 848cd501c6..792f07bb89 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -165,6 +165,28 @@ let label_of = let open GlobRef in function | ConstructRef ((kn,_),_) -> MutInd.label kn | VarRef id -> Label.of_id id +let fold_with_full_binders g f n acc c = + let open Context.Rel.Declaration in + match kind c with + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (_,c) -> f n acc c + | Evar (_,l) -> List.fold_left (f n) acc l + | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | Array(_u,t,def,ty) -> f n (f n (Array.fold_left (f n) acc t) def) ty + let rec traverse current ctx accu t = let open GlobRef in match Constr.kind t with @@ -189,10 +211,10 @@ let rec traverse current ctx accu t = traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) | _ -> - Constr.fold_with_full_binders + fold_with_full_binders Context.Rel.add (traverse current) ctx accu t end -| _ -> Constr.fold_with_full_binders +| _ -> fold_with_full_binders Context.Rel.add (traverse current) ctx accu t and traverse_object ?inhabits (curr, data, ax2ty) body obj = diff --git a/vernac/attributes.ml b/vernac/attributes.ml index fdaeedef8c..37895d22f5 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -338,3 +338,47 @@ let uses_parser : string key_parser = fun orig args -> | _ -> CErrors.user_err (Pp.str "Ill formed \"using\" attribute") let using = attribute_of_list ["using",uses_parser] + +let process_typing_att ~typing_flags att disable = + let enable = not disable in + match att with + | "universes" -> + { typing_flags with + Declarations.check_universes = enable + } + | "guard" -> + { typing_flags with + Declarations.check_guarded = enable + } + | "positivity" -> + { typing_flags with + Declarations.check_positive = enable + } + | att -> + CErrors.user_err Pp.(str "Unknown “typing” attribute: " ++ str att) + +let process_typing_disable ~key = function + | VernacFlagEmpty | VernacFlagLeaf (FlagIdent "yes") -> + true + | VernacFlagLeaf (FlagIdent "no") -> + false + | _ -> + CErrors.user_err Pp.(str "Ill-formed attribute value, must be " ++ str key ++ str "={yes, no}") + +let typing_flags_parser : Declarations.typing_flags key_parser = fun orig args -> + let rec flag_parser typing_flags = function + | [] -> typing_flags + | (typing_att, enable) :: rest -> + let disable = process_typing_disable ~key:typing_att enable in + let typing_flags = process_typing_att ~typing_flags typing_att disable in + flag_parser typing_flags rest + in + match args with + | VernacFlagList atts -> + let typing_flags = Global.typing_flags () in + flag_parser typing_flags atts + | att -> + CErrors.user_err Pp.(str "Ill-formed “typing” attribute: " ++ pr_vernac_flag_value att) + +let typing_flags = + attribute_of_list ["bypass_check", typing_flags_parser] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 03a14a03ff..584e13e781 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -59,6 +59,9 @@ val canonical_field : bool attribute val canonical_instance : bool attribute val using : string option attribute +(** Enable/Disable universe checking *) +val typing_flags : Declarations.typing_flags option attribute + val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index adf1f42beb..a21af12785 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -223,10 +223,10 @@ let vernac_arguments ~section_local reference args more_implicits flags = | _ -> true in if implicits_specified && clear_implicits_flag then - CErrors.user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); + CErrors.user_err Pp.(str "The \"clear implicits\" flag must be omitted if implicit annotations are given."); if implicits_specified && default_implicits_flag then - CErrors.user_err Pp.(str "The \"default implicits\" flag is incompatible with implicit annotations"); + CErrors.user_err Pp.(str "The \"default implicits\" flag is incompatible with implicit annotations."); let rargs = Util.List.map_filter (function (n, true) -> Some n | _ -> None) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 9e850ff1c7..f8f2193e03 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -257,9 +257,10 @@ let context ~poly l = let sigma = Evd.from_env env in let sigma, (_, ((_env, ctx), impls)) = interp_context_evars ~program_mode:false env sigma l in (* Note, we must use the normalized evar from now on! *) - let sigma = Evd.minimize_universes sigma in let ce t = Pretyping.check_evars env sigma t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) ctx in + let sigma, ctx = Evarutil.finalize ~abort_on_undefined_evars:false + sigma (fun nf -> List.map (RelDecl.map_constr_het nf) ctx) in (* reorder, evar-normalize and add implicit status *) let ctx = List.rev_map (fun d -> let {binder_name=name}, b, t = RelDecl.to_tuple d in @@ -267,8 +268,6 @@ let context ~poly l = | Anonymous -> user_err Pp.(str "Anonymous variables not allowed in contexts.") | Name id -> id in - let b = Option.map (EConstr.to_constr sigma) b in - let t = EConstr.to_constr sigma t in let impl = let open Glob_term in let search x = match x.CAst.v with | Some (Name id',max) when Id.equal name id' -> diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 81154bbea9..c54adb45f9 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -110,9 +110,10 @@ let interp_definition ~program_mode env evd impl_env bl red_option c ctypopt = let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in evd, (c, tyopt), imps -let do_definition ?hook ~name ~scope ~poly ~kind ?using udecl bl red_option c ctypopt = +let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl red_option c ctypopt = let program_mode = false in let env = Global.env() in + let env = Environ.update_typing_flags ?typing_flags env in (* Explicitly bound universes and constraints *) let evd, udecl = interp_univ_decl_opt env udecl in let evd, (body, types), impargs = @@ -125,14 +126,15 @@ let do_definition ?hook ~name ~scope ~poly ~kind ?using udecl bl red_option c ct in let kind = Decls.IsDefinition kind in let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types ?using () in - let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly () in + let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly ?typing_flags () in let _ : Names.GlobRef.t = Declare.declare_definition ~info ~cinfo ~opaque:false ~body evd in () -let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind ?using udecl bl red_option c ctypopt = +let do_definition_program ?hook ~pm ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl red_option c ctypopt = let program_mode = true in let env = Global.env() in + let env = Environ.update_typing_flags ?typing_flags env in (* Explicitly bound universes and constraints *) let evd, udecl = interp_univ_decl_opt env udecl in let evd, (body, types), impargs = @@ -146,6 +148,6 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind ?using udecl bl red let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in let pm, _ = let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in - let info = Declare.Info.make ~udecl ~scope ~poly ~kind ?hook () in + let info = Declare.Info.make ~udecl ~scope ~poly ~kind ?hook ?typing_flags () in Declare.Obls.add_definition ~pm ~cinfo ~info ~term ~uctx obls in pm diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 5e1b705ae4..9962e44098 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -30,6 +30,7 @@ val do_definition -> name:Id.t -> scope:Locality.locality -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> kind:Decls.definition_object_kind -> ?using:Vernacexpr.section_subset_expr -> universe_decl_expr option @@ -45,6 +46,7 @@ val do_definition_program -> name:Id.t -> scope:Locality.locality -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> kind:Decls.logical_kind -> ?using:Vernacexpr.section_subset_expr -> universe_decl_expr option diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index dd6c985bf9..0cf0b07822 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -158,10 +158,9 @@ type ('constr, 'types) recursive_preentry = let fix_proto sigma = Evarutil.new_global sigma (Coqlib.lib_ref "program.tactic.fix_proto") -let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen list) = +let interp_recursive env ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen list) = let open Context.Named.Declaration in let open EConstr in - let env = Global.env() in let fixnames = List.map (fun fix -> fix.Vernacexpr.fname.CAst.v) fixl in (* Interp arities allowing for unresolved types *) @@ -241,11 +240,13 @@ let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) (* XXX: Unify with interp_recursive *) -let interp_fixpoint ?(check_recursivity=true) ~cofix l : +let interp_fixpoint ?(check_recursivity=true) ?typing_flags ~cofix l : ( (Constr.t, Constr.types) recursive_preentry * UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list) = - let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in + let env = Global.env () in + let env = Environ.update_typing_flags ?typing_flags env in + let (env,_,pl,evd),fix,info = interp_recursive env ~program_mode:false ~cofix l in if check_recursivity then check_recursive true env evd fix; let evd = Pretyping.(solve_remaining_evars all_no_fail_flags env evd) in let uctx,fix = ground_fixpoint env evd fix in @@ -271,12 +272,12 @@ let build_recthms ~indexes ?using fixnames fixtypes fiximps = in fix_kind, cofix, thms -let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = +let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ?typing_flags ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = let fix_kind, cofix, thms = build_recthms ~indexes fixnames fixtypes fiximps in let indexes = Option.default [] indexes in let init_terms = Some fixdefs in let evd = Evd.from_ctx ctx in - let info = Declare.Info.make ~poly ~scope ~kind:(Decls.IsDefinition fix_kind) ~udecl () in + let info = Declare.Info.make ~poly ~scope ~kind:(Decls.IsDefinition fix_kind) ~udecl ?typing_flags () in let lemma = Declare.Proof.start_mutual_with_initialization ~info evd ~mutual_info:(cofix,indexes,init_terms) ~cinfo:thms None in @@ -284,13 +285,13 @@ let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; lemma -let declare_fixpoint_generic ?indexes ~scope ~poly ?using ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = +let declare_fixpoint_generic ?indexes ~scope ~poly ?typing_flags ?using ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = (* We shortcut the proof process *) let fix_kind, cofix, fixitems = build_recthms ~indexes ?using fixnames fixtypes fiximps in let fixdefs = List.map Option.get fixdefs in let rec_declaration = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fix_kind = Decls.IsDefinition fix_kind in - let info = Declare.Info.make ~scope ~kind:fix_kind ~poly ~udecl () in + let info = Declare.Info.make ~scope ~kind:fix_kind ~poly ~udecl ?typing_flags () in let cinfo = fixitems in let _ : GlobRef.t list = Declare.declare_mutually_recursive ~cinfo ~info ~opaque:false ~uctx @@ -322,22 +323,22 @@ let adjust_rec_order ~structonly binders rec_order = in Option.map (extract_decreasing_argument ~structonly) rec_order -let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = +let do_fixpoint_common ?typing_flags (fixl : Vernacexpr.fixpoint_expr list) = let fixl = List.map (fun fix -> Vernacexpr.{ fix with rec_order = adjust_rec_order ~structonly:true fix.binders fix.rec_order }) fixl in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in - let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl in + let (_, _, _, info as fix) = interp_fixpoint ~cofix:false ?typing_flags fixl in fixl, ntns, fix, List.map compute_possible_guardness_evidences info -let do_fixpoint_interactive ~scope ~poly l : Declare.Proof.t = - let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in - let lemma = declare_fixpoint_interactive_generic ~indexes:possible_indexes ~scope ~poly fix ntns in +let do_fixpoint_interactive ~scope ~poly ?typing_flags l : Declare.Proof.t = + let fixl, ntns, fix, possible_indexes = do_fixpoint_common ?typing_flags l in + let lemma = declare_fixpoint_interactive_generic ~indexes:possible_indexes ~scope ~poly ?typing_flags fix ntns in lemma -let do_fixpoint ~scope ~poly ?using l = - let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in - declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly ?using fix ntns +let do_fixpoint ~scope ~poly ?typing_flags ?using l = + let fixl, ntns, fix, possible_indexes = do_fixpoint_common ?typing_flags l in + declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly ?typing_flags ?using fix ntns let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = let fixl = List.map (fun fix -> {fix with Vernacexpr.rec_order = None}) fixl in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index a36aba7672..faa5fce375 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -15,11 +15,20 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) -val do_fixpoint_interactive : - scope:Locality.locality -> poly:bool -> fixpoint_expr list -> Declare.Proof.t +val do_fixpoint_interactive + : scope:Locality.locality + -> poly:bool + -> ?typing_flags:Declarations.typing_flags + -> fixpoint_expr list + -> Declare.Proof.t -val do_fixpoint : - scope:Locality.locality -> poly:bool -> ?using:Vernacexpr.section_subset_expr -> fixpoint_expr list -> unit +val do_fixpoint + : scope:Locality.locality + -> poly:bool + -> ?typing_flags:Declarations.typing_flags + -> ?using:Vernacexpr.section_subset_expr + -> fixpoint_expr list + -> unit val do_cofixpoint_interactive : scope:Locality.locality -> poly:bool -> cofixpoint_expr list -> Declare.Proof.t @@ -44,6 +53,7 @@ type ('constr, 'types) recursive_preentry = Id.t list * Sorts.relevance list * ' (** Exported for Program *) val interp_recursive : + Environ.env -> (* Misc arguments *) program_mode:bool -> cofix:bool -> (* Notations of the fixpoint / should that be folded in the previous argument? *) @@ -58,8 +68,9 @@ val interp_recursive : (** Exported for Funind *) val interp_fixpoint - : ?check_recursivity:bool -> - cofix:bool + : ?check_recursivity:bool + -> ?typing_flags:Declarations.typing_flags + -> cofix:bool -> lident option fix_expr_gen list -> (Constr.t, Constr.types) recursive_preentry * UState.universe_decl * UState.t * diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8cb077ca21..2be6097184 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -631,7 +631,7 @@ type uniform_inductive_flag = | UniformParameters | NonUniformParameters -let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uniform finite = +let do_mutual_inductive ~template udecl indl ~cumulative ~poly ?typing_flags ~private_ind ~uniform finite = let (params,indl),coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) let indl = match params with @@ -640,9 +640,11 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni | UniformParameters -> (params, [], indl) | NonUniformParameters -> ([], params, indl) in - let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) ~template udecl indl ntns ~cumulative ~poly ~private_ind finite in + let env = Global.env () in + let env = Environ.update_typing_flags ?typing_flags env in + let mie,pl,impls = interp_mutual_inductive_gen env ~template udecl indl ntns ~cumulative ~poly ~private_ind finite in (* Declare the mutual inductive block with its associated schemes *) - ignore (DeclareInd.declare_mutual_inductive_with_eliminations mie pl impls); + ignore (DeclareInd.declare_mutual_inductive_with_eliminations ?typing_flags mie pl impls); (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 8bce884ba4..e049bacb26 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -26,6 +26,7 @@ val do_mutual_inductive -> (one_inductive_expr * decl_notation list) list -> cumulative:bool -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> private_ind:bool -> uniform:uniform_inductive_flag -> Declarations.recursivity_kind diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 31f91979d3..3c4a651cf5 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -109,7 +109,7 @@ let telescope env sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?using r measure notation = +let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?typing_flags ?using r measure notation = let open EConstr in let open Vars in let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in @@ -266,7 +266,7 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?using r measure notat in let uctx = Evd.evar_universe_context sigma in let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ ?using () in - let info = Declare.Info.make ~udecl ~poly ~hook () in + let info = Declare.Info.make ~udecl ~poly ~hook ?typing_flags () in let pm, _ = Declare.Obls.add_definition ~pm ~cinfo ~info ~term:evars_def ~uctx evars in pm @@ -280,10 +280,12 @@ let collect_evars_of_term evd c ty = Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) -let do_program_recursive ~pm ~scope ~poly ?using fixkind fixl = +let do_program_recursive ~pm ~scope ~poly ?typing_flags ?using fixkind fixl = let cofix = fixkind = Declare.Obls.IsCoFixpoint in let (env, rec_sign, udecl, evd), fix, info = - interp_recursive ~cofix ~program_mode:true fixl + let env = Global.env () in + let env = Environ.update_typing_flags ?typing_flags env in + interp_recursive env ~cofix ~program_mode:true fixl in (* Program-specific code *) (* Get the interesting evars, those that were not instantiated *) @@ -320,10 +322,13 @@ let do_program_recursive ~pm ~scope ~poly ?using fixkind fixl = Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in let indexes = - Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in + let env = Global.env () in + let env = Environ.update_typing_flags ?typing_flags env in + Pretyping.search_guard env possible_indexes fixdecls in + let env = Environ.update_typing_flags ?typing_flags env in List.iteri (fun i _ -> Inductive.check_fix env - ((indexes,i),fixdecls)) + ((indexes,i),fixdecls)) fixl end in let uctx = Evd.evar_universe_context evd in @@ -332,16 +337,16 @@ let do_program_recursive ~pm ~scope ~poly ?using fixkind fixl = | Declare.Obls.IsCoFixpoint -> Decls.(IsDefinition CoFixpoint) in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in - let info = Declare.Info.make ~poly ~scope ~kind ~udecl () in + let info = Declare.Info.make ~poly ~scope ~kind ~udecl ?typing_flags () in Declare.Obls.add_mutual_definitions ~pm defs ~info ~uctx ~ntns fixkind -let do_fixpoint ~pm ~scope ~poly ?using l = +let do_fixpoint ~pm ~scope ~poly ?typing_flags ?using l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with | [Some { CAst.v = CWfRec (n,r) }], [ Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations} ] -> let recarg = mkIdentC n.CAst.v in - build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?using r recarg notations + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?typing_flags ?using r recarg notations | [Some { CAst.v = CMeasureRec (n, m, r) }], [Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations }] -> @@ -354,7 +359,7 @@ let do_fixpoint ~pm ~scope ~poly ?using l = user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") | _, _ -> r in - build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?using + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?typing_flags ?using (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m notations | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> @@ -362,7 +367,7 @@ let do_fixpoint ~pm ~scope ~poly ?using l = Vernacexpr.(ComFixpoint.adjust_rec_order ~structonly:true fix.binders fix.rec_order)) l in let fixkind = Declare.Obls.IsFixpoint annots in let l = List.map2 (fun fix rec_order -> { fix with Vernacexpr.rec_order }) l annots in - do_program_recursive ~pm ~scope ~poly ?using fixkind l + do_program_recursive ~pm ~scope ~poly ?typing_flags ?using fixkind l | _, _ -> CErrors.user_err ~hdr:"do_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index 30bf3ae8f8..0193be8683 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -15,6 +15,7 @@ val do_fixpoint : pm:Declare.OblState.t -> scope:Locality.locality -> poly:bool + -> ?typing_flags:Declarations.typing_flags -> ?using:Vernacexpr.section_subset_expr -> fixpoint_expr list -> Declare.OblState.t diff --git a/vernac/declare.ml b/vernac/declare.ml index 73ebca276d..fafee13bf6 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -83,14 +83,15 @@ module Info = struct ; udecl : UState.universe_decl ; scope : Locality.locality ; hook : Hook.t option + ; typing_flags : Declarations.typing_flags option } (** Note that [opaque] doesn't appear here as it is not known at the start of the proof in the interactive case. *) let make ?(poly=false) ?(inline=false) ?(kind=Decls.(IsDefinition Definition)) ?(udecl=UState.default_univ_decl) ?(scope=Locality.Global Locality.ImportDefaultBehavior) - ?hook () = - { poly; inline; kind; udecl; scope; hook } + ?hook ?typing_flags () = + { poly; inline; kind; udecl; scope; hook; typing_flags } end @@ -325,12 +326,12 @@ let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proo let feedback_axiom () = Feedback.(feedback AddedAxiom) -let is_unsafe_typing_flags () = +let is_unsafe_typing_flags flags = + let flags = Option.default (Global.typing_flags ()) flags in let open Declarations in - let flags = Environ.typing_flags (Global.env()) in not (flags.check_universes && flags.check_guarded && flags.check_positive) -let define_constant ~name cd = +let define_constant ~name ~typing_flags cd = (* Logically define the constant and its subproofs, no libobject tampering *) let decl, unsafe = match cd with | DefinitionEntry de -> @@ -354,13 +355,13 @@ let define_constant ~name cd = | PrimitiveEntry e -> ConstantEntry (Entries.PrimitiveEntry e), false in - let kn = Global.add_constant name decl in - if unsafe || is_unsafe_typing_flags() then feedback_axiom(); + let kn = Global.add_constant ?typing_flags name decl in + if unsafe || is_unsafe_typing_flags typing_flags then feedback_axiom(); kn -let declare_constant ?(local = Locality.ImportDefaultBehavior) ~name ~kind cd = +let declare_constant ?(local = Locality.ImportDefaultBehavior) ~name ~kind ~typing_flags cd = let () = check_exists name in - let kn = define_constant ~name cd in + let kn = define_constant ~typing_flags ~name cd in (* Register the libobjects attached to the constants *) let () = register_constant kn kind local in kn @@ -557,7 +558,7 @@ let declare_definition_scheme ~internal ~univs ~role ~name c = kn, eff (* Locality stuff *) -let declare_entry_core ~name ~scope ~kind ?hook ~obls ~impargs ~uctx entry = +let declare_entry_core ~name ~scope ~kind ~typing_flags ?hook ~obls ~impargs ~uctx entry = let should_suggest = entry.proof_entry_opaque && not (List.is_empty (Global.named_context())) @@ -570,7 +571,7 @@ let declare_entry_core ~name ~scope ~kind ?hook ~obls ~impargs ~uctx entry = if should_suggest then Proof_using.suggest_variable (Global.env ()) name; Names.GlobRef.VarRef name | Locality.Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in + let kn = declare_constant ~name ~local ~kind ~typing_flags (DefinitionEntry entry) in let gr = Names.GlobRef.ConstRef kn in if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; let () = DeclareUniv.declare_univ_binders gr ubind in @@ -583,10 +584,11 @@ let declare_entry_core ~name ~scope ~kind ?hook ~obls ~impargs ~uctx entry = let declare_entry = declare_entry_core ~obls:[] -let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = +let mutual_make_bodies ~typing_flags ~fixitems ~rec_declaration ~possible_indexes = match possible_indexes with | Some possible_indexes -> let env = Global.env() in + let env = Environ.update_typing_flags ?typing_flags env in let indexes = Pretyping.search_guard env possible_indexes rec_declaration in let vars = Vars.universes_of_constr (Constr.mkFix ((indexes,0),rec_declaration)) in let fixdecls = CList.map_i (fun i _ -> Constr.mkFix ((indexes,i),rec_declaration)) 0 fixitems in @@ -597,9 +599,9 @@ let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = vars, fixdecls, None let declare_mutually_recursive_core ~info ~cinfo ~opaque ~ntns ~uctx ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) () = - let { Info.poly; udecl; scope; kind; _ } = info in + let { Info.poly; udecl; scope; kind; typing_flags; _ } = info in let vars, fixdecls, indexes = - mutual_make_bodies ~fixitems:cinfo ~rec_declaration ~possible_indexes in + mutual_make_bodies ~typing_flags ~fixitems:cinfo ~rec_declaration ~possible_indexes in let uctx, univs = (* XXX: Obligations don't do this, this seems like a bug? *) if restrict_ucontext @@ -614,7 +616,7 @@ let declare_mutually_recursive_core ~info ~cinfo ~opaque ~ntns ~uctx ~rec_declar let csts = CList.map2 (fun CInfo.{ name; typ; impargs; using } body -> let entry = definition_entry ~opaque ~types:typ ~univs ?using body in - declare_entry ~name ~scope ~kind ~impargs ~uctx entry) + declare_entry ~name ~scope ~kind ~impargs ~uctx ~typing_flags entry) cinfo fixdecls in let isfix = Option.has_some possible_indexes in @@ -637,7 +639,7 @@ let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = in let kind = Decls.(IsAssumption Conjectural) in let decl = ParameterEntry pe in - let kn = declare_constant ~name ~local ~kind decl in + let kn = declare_constant ~name ~local ~kind ~typing_flags:None decl in let dref = Names.GlobRef.ConstRef kn in let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = assumption_message name in @@ -680,8 +682,8 @@ let prepare_definition ~info ~opaque ?using ~body ~typ sigma = let declare_definition_core ~info ~cinfo ~opaque ~obls ~body sigma = let { CInfo.name; impargs; typ; using; _ } = cinfo in let entry, uctx = prepare_definition ~info ~opaque ?using ~body ~typ sigma in - let { Info.scope; kind; hook; _ } = info in - declare_entry_core ~name ~scope ~kind ~impargs ~obls ?hook ~uctx entry, uctx + let { Info.scope; kind; hook; typing_flags; _ } = info in + declare_entry_core ~name ~scope ~kind ~impargs ~typing_flags ~obls ?hook ~uctx entry, uctx let declare_definition ~info ~cinfo ~opaque ~body sigma = declare_definition_core ~obls:[] ~info ~cinfo ~opaque ~body sigma |> fst @@ -913,6 +915,7 @@ let declare_obligation prg obl ~uctx ~types ~body = (* ppedrot: seems legit to have obligations as local *) let constant = declare_constant ~name:obl.obl_name + ~typing_flags:prg.prg_info.Info.typing_flags ~local:Locality.ImportNeedQualified ~kind:Decls.(IsProof Property) (DefinitionEntry ce) @@ -1425,9 +1428,9 @@ let start_proof_core ~name ~typ ~pinfo ?(sign=initialize_named_context_for_proof marked "opaque", this is a hack tho, see #10446, and build_constant_by_tactic uses a different method that would break program_inference_hook *) - let { Proof_info.info = { Info.poly; _ }; _ } = pinfo in + let { Proof_info.info = { Info.poly; typing_flags; _ }; _ } = pinfo in let goals = [Global.env_of_context sign, typ] in - let proof = Proof.start ~name ~poly sigma goals in + let proof = Proof.start ~name ~poly ?typing_flags sigma goals in let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in { proof ; endline_tactic = None @@ -1448,7 +1451,8 @@ let start_core ~info ~cinfo ?proof_ending sigma = let start = start_core ?proof_ending:None let start_dependent ~info ~name ~proof_ending goals = - let proof = Proof.dependent_start ~name ~poly:info.Info.poly goals in + let { Info.poly; typing_flags; _ } = info in + let proof = Proof.dependent_start ~name ~poly ?typing_flags goals in let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in let cinfo = [] in let pinfo = Proof_info.make ~info ~cinfo ~proof_ending () in @@ -1886,7 +1890,7 @@ end = struct let declare_mutdef ~uctx ~pinfo pe i CInfo.{ name; impargs; typ; _} = let { Proof_info.info; compute_guard; _ } = pinfo in - let { Info.hook; scope; kind; _ } = info in + let { Info.hook; scope; kind; typing_flags; _ } = info in (* if i = 0 , we don't touch the type; this is for compat but not clear it is the right thing to do. *) @@ -1903,7 +1907,7 @@ end = struct Internal.map_entry_body pe ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + declare_entry ~name ~scope ~kind ?hook ~impargs ~typing_flags ~uctx pe let declare_mutdef ~pinfo ~uctx ~entry = let pe = match pinfo.Proof_info.compute_guard with @@ -1913,6 +1917,8 @@ end = struct | possible_indexes -> (* Try all combinations... not optimal *) let env = Global.env() in + let typing_flags = pinfo.Proof_info.info.Info.typing_flags in + let env = Environ.update_typing_flags ?typing_flags env in Internal.map_entry_body entry ~f:(guess_decreasing env possible_indexes) in @@ -1993,7 +1999,7 @@ let finish_derived ~f ~name ~entries = let f_def = Internal.set_opacity ~opaque:false f_def in let f_kind = Decls.(IsDefinition Definition) in let f_def = DefinitionEntry f_def in - let f_kn = declare_constant ~name:f ~kind:f_kind f_def in + let f_kn = declare_constant ~name:f ~kind:f_kind f_def ~typing_flags:None in let f_kn_term = Constr.mkConst f_kn in (* In the type and body of the proof of [suchthat] there can be references to the variable [f]. It needs to be replaced by @@ -2011,7 +2017,7 @@ let finish_derived ~f ~name ~entries = (* The same is done in the body of the proof. *) let lemma_def = Internal.map_entry_body lemma_def ~f:(fun ((b,ctx),fx) -> (substf b, ctx), fx) in let lemma_def = DefinitionEntry lemma_def in - let ct = declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in + let ct = declare_constant ~name ~typing_flags:None ~kind:Decls.(IsProof Proposition) lemma_def in [GlobRef.ConstRef f_kn; GlobRef.ConstRef ct] let finish_proved_equations ~pm ~kind ~hook i proof_obj types sigma0 = @@ -2025,7 +2031,7 @@ let finish_proved_equations ~pm ~kind ~hook i proof_obj types sigma0 = | None -> let n = !obls in incr obls; Nameops.add_suffix i ("_obligation_" ^ string_of_int n) in let entry, args = Internal.shrink_entry local_context entry in - let cst = declare_constant ~name:id ~kind (DefinitionEntry entry) in + let cst = declare_constant ~name:id ~kind ~typing_flags:None (DefinitionEntry entry) in let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 @@ -2519,3 +2525,9 @@ type nonrec progress = progress = end module OblState = Obls_.State + +let declare_constant ?local ~name ~kind ?typing_flags = + declare_constant ?local ~name ~kind ~typing_flags + +let declare_entry ~name ~scope ~kind = + declare_entry ~name ~scope ~kind ~typing_flags:None diff --git a/vernac/declare.mli b/vernac/declare.mli index e4c77113af..37a61cc4f0 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -109,6 +109,7 @@ module Info : sig (** locality *) -> ?hook : Hook.t (** Callback to be executed after saving the constant *) + -> ?typing_flags:Declarations.typing_flags -> unit -> t @@ -387,6 +388,7 @@ val declare_constant : ?local:Locality.import_status -> name:Id.t -> kind:Decls.logical_kind + -> ?typing_flags:Declarations.typing_flags -> Evd.side_effects constant_entry -> Constant.t diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index e22d63b811..7050ddc042 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -104,7 +104,7 @@ let is_unsafe_typing_flags () = not (flags.check_universes && flags.check_guarded && flags.check_positive) (* for initial declaration *) -let declare_mind mie = +let declare_mind ?typing_flags mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in @@ -113,7 +113,7 @@ let declare_mind mie = List.iter (fun (typ, cons) -> Declare.check_exists typ; List.iter Declare.check_exists cons) names; - let _kn' = Global.add_mind id mie in + let _kn' = Global.add_mind ?typing_flags id mie in let (sp,kn as oname) = Lib.add_leaf id (inInductive { ind_names = names }) in if is_unsafe_typing_flags() then feedback_axiom (); let mind = Global.mind_of_delta_kn kn in @@ -154,7 +154,7 @@ type one_inductive_impls = Impargs.manual_implicits (* for inds *) * Impargs.manual_implicits list (* for constrs *) -let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = +let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) ?typing_flags mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) begin match mie.mind_entry_finite with @@ -166,7 +166,7 @@ let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie p | _ -> () end; let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_, kn), prim = declare_mind mie in + let (_, kn), prim = declare_mind ?typing_flags mie in let mind = Global.mind_of_delta_kn kn in if primitive_expected && not prim then warn_non_primitive_record (mind,0); DeclareUniv.declare_univ_binders (GlobRef.IndRef (mind,0)) pl; diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli index 05a1617329..eacf20e30c 100644 --- a/vernac/declareInd.mli +++ b/vernac/declareInd.mli @@ -17,6 +17,7 @@ type one_inductive_impls = val declare_mutual_inductive_with_eliminations : ?primitive_expected:bool + -> ?typing_flags:Declarations.typing_flags -> Entries.mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 1705915e70..834ef0d29a 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -9,6 +9,8 @@ (************************************************************************) open Names +open Declarations +open Univ (* object_kind , id *) exception AlreadyDeclared of (string option * Id.t) @@ -72,23 +74,51 @@ let input_univ_names : universe_name_decl -> Libobject.obj = subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } +let invent_name (named,cnt) u = + let rec aux i = + let na = Id.of_string ("u"^(string_of_int i)) in + if Id.Map.mem na named then aux (i+1) + else na, (Id.Map.add na u named, i+1) + in + aux cnt + +let label_and_univs_of = let open GlobRef in function + | ConstRef c -> + let l = Label.to_id @@ Constant.label c in + let univs = (Global.lookup_constant c).const_universes in + l, univs + | IndRef (c,_) -> + let l = Label.to_id @@ MutInd.label c in + let univs = (Global.lookup_mind c).mind_universes in + l, univs + | VarRef id -> + CErrors.anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") + | ConstructRef _ -> + CErrors.anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on a constructor reference") + let declare_univ_binders gr pl = - if Global.is_polymorphic gr then - () - else - let l = let open GlobRef in match gr with - | ConstRef c -> Label.to_id @@ Constant.label c - | IndRef (c, _) -> Label.to_id @@ MutInd.label c - | VarRef id -> - CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") - | ConstructRef _ -> - CErrors.anomaly ~label:"declare_univ_binders" - Pp.(str "declare_univ_binders on a constructor reference") + let l, univs = label_and_univs_of gr in + match univs with + | Polymorphic _ -> () + | Monomorphic (levels,_) -> + (* First the explicitly named universes *) + let named, univs = Id.Map.fold (fun id univ (named,univs) -> + let univs = match Univ.Level.name univ with + | None -> assert false (* having Prop/Set/Var as binders is nonsense *) + | Some univ -> (id,univ)::univs + in + let named = LSet.add univ named in + named, univs) + pl (LSet.empty,[]) in - let univs = Id.Map.fold (fun id univ univs -> - match Univ.Level.name univ with - | None -> assert false (* having Prop/Set/Var as binders is nonsense *) - | Some univ -> (id,univ)::univs) pl [] + (* then invent names for the rest *) + let _, univs = LSet.fold (fun univ (aux,univs) -> + let id, aux = invent_name aux univ in + let univ = Option.get (Level.name univ) in + aux, (id,univ) :: univs) + (LSet.diff levels named) ((pl,0),univs) in Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) @@ -109,9 +139,8 @@ let do_universe ~poly l = let do_constraint ~poly l = let open Univ in - let u_of_id x = - Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x - in + let evd = Evd.from_env (Global.env ()) in + let u_of_id x = Constrintern.interp_known_level evd x in let constraints = List.fold_left (fun acc (l, d, r) -> let lu = u_of_id l and ru = u_of_id r in Constraint.add (lu, d, ru) acc) diff --git a/vernac/declareUniv.mli b/vernac/declareUniv.mli index e4d1d5dc65..a7e942be5a 100644 --- a/vernac/declareUniv.mli +++ b/vernac/declareUniv.mli @@ -10,11 +10,16 @@ open Names -(* object_kind , id *) +(** Also used by [Declare] for constants, [DeclareInd] for inductives, etc. + Containts [object_kind , id]. *) exception AlreadyDeclared of (string option * Id.t) -(** Global universe contexts, names and constraints *) +(** Internally used to declare names of universes from monomorphic + constants/inductives. Noop on polymorphic references. *) val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit +(** Command [Universes]. *) val do_universe : poly:bool -> lident list -> unit -val do_constraint : poly:bool -> Glob_term.glob_constraint list -> unit + +(** Command [Constraint]. *) +val do_constraint : poly:bool -> Constrexpr.univ_constraint_expr list -> unit diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index ad6ac8d3f3..9fe3e2f7ab 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -246,6 +246,7 @@ type _ target = type prod_info = production_level * production_position type (_, _) entry = +| TTIdent : ('self, lident) entry | TTName : ('self, lname) entry | TTReference : ('self, qualid) entry | TTBigint : ('self, string) entry @@ -364,6 +365,7 @@ let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = | TTPattern p -> MayRecNo (Pcoq.Symbol.nterml Constr.pattern (string_of_int p)) | TTClosedBinderList [] -> MayRecNo (Pcoq.Symbol.list1 (Pcoq.Symbol.nterm Constr.binder)) | TTClosedBinderList tkl -> MayRecNo (Pcoq.Symbol.list1sep (Pcoq.Symbol.nterm Constr.binder) (make_sep_rules tkl) false) +| TTIdent -> MayRecNo (Pcoq.Symbol.nterm Prim.identref) | TTName -> MayRecNo (Pcoq.Symbol.nterm Prim.name) | TTBinder true -> MayRecNo (Pcoq.Symbol.nterm Constr.one_open_binder) | TTBinder false -> MayRecNo (Pcoq.Symbol.nterm Constr.one_closed_binder) @@ -372,6 +374,7 @@ let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = | TTReference -> MayRecNo (Pcoq.Symbol.nterm Constr.global) let interp_entry forpat e = match e with +| ETProdIdent -> TTAny TTIdent | ETProdName -> TTAny TTName | ETProdReference -> TTAny TTReference | ETProdBigint -> TTAny TTBigint @@ -382,6 +385,9 @@ let interp_entry forpat e = match e with | ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList | ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl) +let cases_pattern_expr_of_id { CAst.loc; v = id } = + CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) + let cases_pattern_expr_of_name { CAst.loc; v = na } = CAst.make ?loc @@ match na with | Anonymous -> CPatAtom None | Name id -> CPatAtom (Some (qualid_of_ident ?loc id)) @@ -398,6 +404,11 @@ let push_constr subst v = { subst with constrs = v :: subst.constrs } let push_item : type s r. s target -> (s, r) entry -> s env -> r -> s env = fun forpat e subst v -> match e with | TTConstr _ -> push_constr subst v +| TTIdent -> + begin match forpat with + | ForConstr -> { subst with binders = (cases_pattern_expr_of_id v, Glob_term.Explicit) :: subst.binders } + | ForPattern -> push_constr subst (cases_pattern_expr_of_id v) + end | TTName -> begin match forpat with | ForConstr -> { subst with binders = (cases_pattern_expr_of_name v, Glob_term.Explicit) :: subst.binders } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 116cfc6413..5c329f60a9 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -531,6 +531,10 @@ let warn_deprecated_include_type = CWarnings.create ~name:"deprecated-include-type" ~category:"deprecated" (fun () -> strbrk "Include Type is deprecated; use Include instead") +let warn_deprecated_as_ident_kind = + CWarnings.create ~name:"deprecated-as-ident-kind" ~category:"deprecated" + (fun () -> strbrk "grammar kind \"as ident\" no longer accepts \"_\"; use \"as name\" instead to accept \"_\", too, or silence the warning if you actually intended to accept only identifiers.") + } (* Modules and Sections *) @@ -1242,7 +1246,13 @@ GRAMMAR EXTEND Gram ] ] ; explicit_subentry: - [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } + [ [ (* Warning to be turn into an error at the end of deprecation phase (for 8.14) *) + IDENT "ident" -> { ETName false } + (* To be activated at the end of transitory phase (for 8.15) + | IDENT "ident" -> { ETIdent } + *) + | IDENT "name" -> { ETName true } (* Boolean to remove at the end of transitory phase *) + | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } | IDENT "binder" -> { ETBinder true } | IDENT "constr" -> { ETConstr (InConstrEntry,None,DefaultLevel) } @@ -1261,8 +1271,9 @@ GRAMMAR EXTEND Gram | -> { DefaultLevel } ] ] ; binder_interp: - [ [ "as"; IDENT "ident" -> { Notation_term.AsIdent } - | "as"; IDENT "pattern" -> { Notation_term.AsIdentOrPattern } + [ [ "as"; IDENT "ident" -> { warn_deprecated_as_ident_kind (); Notation_term.AsIdent } + | "as"; IDENT "name" -> { Notation_term.AsName } + | "as"; IDENT "pattern" -> { Notation_term.AsNameOrPattern } | "as"; IDENT "strict"; IDENT "pattern" -> { Notation_term.AsStrictPattern } ] ] ; END diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 9d86ea90e6..bff0359782 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -572,6 +572,13 @@ let rec explain_evar_kind env sigma evk ty = strbrk "the type of " ++ Id.print id | Evar_kinds.BinderType Anonymous -> strbrk "the type of this anonymous binder" + | Evar_kinds.EvarType (ido,evk) -> + let pp = match ido with + | Some id -> str "?" ++ Id.print id + | None -> + try pr_existential_key sigma evk + with (* defined *) Not_found -> strbrk "an internal placeholder" in + strbrk "the type of " ++ pp | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in strbrk "the implicit parameter " ++ Id.print id ++ spc () ++ str "of" ++ @@ -961,7 +968,7 @@ let explain_not_match_error = function status (not b) ++ str" declaration was found" | IncompatibleUniverses incon -> str"the universe constraints are inconsistent: " ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes incon + Univ.explain_universe_inconsistency UnivNames.(pr_with_global_universes empty_binders) incon | IncompatiblePolymorphism (env, t1, t2) -> str "conversion of polymorphic values generates additional constraints: " ++ quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t1) ++ spc () ++ @@ -1218,7 +1225,7 @@ let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." let error_inductive_missing_constraints (us,ind_univ) = - let pr_u = Univ.Universe.pr_with UnivNames.pr_with_global_universes in + let pr_u = Univ.Universe.pr_with UnivNames.(pr_with_global_universes empty_binders) in str "Missing universe constraint declared for inductive type:" ++ spc() ++ v 0 (prlist_with_sep spc (fun u -> hov 0 (pr_u u ++ str " <= " ++ pr_u ind_univ)) @@ -1318,14 +1325,28 @@ let decline_string n s = else if Int.equal n 1 then str "1 " ++ str s else (int n ++ str " " ++ str s ++ str "s") -let explain_wrong_numarg_constructor env cstr n = - str "The constructor " ++ pr_constructor env cstr ++ - str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++ - str ") expects " ++ decline_string n "argument" ++ str "." - -let explain_wrong_numarg_inductive env ind n = - str "The inductive type " ++ pr_inductive env ind ++ - str " expects " ++ decline_string n "argument" ++ str "." +let explain_wrong_numarg_pattern expanded nargs expected_nassums expected_ndecls pp = + (if expanded then + strbrk "Once notations are expanded, the resulting " + else + strbrk "The ") ++ pp ++ + strbrk " is expected to be applied to " ++ decline_string expected_nassums "argument" ++ + (if expected_nassums = expected_ndecls then mt () else + strbrk " (or " ++ decline_string expected_ndecls "argument" ++ + strbrk " when including variables for local definitions)") ++ + strbrk " while it is actually applied to " ++ + decline_string nargs "argument" ++ str "." + +let explain_wrong_numarg_constructor env cstr expanded nargs expected_nassums expected_ndecls = + let pp = + strbrk "constructor " ++ pr_constructor env cstr ++ + strbrk " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++ + strbrk ")" in + explain_wrong_numarg_pattern expanded nargs expected_nassums expected_ndecls pp + +let explain_wrong_numarg_inductive env ind expanded nargs expected_nassums expected_ndecls = + let pp = strbrk "inductive type " ++ pr_inductive env ind in + explain_wrong_numarg_pattern expanded nargs expected_nassums expected_ndecls pp let explain_unused_clause env pats = str "Pattern \"" ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) ++ strbrk "\" is redundant in this clause." @@ -1350,10 +1371,10 @@ let explain_pattern_matching_error env sigma = function explain_bad_pattern env sigma c t | BadConstructor (c,ind) -> explain_bad_constructor env c ind - | WrongNumargConstructor (c,n) -> - explain_wrong_numarg_constructor env c n - | WrongNumargInductive (c,n) -> - explain_wrong_numarg_inductive env c n + | WrongNumargConstructor {cstr; expanded; nargs; expected_nassums; expected_ndecls} -> + explain_wrong_numarg_constructor env cstr expanded nargs expected_nassums expected_ndecls + | WrongNumargInductive {ind; expanded; nargs; expected_nassums; expected_ndecls} -> + explain_wrong_numarg_inductive env ind expanded nargs expected_nassums expected_ndecls | UnusedClause tms -> explain_unused_clause env tms | NonExhaustive tms -> @@ -1406,7 +1427,7 @@ let _ = CErrors.register_handler (wrap_unhandled explain_exn_default) let rec vernac_interp_error_handler = function | Univ.UniverseInconsistency i -> str "Universe inconsistency." ++ spc() ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes i ++ str "." + Univ.explain_universe_inconsistency UnivNames.(pr_with_global_universes empty_binders) i ++ str "." | TypeError(ctx,te) -> let te = map_ptype_error EConstr.of_constr te in explain_type_error ctx Evd.empty te diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8759798331..e6244ee3b5 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -340,11 +340,11 @@ let unparsing_metavar i from typs = let x = List.nth typs (i-1) in let prec,side = unparsing_precedence_of_entry_type from x in match x with - | ETConstr _ | ETGlobal | ETBigint -> + | ETConstr _ | ETGlobal | ETBigint | ETIdent -> UnpMetaVar (prec,side) - | ETPattern _ | ETIdent -> + | ETPattern _ | ETName _ -> UnpBinderMetaVar (prec,NotQuotedPattern) - | ETBinder _ -> + | ETBinder isopen -> UnpBinderMetaVar (prec,QuotedPattern) (* Heuristics for building default printing rules *) @@ -631,7 +631,8 @@ let include_possible_similar_trailing_pattern typ etyps sl l = try_aux 0 l let prod_entry_type = function - | ETIdent -> ETProdName + | ETIdent -> ETProdIdent + | ETName _ -> ETProdName | ETGlobal -> ETProdReference | ETBigint -> ETProdBigint | ETBinder o -> ETProdOneBinder o @@ -891,6 +892,11 @@ let default = { end +(* To be turned into a fatal warning in 8.14 *) +let warn_deprecated_ident_entry = + CWarnings.create ~name:"deprecated-ident-entry" ~category:"deprecated" + (fun () -> strbrk "grammar entry \"ident\" permitted \"_\" in addition to proper identifiers; this use is deprecated and its meaning will change in the future; use \"name\" instead.") + let interp_modifiers modl = let open NotationMods in let rec interp subtyps acc = function | [] -> subtyps, acc @@ -952,6 +958,13 @@ let interp_modifiers modl = let open NotationMods in let subtyps,mods = interp [] default modl in (* interpret item levels wrt to main entry *) let extra_etyps = List.map (fun (id,bko,n) -> (id,ETConstr (mods.custom,bko,n))) subtyps in + (* Temporary hack: "ETName false" (i.e. "ident" in deprecation phase) means "ETIdent" for custom entries *) + let mods = + { mods with etyps = List.map (function + | (id,ETName false) -> + if mods.custom = InConstrEntry then (warn_deprecated_ident_entry (); (id,ETName true)) + else (id,ETIdent) + | x -> x) mods.etyps } in { mods with etyps = extra_etyps@mods.etyps } let check_infix_modifiers modifiers = @@ -1000,7 +1013,7 @@ let set_entry_type from n etyps (x,typ) = | ETConstr (s,bko,n), InternalProd -> ETConstr (s,bko,(n,InternalProd)) | ETPattern (b,n), _ -> ETPattern (b,n) - | (ETIdent | ETBigint | ETGlobal | ETBinder _ as x), _ -> x + | (ETIdent | ETName _ | ETBigint | ETGlobal | ETBinder _ as x), _ -> x with Not_found -> ETConstr (from,None,(make_lev n from,typ)) in (x,typ) @@ -1023,7 +1036,7 @@ let join_auxiliary_recursive_types recvars etyps = let internalization_type_of_entry_type = function | ETBinder _ -> NtnInternTypeOnlyBinder | ETConstr _ | ETBigint | ETGlobal - | ETIdent | ETPattern _ -> NtnInternTypeAny + | ETIdent | ETName _ | ETPattern _ -> NtnInternTypeAny let set_internalization_type typs = List.map (fun (_, e) -> internalization_type_of_entry_type e) typs @@ -1043,6 +1056,7 @@ let make_interpretation_type isrec isonlybinding default_if_binding = function | ETConstr (_,None,_) -> NtnTypeConstr (* Others *) | ETIdent -> NtnTypeBinder NtnParsedAsIdent + | ETName _ -> NtnTypeBinder NtnParsedAsName | ETPattern (ppstrict,_) -> NtnTypeBinder (NtnParsedAsPattern ppstrict) (* Parsed as ident/pattern, primarily interpreted as binder; maybe strict at printing *) | ETBigint | ETGlobal -> NtnTypeConstr | ETBinder _ -> @@ -1063,7 +1077,7 @@ let subentry_of_constr_prod_entry from_level = function | _ -> InConstrEntrySomeLevel let make_interpretation_vars - (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsIdent) + (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsName) recvars level allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && @@ -1159,7 +1173,7 @@ let find_precedence custom lev etyps symbols onlyprint = user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") in (try match List.assoc x etyps, custom with | ETConstr (s,_,(NumLevel _ | NextLevel)), s' when s = s' -> test () - | (ETIdent | ETBigint | ETGlobal), _ -> + | (ETIdent | ETName _ | ETBigint | ETGlobal), _ -> begin match lev with | None -> ([fun () -> Flags.if_verbose (Feedback.msg_info ?loc:None) (strbrk "Setting notation at level 0.")],0) @@ -1798,7 +1812,7 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing interp_notation_constr env nenv c in let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,InternalProd))) in - let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] 0 acvars (List.map in_pat vars) in + let interp = make_interpretation_vars ~default_if_binding:AsNameOrPattern [] 0 acvars (List.map in_pat vars) in let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in let also_in_cases_pattern = has_no_binders_type vars in let onlyparsing = onlyparsing || fst (printability None [] false reversibility pat) in @@ -1808,9 +1822,9 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing (* Declaration of custom entry *) let warn_custom_entry = - CWarnings.create ~name:"custom-entry-overriden" ~category:"parsing" + CWarnings.create ~name:"custom-entry-overridden" ~category:"parsing" (fun s -> - strbrk "Custom entry " ++ str s ++ strbrk " has been overriden.") + strbrk "Custom entry " ++ str s ++ strbrk " has been overridden.") let load_custom_entry _ _ = () diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4cee4f7a47..ff4365c8d3 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -60,8 +60,8 @@ let pr_red_expr = keyword let pr_uconstraint (l, d, r) = - pr_glob_sort_name l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_sort_name r + pr_sort_name_expr l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_sort_name_expr r let pr_univ_name_list = function | None -> mt () @@ -187,13 +187,16 @@ let level_of_pattern_level = function None -> DefaultLevel | Some n -> NumLevel let pr_constr_as_binder_kind = let open Notation_term in function | AsIdent -> spc () ++ keyword "as ident" - | AsIdentOrPattern -> spc () ++ keyword "as pattern" + | AsName -> spc () ++ keyword "as name" + | AsNameOrPattern -> spc () ++ keyword "as pattern" | AsStrictPattern -> spc () ++ keyword "as strict pattern" let pr_strict b = if b then str "strict " else mt () let pr_set_entry_type pr = function | ETIdent -> str"ident" + | ETName false -> str"ident" (* temporary *) + | ETName true -> str"name" | ETGlobal -> str"global" | ETPattern (b,n) -> pr_strict b ++ str"pattern" ++ pr_at_level (level_of_pattern_level n) | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko @@ -268,9 +271,9 @@ let pr_reference_or_constr pr_c = function | HintsConstr c -> pr_c c let pr_hint_mode = let open Hints in function - | ModeInput -> str"+" - | ModeNoHeadEvar -> str"!" - | ModeOutput -> str"-" + | ModeInput -> str"+" + | ModeNoHeadEvar -> str"!" + | ModeOutput -> str"-" let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } = pr_opt (fun x -> str"|" ++ int x) pri ++ diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 840754ccc6..0fc6c7f87b 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -206,7 +206,7 @@ let print_if_is_coercion ref = let pr_template_variables = function | [] -> mt () - | vars -> str "on " ++ prlist_with_sep spc UnivNames.pr_with_global_universes vars + | vars -> str "on " ++ prlist_with_sep spc UnivNames.(pr_with_global_universes empty_binders) vars let print_polymorphism ref = let poly = Global.is_polymorphic ref in @@ -668,7 +668,7 @@ let gallina_print_syntactic_def env kn = spc () ++ str ":=") ++ spc () ++ Constrextern.without_specific_symbols - [Notation.SynDefRule kn] (pr_glob_constr_env env) c) + [Notation.SynDefRule kn] (pr_glob_constr_env env (Evd.from_env env)) c) module DynHandle = Libobject.Dyn.Map(struct type 'a t = 'a -> Pp.t option end) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 0f63dfe5ce..a3726daf63 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -57,16 +57,17 @@ module DefAttributes = struct program : bool; deprecated : Deprecation.t option; canonical_instance : bool; + typing_flags : Declarations.typing_flags option; using : Vernacexpr.section_subset_expr option; } let parse f = let open Attributes in - let ((((locality, deprecated), polymorphic), program), canonical_instance), using = - parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance ++ using) f + let (((((locality, deprecated), polymorphic), program), canonical_instance), typing_flags), using = + parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance ++ typing_flags ++ using) f in let using = Option.map Proof_using.using_from_string using in - { polymorphic; program; locality; deprecated; canonical_instance; using } + { polymorphic; program; locality; deprecated; canonical_instance; typing_flags; using } end let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) @@ -353,9 +354,9 @@ let universe_subgraph ?loc kept univ = let open Univ in let sigma = Evd.from_env (Global.env()) in let parse q = - let q = Glob_term.(GType q) in + let q = Constrexpr.CType q in (* this function has a nice error message for not found univs *) - Pretyping.interp_known_glob_level ?loc sigma q + Constrintern.interp_known_level sigma q in let kept = List.fold_left (fun kept q -> LSet.add (parse q) kept) LSet.empty kept in let csts = UGraph.constraints_for ~kept univ in @@ -377,7 +378,7 @@ let print_universes ?loc ~sort ~subgraph dst = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" in - let prl = UnivNames.pr_with_global_universes in + let prl = UnivNames.(pr_with_global_universes empty_binders) in begin match dst with | None -> UGraph.pr_universes prl univ ++ pr_remaining | Some s -> dump_universes_gen (fun u -> Pp.string_of_ppcmds (prl u)) univ s @@ -512,6 +513,7 @@ let vernac_set_used_variables ~pstate e : Declare.Proof.t = l; let _, pstate = Declare.Proof.set_used_variables pstate l in pstate + let vernac_set_used_variables_opt ?using pstate = match using with | None -> pstate @@ -546,28 +548,29 @@ let post_check_evd ~udecl ~poly evd = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd -let start_lemma_com ~program_mode ~poly ~scope ~kind ?using ?hook thms = +let start_lemma_com ~typing_flags ~program_mode ~poly ~scope ~kind ?using ?hook thms = let env0 = Global.env () in + let env0 = Environ.update_typing_flags ?typing_flags env0 in let flags = Pretyping.{ all_no_fail_flags with program_mode } in let decl = fst (List.hd thms) in let evd, udecl = Constrintern.interp_univ_decl_opt env0 (snd decl) in let evd, thms = interp_lemma ~program_mode ~flags ~scope env0 evd thms in let mut_analysis = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in - let pstate = + let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl ?typing_flags () in + begin match mut_analysis with | RecLemmas.NonMutual thm -> let thm = Declare.CInfo.to_constr evd thm in let evd = post_check_evd ~udecl ~poly evd in - let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in Declare.Proof.start_with_initialization ~info ~cinfo:thm evd | RecLemmas.Mutual { mutual_info; cinfo ; possible_guards } -> let cinfo = List.map (Declare.CInfo.to_constr evd) cinfo in let evd = post_check_evd ~udecl ~poly evd in - let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in Declare.Proof.start_mutual_with_initialization ~info ~cinfo evd ~mutual_info (Some possible_guards) - in - vernac_set_used_variables_opt ?using pstate + end + (* XXX: This should be handled in start_with_initialization, see duplicate using in declare.ml *) + |> vernac_set_used_variables_opt ?using let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in function | Coercion -> @@ -606,14 +609,16 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in let poly = atts.polymorphic in + let typing_flags = atts.typing_flags in let name = vernac_definition_name lid local in - start_lemma_com ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?using:atts.using ?hook [(name, pl), (bl, t)] + start_lemma_com ~typing_flags ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?using:atts.using ?hook [(name, pl), (bl, t)] let vernac_definition ~atts ~pm (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in let scope = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in + let typing_flags = atts.typing_flags in let name = vernac_definition_name lid scope in let red_option = match red_option with | None -> None @@ -624,11 +629,11 @@ let vernac_definition ~atts ~pm (discharge, kind) (lid, pl) bl red_option c typ_ if program_mode then let kind = Decls.IsDefinition kind in ComDefinition.do_definition_program ~pm ~name:name.v - ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook + ~poly:atts.polymorphic ?typing_flags ~scope ~kind pl bl red_option c typ_opt ?hook else let () = ComDefinition.do_definition ~name:name.v - ~poly:atts.polymorphic ~scope ~kind ?using:atts.using pl bl red_option c typ_opt ?hook in + ~poly:atts.polymorphic ?typing_flags ~scope ~kind ?using:atts.using pl bl red_option c typ_opt ?hook in pm (* NB: pstate argument to use combinators easily *) @@ -637,7 +642,11 @@ let vernac_start_proof ~atts kind l = let scope = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_lemma_com ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Decls.IsProof kind) ?using:atts.using l + start_lemma_com + ~typing_flags:atts.typing_flags + ~program_mode:atts.program + ~poly:atts.polymorphic + ~scope ~kind:(Decls.IsProof kind) ?using:atts.using l let vernac_end_proof ~lemma ~pm = let open Vernacexpr in function | Admitted -> @@ -720,7 +729,7 @@ let should_treat_as_uniform () = then ComInductive.UniformParameters else ComInductive.NonUniformParameters -let vernac_record ~template udecl ~cumulative k ~poly finite records = +let vernac_record ~template udecl ~cumulative k ~poly ?typing_flags finite records = let map ((is_coercion, name), binders, sort, nameopt, cfs) = let idbuild = match nameopt with | None -> Nameops.add_prefix "Build_" name.v @@ -741,7 +750,13 @@ let vernac_record ~template udecl ~cumulative k ~poly finite records = Record.Ast.{ name; is_coercion; binders; cfs; idbuild; sort } in let records = List.map map records in - ignore(Record.definition_structure ~template udecl k ~cumulative ~poly finite records) + match typing_flags with + | Some _ -> + CErrors.user_err (Pp.str "typing flags are not yet supported for records") + | None -> + let _ : _ list = + Record.definition_structure ~template udecl k ~cumulative ~poly finite records in + () let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = match indl with @@ -773,8 +788,8 @@ let private_ind = | None -> return false let vernac_inductive ~atts kind indl = - let (template, (poly, cumulative)), private_ind = Attributes.( - parse Notations.(template ++ polymorphic_cumulative ++ private_ind) atts) in + let ((template, (poly, cumulative)), private_ind), typing_flags = Attributes.( + parse Notations.(template ++ polymorphic_cumulative ++ private_ind ++ typing_flags) atts) in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -811,7 +826,7 @@ let vernac_inductive ~atts kind indl = let coe' = if coe then BackInstance else NoInstance in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), [], ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in - vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] + vernac_record ~template udecl ~cumulative (Class true) ~poly ?typing_flags finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) let () = match kind with @@ -836,7 +851,7 @@ let vernac_inductive ~atts kind indl = in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in - vernac_record ~template udecl ~cumulative kind ~poly finite recordl + vernac_record ~template udecl ~cumulative kind ~poly ?typing_flags finite recordl else if List.for_all is_constructor indl then (* Mutual inductive case *) let () = match kind with @@ -860,7 +875,7 @@ let vernac_inductive ~atts kind indl = in let indl = List.map unpack indl in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ?typing_flags ~private_ind ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") @@ -874,17 +889,19 @@ let vernac_fixpoint_interactive ~atts discharge l = let scope = vernac_fixpoint_common ~atts discharge l in if atts.program then CErrors.user_err Pp.(str"Program Fixpoint requires a body"); - vernac_set_used_variables_opt ?using:atts.using - (ComFixpoint.do_fixpoint_interactive ~scope ~poly:atts.polymorphic l) + let typing_flags = atts.typing_flags in + ComFixpoint.do_fixpoint_interactive ~scope ~poly:atts.polymorphic ?typing_flags l + |> vernac_set_used_variables_opt ?using:atts.using let vernac_fixpoint ~atts ~pm discharge l = let open DefAttributes in let scope = vernac_fixpoint_common ~atts discharge l in + let typing_flags = atts.typing_flags in if atts.program then (* XXX: Switch to the attribute system and match on ~atts *) - ComProgramFixpoint.do_fixpoint ~pm ~scope ~poly:atts.polymorphic ?using:atts.using l + ComProgramFixpoint.do_fixpoint ~pm ~scope ~poly:atts.polymorphic ?typing_flags ?using:atts.using l else - let () = ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic ?using:atts.using l in + let () = ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic ?typing_flags ?using:atts.using l in pm let vernac_cofixpoint_common ~atts discharge l = @@ -1829,11 +1846,11 @@ let vernac_print ~pstate = | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> - Notation.pr_scopes (Constrextern.without_symbols (pr_glob_constr_env env)) + Notation.pr_scopes (Constrextern.without_symbols (pr_glob_constr_env env sigma)) | PrintScope s -> - Notation.pr_scope (Constrextern.without_symbols (pr_glob_constr_env env)) s + Notation.pr_scope (Constrextern.without_symbols (pr_glob_constr_env env sigma)) s | PrintVisibility s -> - Notation.pr_visibility (Constrextern.without_symbols (pr_glob_constr_env env)) s + Notation.pr_visibility (Constrextern.without_symbols (pr_glob_constr_env env sigma)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> @@ -1867,9 +1884,9 @@ let vernac_locate ~pstate = let open Constrexpr in function | LocateTerm {v=AN qid} -> Prettyp.print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> - let _, env = get_current_or_global_context ~pstate in + let sigma, env = get_current_or_global_context ~pstate in Notation.locate_notation - (Constrextern.without_symbols (pr_glob_constr_env env)) ntn sc + (Constrextern.without_symbols (pr_glob_constr_env env sigma)) ntn sc | LocateLibrary qid -> print_located_library qid | LocateModule qid -> Prettyp.print_located_module qid | LocateOther (s, qid) -> Prettyp.print_located_other s qid diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index defb0691c0..2e360cf969 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -129,8 +129,6 @@ type option_setting = (** Identifier and optional list of bound universes and constraints. *) -type sort_expr = Sorts.family - type definition_expr = | ProveBody of local_binder_expr list * constr_expr | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr @@ -210,8 +208,8 @@ type proof_end = | Proved of opacity_flag * lident option type scheme = - | InductionScheme of bool * qualid or_by_notation * sort_expr - | CaseScheme of bool * qualid or_by_notation * sort_expr + | InductionScheme of bool * qualid or_by_notation * Sorts.family + | CaseScheme of bool * qualid or_by_notation * Sorts.family | EqualityScheme of qualid or_by_notation type section_subset_expr = @@ -341,7 +339,7 @@ type nonrec vernac_expr = | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of Glob_term.glob_constraint list + | VernacConstraint of univ_constraint_expr list (* Gallina extensions *) | VernacBeginSection of lident diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 57d9e0ac3c..e5971e1aaa 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -82,7 +82,9 @@ let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = match !default_timeout, timeout with | _, Some n | Some n, None -> - Control.timeout n f x CErrors.Timeout + (match Control.timeout n f x with + | None -> Exninfo.iraise (Exninfo.capture CErrors.Timeout) + | Some x -> x) | None, None -> f x |