diff options
670 files changed, 12167 insertions, 14937 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 56bd34f6fd..fe7913a3d2 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -16,8 +16,6 @@ /META.coq.in @coq/legacy-build-maintainers -/dev/build/windows @coq/windows-build-maintainers - ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers 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..754c09776e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,17 +9,18 @@ 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. e.g. + # echo $(md5sum dev/ci/docker/bionic_coq/Dockerfile | head -c 10) + CACHEKEY: "bionic_coq-V2020-12-25-95a34df128" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -59,6 +60,7 @@ before_script: - eval $(opam env) - opam list - opam config list + - dev/tools/check-cachekey.sh ################ GITLAB CACHING ###################### # - use artifacts between jobs # @@ -111,7 +113,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 +141,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 +156,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 +167,7 @@ before_script: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: + needs: - not-a-real-job script: - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/"' @@ -180,14 +179,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 +204,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,37 +247,27 @@ 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" -.windows-template: +.platform-template: stage: stage-1 interruptible: true + variables: + PLATFORM: "https://github.com/coq/platform/archive/master.zip" artifacts: - name: "%CI_JOB_NAME%" + name: "$CI_JOB_NAME" paths: - artifacts when: always expire_in: 1 week - dependencies: [] - tags: - - windows-inria - before_script: [] - script: - - call dev/ci/gitlab.bat - only: - variables: - - $WINDOWS =~ /enabled/ + before_script: [] # We don't want to use the shared 'before_script' .deploy-template: stage: deploy @@ -355,16 +344,13 @@ build:quick: when: always windows64: - extends: .windows-template + extends: .platform-template variables: ARCH: "64" - -windows32: - extends: .windows-template - variables: - ARCH: "32" - except: - - /^pr-.*$/ + script: + - call dev/ci/platform-windows.bat + tags: + - windows-inria lint: stage: stage-1 @@ -372,7 +358,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 +370,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 +393,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 +436,6 @@ pkg:nix:deploy:channel: - /^v.*\..*$/ variables: - $CACHIX_DEPLOYMENT_KEY - dependencies: [] needs: - pkg:nix:deploy script: @@ -475,8 +457,6 @@ pkg:nix: doc:refman: extends: .doc-template - dependencies: - - build:base needs: - build:base @@ -517,10 +497,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 +527,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 +540,6 @@ test-suite:base+32bit: test-suite:edge+flambda: extends: .test-suite-template - dependencies: - - build:edge+flambda needs: - build:edge+flambda variables: @@ -583,8 +553,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 +575,6 @@ test-suite:edge:dune:dev: variables: - $ONLY_WINDOWS == "true" interruptible: true - dependencies: [] script: - opam switch create $OCAMLVER --empty - eval $(opam env) @@ -636,8 +603,6 @@ test-suite:edge:dune:dev: test-suite:base+async: extends: .test-suite-template - dependencies: - - build:base needs: - build:base variables: @@ -650,15 +615,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 +628,6 @@ validate:base+32bit: validate:edge+flambda: extends: .validate-template - dependencies: - - build:edge+flambda needs: - build:edge+flambda variables: @@ -678,8 +637,6 @@ validate:edge+flambda: validate:quick: extends: .validate-template - dependencies: - - build:quick needs: - build:quick only: @@ -706,12 +663,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 +684,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 +712,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 +729,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 +767,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 +790,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 +815,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 +845,6 @@ plugin:ci-metacoq: needs: - build:base - plugin:ci-equations - dependencies: - - build:base - - plugin:ci-equations plugin:ci-mtac2: extends: .ci-template @@ -890,7 +861,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.doc b/Makefile.doc index a5ff8e0123..e9bc03565d 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -101,7 +101,7 @@ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf sphinx-clean: - rm -rf $(SPHINXBUILDDIR) + rm -rf $(SPHINXBUILDDIR) doc/sphinx/index.rst doc/sphinx/zebibliography.rst .PHONY: plugin-tutorial plugin-tutorial: states tools diff --git a/Makefile.ide b/Makefile.ide index 789acee5ec..6e3713c7bf 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -233,7 +233,6 @@ install-ide-info: .PHONY: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents: - rm -rdf $@ $(MKDIR) $@ sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/coqide/MacOS/Info.plist.template > $@/Info.plist $(MKDIR) "$@/MacOS" @@ -262,7 +261,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 +270,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 +281,11 @@ $(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 $@/../bin/*; \ + do \ + macpack -d ../lib $$i; \ + done + for i in $@/../loaders/*.so $@/../immodules/*.{dylib,so}; \ do \ macpack -d ../lib $$i; \ done @@ -297,7 +301,7 @@ $(COQIDEAPP):$(COQIDEAPP)/Contents/Resources ########################################################################### # This is either x86_64-w64-mingw32 or i686-w64-mingw32 -TARGET_ARCH=$(shell $CC -dumpmachine) +TARGET_ARCH=$(shell $(CC) -dumpmachine) %.o: %.rc $(SHOW)'WINDRES $<' @@ -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/checker/checker.ml b/checker/checker.ml index 08d92bb7b3..bdfc5f07be 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -289,7 +289,7 @@ let explain_exn = function Constr.debug_print a ++ fnl ()); Feedback.msg_notice (str"====== universes ====" ++ fnl () ++ (UGraph.pr_universes Univ.Level.pr - (ctx.Environ.env_stratification.Environ.env_universes))); + (UGraph.repr (ctx.Environ.env_stratification.Environ.env_universes)))); str "CantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" | IllFormedRecBody _ -> str"IllFormedRecBody" diff --git a/checker/values.ml b/checker/values.ml index 4e99d087df..907f9f7e32 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -147,7 +147,7 @@ let rec v_constr = [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) [|v_puniverses v_cons|]; (* Construct *) - [|v_caseinfo;v_constr;v_case_invert;v_constr;Array v_constr|]; (* Case *) + [|v_caseinfo;v_instance; Array v_constr; v_case_return; v_case_invert; v_constr; Array v_case_branch|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) @@ -160,7 +160,11 @@ and v_prec = Tuple ("prec_declaration", [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) -and v_case_invert = Sum ("case_inversion", 1, [|[|v_instance;Array v_constr|]|]) +and v_case_invert = Sum ("case_inversion", 1, [|[|Array v_constr|]|]) + +and v_case_branch = Tuple ("case_branch", [|Array (v_binder_annot v_name); v_constr|]) + +and v_case_return = Tuple ("case_return", [|Array (v_binder_annot v_name); v_constr|]) let v_rdecl = v_sum "rel_declaration" 0 [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) 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/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index 35d0379008..2550cbb31c 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -8,12 +8,12 @@ DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app -# Create a .app file with CoqIDE, without signing it -make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" - -# Add Coq to the .app file +# Install Coq into the .app file make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop +# Fill .app file with metadata and other .app specific stuff (like non-system .so) +make PRIVATEBINARIES="$APP" -j 1 -l2 "$APP" VERBOSE=1 + # Create the dmg bundle mkdir -p "$DMGDIR" ln -sf /Applications "$DMGDIR/Applications" diff --git a/dev/build/windows/CAVEATS.txt b/dev/build/windows/CAVEATS.txt deleted file mode 100644 index cb1ae3aaaf..0000000000 --- a/dev/build/windows/CAVEATS.txt +++ /dev/null @@ -1,22 +0,0 @@ -===== Environemt SIZE =====
-
-find and xargs can fail if the environment is to large. I think the limit is 8k.
-
-xargs --show-limits
-
-shows the actual environment size
-
-The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to
-avoid issues
-
-===== OCAMLLIB =====
-
-If the environment variable OCAMLLIB is defined, it takes precedence over the
-internal paths of ocaml tools. This usually messes up things considerably. A
-typical failure is
-
-Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application.
-
-The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml
-compiler from outside the provided cygwin shell, OCAMLLIB might be defined.
-
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat deleted file mode 100755 index 8eff2cf577..0000000000 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ /dev/null @@ -1,499 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== NOTES ==========
-
-REM For Cygwin setup command line options
-REM see https://cygwin.com/faq/faq.html#faq.setup.cli
-
-REM ========== DEFAULT VALUES FOR PARAMETERS ==========
-
-REM For a description of all parameters, see ReadMe.txt
-
-SET BATCHFILE=%~0
-SET BATCHDIR=%~dp0
-
-REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
-SET ARCH=x86_64
-
-REM see -mode in ReadMe.txt
-SET INSTALLMODE=absolute
-
-REM see -installer in ReadMe.txt
-SET MAKEINSTALLER=N
-
-REM see -ocaml in ReadMe.txt
-SET INSTALLOCAML=N
-
-REM see -make in ReadMe.txt
-SET INSTALLMAKE=N
-
-REM see -destcyg in ReadMe.txt
-SET DESTCYG=C:\bin\cygwin_coq
-
-REM see -destcoq in ReadMe.txt
-SET DESTCOQ=C:\bin\coq
-
-REM see -setup in ReadMe.txt
-SET SETUP=setup-x86_64.exe
-
-REM see -proxy in ReadMe.txt
-IF DEFINED HTTP_PROXY (
- SET PROXY=%HTTP_PROXY:http://=%
-) else (
- REM One can't set a variable to empty in DOS, but you can set it to a space this way.
- REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
- SET "PROXY= "
-)
-
-REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=https://mirrors.kernel.org/sourceware/cygwin
-
-REM see -cygcache in ReadMe.txt
-SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
-
-REM see -cyglocal in ReadMe.txt
-SET CYGWIN_FROM_CACHE=N
-
-REM see -cygquiet in ReadMe.txt
-SET CYGWIN_QUIET=Y
-
-REM see -srccache in ReadMe.txt
-SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
-
-REM see -coqver in ReadMe.txt
-SET COQ_VERSION=8.5pl3
-
-REM see -gtksrc in ReadMe.txt
-SET GTK_FROM_SOURCES=N
-
-REM see -threads in ReadMe.txt
-SET MAKE_THREADS=8
-
-REM see -addon in ReadMe.txt
-SET "COQ_ADDONS= "
-
-REM ========== PARSE COMMAND LINE PARAMETERS ==========
-
-SHIFT
-
-:Parse
-
-IF "%~0" == "-arch" (
- IF "%~1" == "32" (
- SET ARCH=i686
- SET SETUP=setup-x86.exe
- ) ELSE (
- IF "%~1" == "64" (
- SET ARCH=x86_64
- SET SETUP=setup-x86_64.exe
- ) ELSE (
- ECHO "Invalid -arch, valid are 32 and 64"
- GOTO :EOF
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-mode" (
- IF "%~1" == "mingwincygwin" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "absolute" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "relocatable" (
- SET INSTALLMODE=%~1
- ) ELSE (
- ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
- GOTO :EOF
- )
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-installer" (
- SET MAKEINSTALLER=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-ocaml" (
- SET INSTALLOCAML=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-make" (
- SET INSTALLMAKE=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcyg" (
- SET DESTCYG=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcoq" (
- SET DESTCOQ=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-setup" (
- SET SETUP=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-proxy" (
- SET PROXY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygrepo" (
- SET CYGWIN_REPOSITORY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygcache" (
- SET CYGWIN_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cyglocal" (
- SET CYGWIN_FROM_CACHE=%~1
- CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygquiet" (
- SET CYGWIN_QUIET=%~1
- CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-srccache" (
- SET SOURCE_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-coqver" (
- SET COQ_VERSION=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-gtksrc" (
- SET GTK_FROM_SOURCES=%~1
- CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-threads" (
- SET MAKE_THREADS=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-addon" (
- SET "COQ_ADDONS=%COQ_ADDONS% %~1"
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-
-IF NOT "%~0" == "" (
- ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
- ECHO !!! Illegal parameter %~0
- ECHO Usage:
- ECHO MakeCoq_MinGW
- CALL :PrintPars
- GOTO :EOF
-)
-
-IF NOT EXIST %SETUP% (
- ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
- ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option.
- GOTO :EOF
-)
-
-REM ========== ADJUST PARAMETERS ==========
-
-IF "%INSTALLMODE%" == "mingwincygwin" (
- SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
-)
-
-IF "%MAKEINSTALLER%" == "Y" (
- SET INSTALLMODE=relocatable
-)
-
-REM ========== CONFIRM PARAMETERS ==========
-
-CALL :PrintPars
-REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
-IF "%COQREGTESTING%"=="Y" (GOTO DontAsk)
- SET /p ANSWER="Is this correct? y/n "
- IF NOT "%ANSWER%"=="y" (GOTO :EOF)
-:DontAsk
-
-REM ========== DERIVED VARIABLES ==========
-
-SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
-SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
-SET TARGET_ARCH=%ARCH%-w64-mingw32
-SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-
-REM Convert paths to various formats
-REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH variable, which is : separated, so C: doesn't work.
-REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
-
-SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
-SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
-SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
-
-ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT%
-ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT%
-ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
-ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT%
-ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT%
-ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
-
-REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
-SET MAKE_OPT=-j %MAKE_THREADS%
-
-REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
-
-REM One can't set a variable to empty in DOS, but you can set it to a space this way.
-REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
-SET "CYGWIN_OPT= "
-
-IF "%CYGWIN_FROM_CACHE%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -L
-)
-
-IF "%CYGWIN_QUIET%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
-)
-
-IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-libxml2
- REM gtksourceview3 is always built from sources until the bug in DLLMain is fixed in cygwin
- REM SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtksourceview3.0
-)
-
-REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
-REM Otherwise chmod won't work and e.g. the ocaml build will fail.
-REM Cygwin setup does not touch the ACLs of existing folders.
-
-REM Run Cygwin Setup
-
-SET RUNSETUP=Y
-IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
- SET RUNSETUP=N
-)
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- SET RUNSETUP=Y
-)
-
-IF "%COQREGTESTING%" == "Y" (
- ECHO "========== REMOVE EXISTING CYGWIN =========="
- DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL
- SET RUNSETUP=Y
-)
-
-SET "EXTRAPACKAGES= "
-
-IF NOT "%APPVEYOR%" == "True" (
- SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5
-)
-
-ECHO "========== INSTALL CYGWIN =========="
-
-REM If you need to add packages, see https://cygwin.com/packages/package_list.html for package names
-REM In the description of each package you also find the file list and maintainer there
-
-IF "%RUNSETUP%"=="Y" (
- %SETUP% ^
- --proxy "%PROXY%" ^
- --site "%CYGWIN_REPOSITORY%" ^
- --root "%CYGWIN_INSTALLDIR_WFMT%" ^
- --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^
- --no-shortcuts ^
- %CYGWIN_OPT% ^
- -P make,unzip ^
- -P gdb,liblzma5 ^
- -P patch,automake1.14 ^
- -P pkg-config ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
- -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
- -P mingw64-%ARCH%-gmp,mingw64-%ARCH%-mpfr ^
- -P adwaita-icon-theme ^
- -P libiconv-devel,libunistring-devel,libncurses-devel ^
- -P gettext-devel,libgettextpo-devel ^
- -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
- -P libfontconfig1 ^
- -P gtk-update-icon-cache ^
- -P libtool,automake ^
- -P libgmp-devel ^
- -P intltool ^
- -P bison,flex ^
- %EXTRAPACKAGES% ^
- || GOTO ErrorExit
-
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs"
-)
-
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
- REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
- :waitsetup
- tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
- IF ERRORLEVEL 1 GOTO waitsetup
-)
-
-ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
-
-REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear
-REM HOME (otherwise we get to the home directory of the other installation)
-REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user)
-SET "HOME="
-SET "PROFILEREAD="
-
-copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit
-
-ECHO ========== BUILD COQ ==========
-
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
-RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-
-COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
-COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit
-
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit
-
-ECHO ========== FINISHED ==========
-
-GOTO :EOF
-
-ECHO ========== BATCH FUNCTIONS ==========
-
-:PrintPars
- REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
- ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
- ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absolute = install coq in -destcoq absolute path^>
- ECHO ^<relocatable = install relocatable coq in -destcoq path^>
- ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
- ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
- ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
- ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absolute/relocatable)^>
- ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
- ECHO -proxy ^<internet proxy^>
- ECHO -cygrepo ^<cygwin download repository^>
- ECHO -cygcache ^<local cygwin repository/cache^>
- ECHO -cyglocal ^<Y or N^> install cygwin from cache
- ECHO -cygquiet ^<Y or N^> install cygwin without user interaction
- ECHO -srccache ^<local source code repository/cache^>
- ECHO -coqver ^<Coq version to install^>
- ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version
- ECHO -threads ^<1..N^> Number of make threads
- ECHO -addon ^<name^> Enable building selected addon (can be repeated)
- ECHO(
- ECHO See ReadMe.txt for a detailed description of all parameters
- ECHO(
- ECHO Parameter values (default or currently set):
- ECHO -arch = %ARCH%
- ECHO -mode = %INSTALLMODE%
- ECHO -ocaml = %INSTALLOCAML%
- ECHO -installer= %MAKEINSTALLER%
- ECHO -make = %INSTALLMAKE%
- ECHO -destcyg = %DESTCYG%
- ECHO -destcoq = %DESTCOQ%
- ECHO -setup = %SETUP%
- ECHO -proxy = %PROXY%
- ECHO -cygrepo = %CYGWIN_REPOSITORY%
- ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
- ECHO -cyglocal = %CYGWIN_FROM_CACHE%
- ECHO -cygquiet = %CYGWIN_QUIET%
- ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
- ECHO -coqver = %COQ_VERSION%
- ECHO -gtksrc = %GTK_FROM_SOURCES%
- ECHO -threads = %MAKE_THREADS%
- ECHO -addon = %COQ_ADDONS%
- GOTO :EOF
-
-:CheckYN
- REM Reset errorlevel to 0
- CMD /c "EXIT /b 0"
- IF "%2" == "Y" (
- REM OK Y
- ) ELSE IF "%2" == "N" (
- REM OK N
- ) ELSE (
- ECHO ERROR Parameter %1 must be Y or N, but is %2
- GOTO ErrorExit
- )
- GOTO :EOF
-
-:ErrorExit
- ECHO ERROR MakeCoq_MinGW.bat failed
- EXIT /b 1
diff --git a/dev/build/windows/MakeCoq_SetRootPath.bat b/dev/build/windows/MakeCoq_SetRootPath.bat deleted file mode 100644 index bcb104772c..0000000000 --- a/dev/build/windows/MakeCoq_SetRootPath.bat +++ /dev/null @@ -1,27 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== CHOOSE A SENSIBLE ROOT PATH ========== - -@ ECHO OFF - -REM Figure out a root path for coq and cygwin - -REM For the \nul trick for testing folders see -REM https://support.microsoft.com/en-us/kb/65994 - -IF EXIST D:\bin\nul ( - SET ROOTPATH=D:\bin -) else if EXIST C:\bin ( - SET ROOTPATH=C:\bin -) else ( - SET ROOTPATH=C: -) - -ECHO ROOTPATH set to %ROOTPATH% diff --git a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat b/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat deleted file mode 100755 index d7d3c5b9d3..0000000000 --- a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_cachefolder_inst" ^
- -destcoq="%ROOTPATH%\coq64_cachefolder_inst" ^
- -cygcache="%ROOTPATH%\cache\cygwin" ^
- -srccache="%ROOTPATH%\cache\source"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_explicitcachefolders_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_local_installer.bat b/dev/build/windows/MakeCoq_local_installer.bat deleted file mode 100755 index 752b73c10a..0000000000 --- a/dev/build/windows/MakeCoq_local_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=/cygdrive/d/coqgit/coq-8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_local_inst" ^
- -destcoq="%ROOTPATH%\coq64_local_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_local_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_master_installer.bat b/dev/build/windows/MakeCoq_master_installer.bat deleted file mode 100755 index 72640d5d79..0000000000 --- a/dev/build/windows/MakeCoq_master_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-master ^
- -destcyg="%ROOTPATH%\cygwin_coq64_trunk_inst" ^
- -destcoq="%ROOTPATH%\coq64_trunk_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat deleted file mode 100644 index 7140a7c619..0000000000 --- a/dev/build/windows/MakeCoq_regtest_noproxy.bat +++ /dev/null @@ -1,29 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-SET HTTP_PROXY=
-SET HTTPS_PROXY=
-MKDIR C:\Temp\srccache
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver 8.5pl2 ^
- -srccache C:\Temp\srccache ^
- -cygquiet=Y ^
- -destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^
- -destcoq %ROOTPATH%\coq64_85pl2_abs
-
-pause
diff --git a/dev/build/windows/MakeCoq_regtests.bat b/dev/build/windows/MakeCoq_regtests.bat deleted file mode 100644 index 74c26456b4..0000000000 --- a/dev/build/windows/MakeCoq_regtests.bat +++ /dev/null @@ -1,36 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== RUN REGRESSION TESTS FOR COQ BUILD SCRIPTS ========== - -SET COQREGTESTING=Y - -REM Current stable -call MakeCoq_86git_abs_ocaml.bat || GOTO Error -call MakeCoq_86git_installer.bat || GOTO Error -call MakeCoq_86git_installer_32.bat || GOTO Error - -REM Old but might still be used -call MakeCoq_85pl3_abs_ocaml.bat || GOTO Error -call MakeCoq_84pl6_abs_ocaml.bat || GOTO Error - -REM Special variants, e.g. for debugging -call MakeCoq_86git_abs_ocaml_gtksrc.bat || GOTO Error -call MakeCoq_local_installer.bat || GOTO Error -call MakeCoq_explicitcachefolders_installer.bat || GOTO Error - -REM Bleeding edge -call MakeCoq_trunk_installer.bat || GOTO Error - -ECHO MakeCoq_regtests.bat: All tests finished successfully -GOTO :EOF - -:Error -ECHO MakeCoq_regtests.bat failed with error code %ERRORLEVEL% -EXIT /b %ERRORLEVEL% diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt deleted file mode 100644 index f34bbea4e9..0000000000 --- a/dev/build/windows/ReadMe.txt +++ /dev/null @@ -1,442 +0,0 @@ -(C) 2016 Intel Deutschland GmbH -Author: Michael Soegtrop - -Released to the public by Intel under the -GNU Lesser General Public License Version 2.1 or later -See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -This license also applies to all files in the patches_coq subfolder. - -==================== Purpose / Goal ==================== - -The main purpose of these scripts is to build Coq for Windows in a reproducible -and at least by this script documented way without using binary libraries and -executables from various sources. These scripts use only MinGW libraries -provided by Cygwin or compile things from sources. For some libraries there are -options to build them from sources or to use the Cygwin version. - -Another goal (which is not yet achieved) is to have a Coq installer for -Windows, which includes all tools required for native compute and Coq plugin -development without Cygwin. - -Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell. -Since the standard Windows OCaml installation requires Cygwin to deliver some of -these components, you might be able to imagine that this is not so easy. - -These scripts can produce the following: - -- Coq running on MinGW - -- OCaml producing MinGW code and running on MinGW - -- GCC producing MinGW code and running on MinGW - -- binutils producing MinGW code and running on MinGW - -With "running on MinGW" I mean that the tools accept paths like -"C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The -MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only -on Cygwin. - -With "producing MinGW code" I mean that the programs created by the tools accept -paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys -DLL. - -The missing piece is a posix shell running on plain Windows (without msys or -Cygwin DLL) and not being a binary from obscure sources. I am working on it ... - -Since compiling gcc and binutils takes a while and it is not of much use without -a shell, the building of these components is currently disabled. OCaml is built -anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is -used to compile Coq. - -Until the shell is there, the Cygwin created by these scripts is required to run -OCaml tools. When everything is finished, this will no longer be required. - -==================== Usage ==================== - -The Script MakeCoq_MinGW does: -- download Cygwin (except the Setup.exe or Setup64.exe) -- install Cygwin -- either installs MinGW GTK via Cygwin or compiles it fom sources -- download, compile and install OCaml, CamlP5, Menhir, lablgtk -- download, compile and install Coq -- download, compile and install selected addons -- create a Windows installer (NSIS based) - -The parameters are described below. Mostly paths and the HTTP proxy need to be -set. - -There are two main usages: - -- Compile and install OCaml and Coq in a given folder - - This works reliably, because absolute library paths can be compiled into Coq - and OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_abs_ocaml.bat for parameters. - -- Create a Windows installer. - - This works well for Coq but not so well for OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_installer.bat for parameters. - -There is also an option to compile OCaml and Coq inside Cygwin, but this is -currently not recommended. The resulting Coq and OCaml work, but Coq is slow -because it scans the largish Cygwin share folder. This will be fixed in a future -version. - -Procedure: - -- Unzip contents of CoqSetup.zip in a folder - -- Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat. - -- Download Cygwin setup from https://Cygwin.com/install.html - For 32 bit Coq : setup-x86.exe (https://Cygwin.com/setup-x86.exe) - For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe) - -- Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat - -- Check MakeCoq_regtests.bat to see what combinations of options are tested - -==================== MakeCoq_MinGW Parameters ==================== - -===== -arch ===== - -Set the target architecture. - -Possible values: - -32: Install/build Cygwin, ocaml and coq for 32 bit windows - -64: Install/build Cygwin, ocaml and coq for 64 bit windows - -Default value: 64 - - -===== -mode ===== - -Set the installation mode / target folder structure. - -Possible values: - -mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - Todo: The coq share folder should be configured to e.g. /share/coq. - As is, coqc scans the complete share folder, which slows it down 5x for short files. - -absolute: Install coq in the absolute path given with -destcoq. - The resulting Coq will not be relocatable. - That is the root folder must not be renamed/moved. - -relocatable: Install coq in the absolute path given with -destcoq. - The resulting Coq will be relocatable. - That is the root folder may be renamed/moved. - If OCaml is installed, please note that OCaml cannot be build really relocatable. - If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder. - Also the file <root>\libocaml\ld.conf must be adjusted. - -Default value: absolute - - -===== -installer ===== - -Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis) - -Possible values: - -Y: Create a windows installer - this forces -mode=relocatable. - -N: Don't create a windows installer - use the created Coq installation as is. - -Default value: N - - -===== -ocaml ===== - -Install OCaml for later use with Coq or just for building. - -Possible values: - -Y: Install OCaml in the same root as Coq (as given with -coqdest) - This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins. - -N: Install OCaml in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - -Default value: N - - -===== -make ===== - -Build and install MinGW GNU make - -Possible values: - -Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest). - -N: Don't build or install MinGW GNU make. - For building everything always Cygwin GNU make is used. - -Default value: Y - - -===== -destcyg ===== - -Destination folder in which Cygwin is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - ->>>>> This folder may be deleted after the Coq build is finished! <<<<< - -Default value: C:\bin\Cygwin_coq - - -===== -destcoq ===== - -Destination folder in which Coq is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - -This option is not required if -mode mingwinCygwin is used. - -Default value: C:\bin\coq - - -===== -setup ===== - -Name/path of the Cygwin setup program. - -The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe. -It can be downloaded from: https://Cygwin.com/install.html. - -Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch. - - -===== -proxy ===== - -Internet proxy setting for downloading Cygwin, ocaml and coq. - -The format is <server>:<port>, e.g. proxy.mycompany.com:911 - -The same proxy is used for HTTP, HTTPS and FTP. -If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13). - -Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist. - -ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to -supply a proxy server, but if this parameter is "", Cygwin setup might use proxy -settings from previous setups. If you once did a Cygwin setup behind a firewall -and now want to do a Cygwin setup without a firewall, use the -cygquiet=N -setting to perform a GUI install, where you can adjust the proxy setting. - -===== -cygrepo ===== - -The online repository, from which Cygwin packages are downloaded. - -Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin. - -Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32 - ->>>>> If you are not in Europe, you might want to change this! <<<<< - - -===== -cygcache ===== - -The local cache folder for Cygwin repositories. - -You can also copy files here from a backup/reference and set -cyglocal. -The setup will then not download/update from the internet but only use the local cache. - -Default value: <folder of MakeCoq_MinGW.bat>\Cygwin_cache - - -===== -cyglocal ===== - -Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder. - -Possible values: - -Y: Install exactly the Cygwin version from the local repository cache. - Don't update from the internet. - -N: Download the latest Cygwin version from the internet. - Update the local repository cache with the latest version. - -Default value: N - - -===== -cygquiet ===== - -Control if the Cygwin setup runs quietly or interactive. - -Possible values: - -Y: Install Cygwin quietly without user interaction. - -N: Install Cygwin interactively (allows to select additional packages). - -Default value: Y - - -===== -srccache ===== - -The local cache folder for ocaml/coq/... sources. - -Default value: <folder of MakeCoq_MinGW.bat>\source_cache - - -===== -coqver ===== - -The version of Coq to download and compile. - -Possible values: 8.4pl6, 8.5pl2, 8.5pl3, 8.6 - (download from https://coq.inria.fr/distrib/V$COQ_VERSION/files/coq-<version>.tar.gz) - Others versions might work, but are untested. - 8.4 is only tested in mode=absolute - - git-v8.6, git-trunk - (download from https://github.com/coq/coq/archive/<version without git->.zip) - - /cygdrive/.... - Use local folder. The sources are archived as coq-local.tar.gz - -Default value: 8.5pl3 - -If git- is prepended, the Coq sources are loaded from git. - -ATTENTION: with default options, the scripts cache source tar balls in two -places, the <destination>/build/tarballs folder and the <scripts>/source_cache -folder. If you modified something in git, you need to delete the cached tar ball -in both places! - -===== -gtksrc ===== - -Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used - -Possible values: - -Y: Build GTK from sources, takes about 90 minutes extra. - This is useful, if you want to debug/fix GTK or library issues. - -N: Use prebuilt MinGW libraries from Cygwin - - -===== -threads ===== - -Control the maximum number of make threads for modules which support parallel make. - -Possible values: 1..N. - Should not be more than 1.5x the number of cores. - Should not be more than available RAM/2GB (e.g. 4 for 8GB) - -===== -addon ===== - -Enable build and installation of selected Coq package (can be repeated for -selecting more packages) - -==================== TODO ==================== - -- Check for spaces in destination paths -- Check for = signs in all paths (DOS commands don't work with paths with = in it, possibly even when quoted) -- Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) -- CoqIDE doesn't find theme files -- Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) -- Possibly create/login as specific user to bash (not sure if it makes sense - need to create additional bash login link then) -- maybe move share/doc/menhir somewhere else (reduces coqc startup time) -- Use original installed file list for removing files in uninstaller - -==================== Issues with relocation ==================== - -Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer. -Some absolute paths in config files are patched in coq_new.nsi. - -Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=<installdir>. -OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files. -If you have issues with one of the remaining (unpatched) files below, please let me know. - -Text files patched by the installer: - -./ocamllib/ld.conf -./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" -./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" - -Text files containing the install folder path after install: - -./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 -./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml -./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin -./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf -./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma"; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) - -Binary files containing the build folder path after install: - -$ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches - -Binary files containing the install folder path after install: - -$ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqc.exe matches -Binary file ./bin/coqchk.exe matches -Binary file ./bin/coqdep.exe matches -Binary file ./bin/coqdoc.exe matches -Binary file ./bin/coqide.exe matches -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/coqworkmgr.exe matches -Binary file ./bin/coq_makefile.exe matches -Binary file ./bin/menhir matches -Binary file ./bin/ocaml.exe matches -Binary file ./bin/ocamlc.exe matches -Binary file ./bin/ocamlc.opt.exe matches -Binary file ./bin/ocamldebug.exe matches -Binary file ./bin/ocamldep.exe matches -Binary file ./bin/ocamldep.opt.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./bin/ocamlfind.exe matches -Binary file ./bin/ocamlmklib.exe matches -Binary file ./bin/ocamlobjinfo.exe matches -Binary file ./bin/ocamlopt.exe matches -Binary file ./bin/ocamlopt.opt.exe matches -Binary file ./bin/ocamlprof.exe matches -Binary file ./bin/ocamlrun.exe matches -Binary file ./bin/ocpp5.exe matches -Binary file ./lib/config/coq_config.cmo matches -Binary file ./lib/config/coq_config.o matches -Binary file ./lib/grammar/grammar.cma matches -Binary file ./lib/ide/coqide/ide_win32_stubs.o matches -Binary file ./lib/lib/clib.a matches -Binary file ./lib/lib/clib.cma matches -Binary file ./lib/libcoqrun.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches -Binary file ./libocaml/dynlink.cma matches -Binary file ./libocaml/expunge.exe matches -Binary file ./libocaml/extract_crc.exe matches -Binary file ./libocaml/libcamlrun.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.a matches -Binary file ./libocaml/site-lib/findlib/findlib.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh deleted file mode 100644 index 7e606b5544..0000000000 --- a/dev/build/windows/configure_profile.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### CONFIGURE CYGWIN USER PROFILE FOR BUILDING COQ ###################### - -rcfile=~/.bash_profile -donefile=~/.bash_profile.upated - -# to learn about `exec >> $file`, see https://www.tldp.org/LDP/abs/html/x17974.html -exec >> $rcfile - -if [ ! -f $donefile ] ; then - - if [ "$1" != "" ] && [ "$1" != " " ]; then - echo export http_proxy="http://$1" - echo export https_proxy="http://$1" - echo export ftp_proxy="http://$1" - fi - - mkdir -p "$RESULT_INSTALLDIR_CFMT/bin" - - # A tightly controlled path helps to avoid issues - # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! - # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH - # See cat /proc/mounts - echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" - - # find and xargs complain if the environment is larger than (I think) 8k. - # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit - echo unset ORIGINAL_PATH - # Other installations of OCaml will mess up things - echo unset OCAMLLIB - - touch $donefile -fi diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh deleted file mode 100644 index 543ca972cd..0000000000 --- a/dev/build/windows/difftar-folder.sh +++ /dev/null @@ -1,89 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### DIFF A TAR FILE AND A FOLDER ###################### - -set -o nounset - -# Print usage - -if [ "$#" -lt 2 ] ; then - echo 'Diff a tar (or compressed tar) file with a folder' - echo 'difftar-folder.sh <tarfile> <folder> [strip]' - echo '<tarfile> is the name of the tar file do diff with (required)' - echo '<folder> is the name of the folder to diff with (required)' - echo '<strip> is the number of path components to strip from tar file (default is 0)' - echo 'All files in the tar file must have at least <strip> path components.' - echo 'This also adds new files from folder.new, if folder.new exists' - exit 1 -fi - -# Parse parameters - -tarfile=$1 -folder=$2 - -if [ "$#" -ge 3 ] ; then - strip=$3 -else - strip=0 -fi - -# Get path prefix if --strip is used - -if [ "$strip" -gt 0 ] ; then - # Get the path/name of the first file from the tar and extract the first $strip path components - # This assumes that the first file in the tar file has at least $strip many path components - prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ -else - prefix= -fi - -# Original folder - -orig=$folder.orig -mkdir -p "$orig" - -# New amd empty filefolder - -new=$folder.new -empty=$folder.empty -mkdir -p "$empty" - -# Print information (this is ignored by patch) - -echo diff/patch file created on "$(date)" with: -echo difftar-folder.sh "$@" -echo TARFILE= "$tarfile" -echo FOLDER= "$folder" -echo TARSTRIP= "$strip" -echo TARPREFIX= "$prefix" -echo ORIGFOLDER= "$orig" - -# Make sure tar uses english output (for Mod time differs) -export LC_ALL=C - -# Search all files with a deviating modification time using tar --diff -tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do - # Substitute ': Mod time differs' with nothing - file=${file/: Mod time differs/} - # Check if file exists - if [ -f "$folder/$file" ] ; then - # Extract original file - tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" - # Compute diff - diff -u "$orig/$file" "$folder/$file" - fi -done - -if [ -d "$new" ] ; then - diff -u -r --unidirectional-new-file "$empty" "$new" -fi diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh deleted file mode 100755 index 6f6b3cd6d2..0000000000 --- a/dev/build/windows/makecoq_mingw.sh +++ /dev/null @@ -1,2031 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016..2018 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html -# -# With very valuable help on building GTK from -# https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack -# http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html - -###################### Script safety and debugging settings ###################### - -set -o nounset -set -o errexit -set -x -# Print current wall time as part of the xtrace -export PS4='+\t ' - -# Set this to 1 if all module directories shall be removed before build (no incremental make) -RMDIR_BEFORE_BUILD=1 - -###################### NOTES ##################### - -# - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin -# with all required packages and then calls this script. -# -# - This script uses set -o errexit, so if anything fails, the script will stop -# -# - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to -# /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix -# -# - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman, -# the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig -# -# - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode -# There are several possible solutions -# 1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path -# - doesn't work for pango because automake goes wild -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin -# - a bit dangerous because this exposes much more than required -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel -# - Possibly version compatibility issues -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# 4.) Build required tools for mingw and cygwin -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# -# We use method 3 below -# Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh) -# -# - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa. -# This is because the linker needs to load DLLs from C:\windows\system32, which contains -# both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using -# app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64. -# Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some -# folder without such black magic. -# -# - The file selection for the Coq Windows Installer is done with make install (unlike the original script) -# Relocatble builds are first configured with prefix=./ then build and then -# reconfigured with prefix=<installroot> before make install. - - -###################### ARCHITECTURES ##################### - -# The OS on which the build of the tool/lib runs -BUILD=$(gcc -dumpmachine) - -# The OS on which the tool runs -# "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine -HOST=$TARGET_ARCH - -# The OS for which the tool creates code/for which the libs are -TARGET=$TARGET_ARCH - -# Cygwin uses different arch name for 32 bit than mingw/gcc -case $ARCH in - x86_64) CYGWINARCH=x86_64 ;; - i686) CYGWINARCH=x86 ;; - *) false ;; -esac - -###################### PATHS ##################### - -# Name and create some 'global' folders -PATCHES=/build/patches -BUILDLOGS=/build/buildlogs -FLAGFILES=/build/flagfiles -TARBALLS=/build/tarballs -FILELISTS=/build/filelists - -mkdir -p $BUILDLOGS -mkdir -p $FLAGFILES -mkdir -p $TARBALLS -mkdir -p $FILELISTS -cd /build - -# Create source cache folder -mkdir -p "$SOURCE_LOCAL_CACHE_CFMT" - -# sysroot prefix for the above /build/host/target combination -# This must be in MFMT (C:/.../) because the OCaml library path is based on it and OCaml is a MinGW application. -PREFIXMINGW=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw - -# Install / Prefix folder for COQ -PREFIXCOQ=$RESULT_INSTALLDIR_MFMT - -# Install / Prefix folder for OCaml -if [ "$INSTALLOCAML" == "Y" ]; then - PREFIXOCAML=$PREFIXCOQ -else - PREFIXOCAML=$PREFIXMINGW -fi - -mkdir -p "$PREFIXMINGW/bin" -mkdir -p "$PREFIXCOQ/bin" -mkdir -p "$PREFIXOCAML/bin" - -# This is required for building addons and plugins -# This must be CFMT (/cygdrive/c/...) otherwise coquelicot 3.0.2 configure fails. -# coquelicot uses which ${COQBIN}/coqc to check if coqc exists. This does not work with COQBIN in MFMT. -export COQBIN=$RESULT_INSTALLDIR_CFMT/bin/ -# This must be MFMT (C:/) otherwise bignums 68a7a3d7e0b21985913a6c3ee12067f4c5ac4e20 fails -export COQLIB=$RESULT_INSTALLDIR_MFMT/lib/coq/ - -###################### Copy Cygwin Setup Info ##################### - -# Copy Cygwin repo ini file and installed files db to tarballs folder. -# Both files together document the exact selection and version of cygwin packages. -# Do this as early as possible to avoid changes by other setups (the repo folder is shared). - -# Escape URL to folder name -CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/ -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a} -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} - -# Copy files -cp "$CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini" $TARBALLS -cp /etc/setup/installed.db $TARBALLS - -###################### LOGGING ##################### - -# The folder which receives log files -mkdir -p buildlogs -LOGS=$(pwd)/buildlogs - -# The current log target (first part of the log file name) -LOGTARGET=other - -# For an explanation of ${COQREGTESTING:-N} search for ${parameter:-word} in -# http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html - -if [ "${COQREGTESTING:-N}" == "Y" ] ; then - # If COQREGTESTING, log to log files only - # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") - log1() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1_log.txt" 2>"$LOGS/$LOGTARGET-$1_err.txt" - } - - # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") - log2() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1-$2_log.txt" 2>"$LOGS/$LOGTARGET-$1-$2_err.txt" - } - - # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") - log_1_3() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1-$3_log.txt" 2>"$LOGS/$LOGTARGET-$1-$3_err.txt" - } - - # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") - logn() { - { local -; set +x; } 2> /dev/null - LOGTARGETEX=$1 - shift - "$@" >"$LOGS/$LOGTARGET-${LOGTARGETEX}_log.txt" 2>"$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" - } -else - # If COQREGTESTING, log to log files and console - # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") - log1() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1_log.txt" | sed -e "s/^/$LOGTARGET-$1_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1_err.txt" | sed -e "s/^/$LOGTARGET-$1_err.txt: /" 1>&2) - } - - # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") - log2() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2_log.txt" | sed -e "s/^/$LOGTARGET-$1-$2_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2_err.txt" | sed -e "s/^/$LOGTARGET-$1-$2_err.txt: /" 1>&2) - } - - # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") - log_1_3() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3_log.txt" | sed -e "s/^/$LOGTARGET-$1-$3_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3_err.txt" | sed -e "s/^/$LOGTARGET-$1-$3_err.txt: /" 1>&2) - } - - # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") - logn() { - { local -; set +x; } 2> /dev/null - LOGTARGETEX=$1 - shift - "$@" > >(tee "$LOGS/$LOGTARGET-${LOGTARGETEX}_log.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_err.txt: /" 1>&2) - } -fi - -###################### 'UNFIX' SED ##################### - -# In Cygwin SED used to do CR-LF to LF conversion, but since sed 4.4-1 this was changed -# We replace sed with a shell script which restores the old behavior for piped input - -#if [ -f /bin/sed.exe ] -#then -# mv /bin/sed.exe /bin/sed_orig.exe -#fi -#cat > /bin/sed << EOF -##!/bin/sh -#dos2unix | /bin/sed_orig.exe "$@" -#EOF -#chmod a+x /bin/sed - -###################### UTILITY FUNCTIONS ##################### - -# ------------------------------------------------------------------------------ -# Get a source tar ball, expand and patch it -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - extract source archive -# - patch source file if patch exists -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] expand folder name (if different from module name) -# $7 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function get_expand_source_tar { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - folder=$6 - else - folder=$name - fi - - if [ "$#" -ge 7 ] ; then - basename=$7 - else - basename=$name - fi - - # Set logging target - logtargetold=$LOGTARGET - LOGTARGET=$name - - # Get the source archive either from the source cache or online - if [ ! -f "$TARBALLS/$name.$3" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" - else - wget --progress=dot:giga "$1/$2.$3" - if file -i "$2.$3" | grep text/html; then - echo Download failed: "$1/$2.$3" - echo The file wget downloaded is an html file: - cat "$2.$3" - exit 1 - fi - if [ ! "$2.$3" == "$name.$3" ] ; then - mv "$2.$3" "$name.$3" - fi - mv "$name.$3" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$name.$3" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - # Remove build directory (clean build) - if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then - rm -f -r "$folder" - fi - - # Create build directory and cd - mkdir -p "$folder" - cd "$folder" - - # Extract source archive - if [ "$3" == "zip" ] ; then - log1 unzip "$TARBALLS/$name.$3" - if [ "$strip" == "1" ] ; then - # move subfolders of root folders one level up - find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; - else - echo "Unzip strip count not supported" - exit 1 - fi - else - logn untar tar xvaf "$TARBALLS/$name.$3" --strip $strip - fi - - # Patch if patch file exists - # First try specific patch file name then generic patch file name - # Note: set -o errexit does not work inside a function called in an if, so exit explicity. - if [ -f "$PATCHES/$name.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$name.patch" || exit 1 - elif [ -f "$PATCHES/$basename.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$basename.patch" || exit 1 - fi - - # Go back to base folder - cd .. - - LOGTARGET=$logtargetold -} - -# ------------------------------------------------------------------------------ -# Prepare a module build -# - check if build is already done (name.finished file exists) - if so return 1 -# - create name.started -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - cd to build folder and extract source archive -# - create bin_special subfolder and add it to $PATH -# - remember things for build_post -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function build_prep { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - basename=$6 - else - basename=$name - fi - - # Set installer section to not set by default - installersection= - - # Check if build is already done - if [ ! -f "$FLAGFILES/$name.finished" ] ; then - BUILD_PACKAGE_NAME=$name - BUILD_OLDPATH=$PATH - BUILD_OLDPWD=$(pwd) - LOGTARGET=$name - - touch "$FLAGFILES/$name.started" - - get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" "$name" "$basename" - - cd "$name" - - # Create a folder and add it to path, where we can put special binaries - # The path is restored in build_post - mkdir bin_special - PATH=$(pwd)/bin_special:$PATH - - return 0 - else - return 1 - fi -} - -# ------------------------------------------------------------------------------ -# Like build_prep, but gets the data from an entry in ci-basic-overlay.sh -# This assumes the following definitions exist in ci-basic-overlay.sh -# $1_CI_REF -# $1_CI_ARCHIVEURL -# $1_CI_GITURL -# ATTENTION: variables in ci-basic-overlay.sh are loaded by load_overlay_data. -# load_overlay_data is is called at the end of make_coq (even if the build is skipped) -# -# Parameters -# $1 base name of module in ci-basic-overlay.sh, e.g. mathcomp, bignums, ... -# ------------------------------------------------------------------------------ - -function build_prep_overlay { - urlvar=$1_CI_ARCHIVEURL - gitvar=$1_CI_GITURL - refvar=$1_CI_REF - url=${!urlvar} - git=${!gitvar} - ref=${!refvar} - ver=$(git ls-remote "$git" "refs/heads/$ref" | cut -f 1) - if [[ "$ver" == "" ]]; then - # $1_CI_REF must have been a tag or hash, not a branch - ver="$ref" - fi - build_prep "$url" "$ver" tar.gz 1 "$1-$ver" "$1" -} - -# ------------------------------------------------------------------------------ -# Load overlay version variables from ci-basic-overlay.sh -# ------------------------------------------------------------------------------ - -function load_overlay_data { - if [ -n "${GITLAB_CI-}" ]; then - export CI_BRANCH="$CI_COMMIT_REF_NAME" - if [[ ${CI_BRANCH#pr-} =~ ^[0-9]*$ ]]; then - export CI_PULL_REQUEST="${CI_BRANCH#pr-}" - else - export CI_PULL_REQUEST="" - fi - else - export CI_BRANCH="" - export CI_PULL_REQUEST="" - fi - - . /build/ci-basic-overlay.sh -} - -# ------------------------------------------------------------------------------ -# Finalize a module build -# - create name.finished -# - go back to base folder -# ------------------------------------------------------------------------------ - -function build_post { - if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then - cd "$BUILD_OLDPWD" - touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" - PATH=$BUILD_OLDPATH - LOGTARGET=other - installer_addon_end - fi -} - -# ------------------------------------------------------------------------------ -# Build and install a module using the standard configure/make/make install process -# - prepare build (as above) -# - configure -# - make -# - make install -# - finalize build (as above) -# -# parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 patch function to call between untar and configure (or true if none) -# $5.. extra configure arguments -# ------------------------------------------------------------------------------ - -function build_conf_make_inst { - if build_prep "$1" "$2" "$3" ; then - $4 - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" "${@:5}" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -# ------------------------------------------------------------------------------ -# Install all files given by a glob pattern to a given folder -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_glob { - SRCDIR=$(realpath -m $1) - DESTDIR=$(realpath -m $3) - ( cd "$SRCDIR" && find . -maxdepth 1 -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) -} - -# ------------------------------------------------------------------------------ -# Recursively Install all files given by a glob pattern to a given folder -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_rec { - SRCDIR=$(realpath -m $1) - DESTDIR=$(realpath -m $3) - ( cd "$SRCDIR" && find . -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) -} - -# ------------------------------------------------------------------------------ -# Write a file list of the target folder -# The file lists are used to create file lists for the windows installer -# Don't overwrite an existing file list -# -# parameters -# $1 name of file list -# ------------------------------------------------------------------------------ - -function list_files { - if [ ! -e "/build/filelists/$1" ] ; then - ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) - fi -} - -# ------------------------------------------------------------------------------ -# Write a file list of the target folder -# The file lists are used to create file lists for the windows installer -# Do overwrite an existing file list -# -# parameters -# $1 name of file list -# ------------------------------------------------------------------------------ - -function list_files_always { - ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) -} - -# ------------------------------------------------------------------------------ -# Compute the set difference of two file lists -# -# parameters -# $1 name of list A-B (set difference of set A minus set B) -# $2 name of list A -# $3 name of list B -# ------------------------------------------------------------------------------ - -function diff_files { - # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations - comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Filter a list of files with a regular expression -# -# parameters -# $1 name of output file list -# $2 name of input file list -# $3 name of filter regexp -# ------------------------------------------------------------------------------ - -function filter_files { - grep -E "$3" "/build/filelists/$2" > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Convert a file list to NSIS installer format -# -# parameters -# $1 name of file list file (output file is the same with extension .nsi) -# ------------------------------------------------------------------------------ - -function files_to_nsis { - # Split the path in the file list into path and filename and create SetOutPath and File instructions - # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does - # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time - tr '/' '\\' < "/build/filelists/$1" | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon section -# -# parameters -# $1 identifier of installer section and base name of file list files -# $2 human readable name of section -# $3 description of section -# $4 flags (space separated list of keywords): off = default off -# -# $1 must be a valid NSIS identifier! -# ------------------------------------------------------------------------------ - -function installer_addon_section { - installersection=$1 - list_files "addon_pre_$installersection" - - echo 'LangString' "DESC_$1" '${LANG_ENGLISH}' "\"$3\"" >> "/build/filelists/addon_strings.nsh" - - echo '!insertmacro MUI_DESCRIPTION_TEXT' '${'"Sec_$1"'}' '$('"DESC_$1"')' >> "/build/filelists/addon_descriptions.nsh" - - local sectionoptions= - if [[ "$4" == *off* ]] ; then sectionoptions+=" /o" ; fi - - echo "Section $sectionoptions \"$2\" Sec_$1" >> "/build/filelists/addon_sections.nsh" - echo 'SetOutPath "$INSTDIR\"' >> "/build/filelists/addon_sections.nsh" - echo '!include "..\..\..\filelists\addon_'"$1"'.nsh"' >> "/build/filelists/addon_sections.nsh" - echo 'SectionEnd' >> "/build/filelists/addon_sections.nsh" -} - -# ------------------------------------------------------------------------------ -# Start an installer addon dependency group -# -# parameters -# $1 identifier of the section which depends on other sections -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -dependencysections= - -function installer_addon_dependency_beg { - installer_addon_dependency "$1" - dependencysections="$1 $dependencysections" -} - -# ------------------------------------------------------------------------------ -# End an installer addon dependency group -# ------------------------------------------------------------------------------ - -function installer_addon_dependency_end { - set -- $dependencysections - shift - dependencysections="$*" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon dependency entry -# This needs to be bracketed with installer_addon_dependencies_beg/end -# -# parameters -# $1 identifier of the section on which other sections might depend -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -function installer_addon_dependency { - for section in $dependencysections ; do - echo '${CheckSectionDependency} ${Sec_'"$section"'} ${Sec_'"$1"'} '"'$section' '$1'" >> "/build/filelists/addon_dependencies.nsh" - done -} - -# ------------------------------------------------------------------------------ -# Finish an installer section after an addon build -# -# This creates the file list files -# -# parameters: none -# ------------------------------------------------------------------------------ - -function installer_addon_end { - if [ -n "$installersection" ]; then - list_files "addon_post_$installersection" - diff_files "addon_$installersection" "addon_post_$installersection" "addon_pre_$installersection" - files_to_nsis "addon_$installersection" - fi -} - -# ------------------------------------------------------------------------------ -# Set all timeouts in all .v files to 1000 -# Since timeouts can lead to CI failures, this is useful -# -# parameters: none -# ------------------------------------------------------------------------------ - -function coq_set_timeouts_1000 { - find . -type f -name '*.v' -print0 | xargs -0 sed -i 's/timeout\s\+[0-9]\+/timeout 1000/g' -} - -###################### MODULE BUILD FUNCTIONS ##################### - -##### SED ##### - -function make_sed { - if build_prep https://ftp.gnu.org/gnu/sed/ sed-4.2.2 tar.gz ; then - logn configure ./configure - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -##### LIBPNG ##### - -function make_libpng { - build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.34 tar.gz true -} - -##### PIXMAN ##### - -function make_pixman { - build_conf_make_inst http://cairographics.org/releases pixman-0.34.0 tar.gz true -} - -##### FREETYPE ##### - -function make_freetype { - build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.9.1 freetype-2.9.1 tar.bz2 true -} - -##### EXPAT ##### - -function make_expat { - build_conf_make_inst http://sourceforge.net/projects/expat/files/expat/2.1.0 expat-2.1.0 tar.gz true -} - -##### FONTCONFIG ##### - -function make_fontconfig { - make_freetype - make_expat - # CONFIGURE PARAMETERS - # build/install fails without --disable-docs - build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.12.93 tar.gz true --disable-docs -} - -##### ICONV ##### - -function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true -} - -##### UNISTRING ##### - -function make_libunistring { - build_conf_make_inst http://ftp.gnu.org/gnu/libunistring libunistring-0.9.5 tar.xz true -} - -##### NCURSES ##### - -function make_ncurses { - # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later. - # - # NOTE: make install fails building the terminfo database because - # : ${TIC_PATH:=unknown} in run_tic.sh - # As a result pkg-config .pc files are not generated - # Also configure of gettext gives two "considers" - # checking where terminfo library functions come from... not found, consider installing GNU ncurses - # checking where termcap library functions come from... not found, consider installing GNU ncurses - # gettext make/make install work anyway - # - # CONFIGURE PARAMETERS - # --enable-term-driver --enable-sp-funcs is required for mingw (see README.MinGW) - # additional changes - # ADD --with-pkg-config - # ADD --enable-pc-files - # ADD --without-manpages - # REM --with-pthread - build_conf_make_inst http://ftp.gnu.org/gnu/ncurses ncurses-5.9 tar.gz true --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages -} - -##### GETTEXT ##### - -function make_gettext { - # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel - # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel - # gettext configure complains that ncurses is also required, but it builds without it - # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses - make_libiconv - make_libunistring - build_conf_make_inst http://ftp.gnu.org/pub/gnu/gettext gettext-0.19 tar.gz true -} - -##### LIBFFI ##### - -function make_libffi { - # NOTE: The official download server is down ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz - build_conf_make_inst http://www.mirrorservice.org/sites/sourceware.org/pub/libffi libffi-3.2.1 tar.gz true -} - -##### LIBEPOXY ##### - -function make_libepoxy { - build_conf_make_inst https://github.com/anholt/libepoxy/releases/download/v1.3.1 libepoxy-1.3.1 tar.bz2 true -} - -##### LIBPCRE ##### - -function make_libpcre { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre-8.39 tar.bz2 true -} - -function make_libpcre2 { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre2-10.22 tar.bz2 true -} - -##### GLIB ##### - -function make_glib { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_gettext - make_libffi - make_libpcre - - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true - -} - -##### ATK ##### - -function make_atk { - make_gettext - make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true -} - -##### PIXBUF ##### - -function make_gdk-pixbuf { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_gettext - make_glib - # CONFIGURE PARAMETERS - # --with-included-loaders=yes statically links the image file format handlers - # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes -} - -##### CAIRO ##### - -function make_cairo { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_glib - make_pixman - make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true -} - -##### PANGO ##### - -function make_pango { - make_cairo - make_glib - make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true -} - -##### GTK3 ##### - -function make_gtk3 { - - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true - fi - - # make all incl. tests and examples runs through fine - # make install fails with issue with - # - # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' - # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" - # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory - # Makefile:1373: recipe for target 'install-update-icon-cache' failed - # make[5]: *** [install-update-icon-cache] Error 1 - # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' -} - -##### LIBXML2 ##### - -function make_libxml2 { - # Cygwin packet dependencies: libtool automake - # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 - # Note: python binding requires <sys/select.h> which doesn't exist on cygwin - if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then - # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXMINGW" --disable-shared --without-python - # shared library required by gtksourceview - ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" --without-python - # shellcheck disable=SC2086 - log1 make $MAKE_OPT all - log2 make install - log2 make clean - build_post - fi -} - -##### GTK-SOURCEVIEW3 ##### - -function make_gtk_sourceview3 { - # Cygwin packet dependencies: intltool - # Note: this is always built from sources cause of a bug in the cygwin delivery. - # Just dependencies are only built if we build from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk3 - make_libxml2 - fi - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config -} - -##### LN replacement ##### - -# Note: this does support symlinks, but symlinks require special user rights on Windows. -# ocamlbuild uses symlinks to link the executables in the build folder to the base folder. -# For this purpose hard links are better. - -function make_ln { - if [ ! -f $FLAGFILES/myln.finished ] ; then - touch $FLAGFILES/myln.started - mkdir -p myln - ( cd myln - cp $PATCHES/ln.c . - "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c - install -D ln.exe "$PREFIXCOQ/bin/ln.exe" - ) - touch $FLAGFILES/myln.finished - fi -} - -##### ARCH-pkg-config replacement ##### - -# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. -# This builds a binary replacement for the shell script and puts it into the bin_special folder. -# There is no global installation since it is module specific what pkg-config is needed under what name. - -function make_arch_pkg_config { - gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c -} - -##### OCAML ##### - -function make_ocaml { - if build_prep https://github.com/ocaml/ocaml/archive 4.08.1 tar.gz 1 ocaml-4.08.1 ; then - # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc - - # get flexdll sources into folder ./flexdll - get_expand_source_tar https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 flexdll - - # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder - logn configure ./configure --build=i686-pc-cygwin --host="$TARGET_ARCH" --prefix="$PREFIXOCAML" --libdir="$PREFIXOCAML/libocaml" - - log2 make flexdll $MAKE_OPT - # Note the next command might change after 4.09.x to just make - # see https://github.com/ocaml/ocaml/blob/4.09/README.win32.adoc - # compare to https://github.com/ocaml/ocaml/blob/4.10/README.win32.adoc - log2 make world.opt $MAKE_OPT - log2 make flexlink.opt $MAKE_OPT - log2 make install $MAKE_OPT - - # Move license files and other into into special folder - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - mkdir -p "$PREFIXOCAML/license_readme/ocaml" - # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. - rm -f ./*.txt - cp LICENSE "$PREFIXOCAML/license_readme/ocaml/License.txt" - cp INSTALL.adoc "$PREFIXOCAML/license_readme/ocaml/Install.txt" - cp README.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMe.txt" - cp README.win32.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt" - cp VERSION "$PREFIXOCAML/license_readme/ocaml/Version.txt" - cp Changes "$PREFIXOCAML/license_readme/ocaml/Changes.txt" - fi - - # Since 4.07 this library is part of ocaml - mkdir -p "$PREFIXOCAML/libocaml/site-lib/seq/" - cat > "$PREFIXOCAML/libocaml/site-lib/seq/META" <<EOT -name="seq" -version="[distributed with OCaml 4.07 or above]" -description="dummy backward-compatibility package for iterators" -requires="" -EOT - - build_post - fi -} - -##### OCAML EXTRA TOOLS ##### - -function make_ocaml_tools { - make_findlib -} - -##### OCAML EXTRA LIBRARIES ##### - -function make_ocaml_libs { - make_num - make_zarith - make_findlib - make_lablgtk -} - -##### Ocaml num library ##### -function make_num { - make_ocaml - # We need this commit due to windows fixed, IMHO this is better than patching v1.1. - if build_prep https://github.com/ocaml/num/archive 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then - log2 make all - # log2 make test - log2 make install - log2 make clean - build_post - fi -} - -function make_zarith { - make_ocaml - if build_prep https://github.com/ocaml/Zarith/archive release-1.10 tar.gz 1 zarith-1.10; then - logn configure ./configure - log1 make - log2 make install - build_post - fi -} - -##### OCAMLBUILD ##### - -function make_ocamlbuild { - make_ocaml - if build_prep https://github.com/ocaml/ocamlbuild/archive 0.14.0 tar.gz 1 ocamlbuild-0.14.0; then - log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -##### FINDLIB Ocaml library manager ##### - -function make_findlib { - make_ocaml - make_ocamlbuild - # Note: latest is 1.8.1 but http://projects.camlcity.org/projects/dl/findlib-1.8.1/doc/README says this is for OCaml 4.09 - if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then - logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" - # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT - log2 make all - log2 make opt - log2 make install - log2 make clean - # Add Coq install library path to ocamlfind config file - # $(ocamlfind printconf conf | tr -d '\r') is the name of the config file - # printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g' is the coq lib path double escaped for sed - sed -i -e 's|path="\(.*\)"|path="\1;'$(printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g')'"|' $(ocamlfind printconf conf | tr -d '\r') - build_post - fi -} - -##### Dune build system ##### - -function make_dune { - make_ocaml - - if build_prep https://github.com/ocaml/dune/archive/ 2.0.0 tar.gz 1 dune-2.0.0 ; then - - log2 make release - log2 make install - - # Dune support libs, we don't install glob and action-plugin as - # they are not needed by Coq - logn dune-private-build dune build -p dune-private-libs @install - logn dune-private-install dune install dune-private-libs - - logn dune-configurator-build dune build -p dune-configurator @install - logn dune-configurator-install dune install dune-configurator - - logn dune-build-info dune build -p dune-build-info @install - logn dune-build-info dune install dune-build-info - - build_post - fi -} - -##### MENHIR Ocaml Parser Generator ##### - -function make_menhir { - make_ocaml - make_findlib - make_ocamlbuild - if build_prep https://gitlab.inria.fr/fpottier/menhir/-/archive/20200525 menhir-20200525 tar.gz 1 ; then - # ToDo: don't know if this is the intended / most reliable to do it, but it works - log2 dune build @install - log2 dune install menhir menhirSdk menhirLib - build_post - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel711 tar.gz 1 camlp5-rel711; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - cp lib/*.a "$PREFIXOCAML/libocaml/camlp5/" - log2 make clean - # For some reason META is not built / copied, but it is required - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - -##### LABLGTK Ocaml GTK binding ##### - -# Note: when rebuilding lablgtk by deleting the .finished file, -# also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib -# Otherwise make install fails - -function make_ocaml_cairo2 { - if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then - make_arch_pkg_config - - log2 dune build cairo2.install - log2 dune install cairo2 - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - - fi -} - -function make_lablgtk { - make_ocaml - make_findlib - make_dune - make_gtk3 - make_gtk_sourceview3 - make_ocaml_cairo2 - - if build_prep https://github.com/garrigue/lablgtk/archive 3.0.beta5 tar.gz 1 lablgtk-3.0.beta5 ; then - make_arch_pkg_config - - # lablgtk3 includes more packages that are not relevant for Coq, - # such as gtkspell - log2 dune build -p lablgtk3 - log2 dune install lablgtk3 - - log2 dune build -p lablgtk3-sourceview3 - log2 dune install lablgtk3-sourceview3 - - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - fi -} - -##### Elpi ##### - -function make_seq { - make_ocaml - # since 4.07 this package is part of ocaml - -} - -function make_re { - make_ocaml - make_dune - make_seq - - if build_prep https://github.com/ocaml/ocaml-re/archive 1.9.0 tar.gz 1 ocaml-re; then - - log2 dune build -p re - log2 dune install re - - build_post - fi - -} - -function make_elpi { - make_ocaml - make_findlib - make_camlp5 - make_dune - make_re - - if build_prep https://github.com/LPCIC/elpi/archive v1.11.4 tar.gz 1 elpi; then - - log2 dune build -p elpi - log2 dune install elpi - - build_post - - fi - -} - -##### COQ ##### - -# Copy one DLLfrom cygwin MINGW packages to Coq install folder - -function copy_coq_dll { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - cp "$PREFIXMINGW/bin/$1" "$PREFIXCOQ/bin/$1" - fi -} - -# Copy required DLLs from cygwin MINGW packages to Coq install folder - -function copy_coq_dlls { - # HOW TO CREATE THE DLL LIST - # With the list empty, after the build/install is finished, open coqide in dependency walker. - # See http://www.dependencywalker.com/ - # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture. - # Select all missing DLLs from the module list, right click "copy filenames" - # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) - # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. - # Do the same for coqc and ocamlc (usually doesn't result in additional files) - - copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBFONTCONFIG-1.DLL - copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-3-0.DLL - copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-3-0.DLL - copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL - copy_coq_dll LIBPANGO-1.0-0.DLL - copy_coq_dll LIBATK-1.0-0.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBCAIRO-GOBJECT-2.DLL - copy_coq_dll LIBEPOXY-0.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL - copy_coq_dll LIBGIO-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL - copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL - copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll LIBPCRE-1.DLL - copy_coq_dll LIBPIXMAN-1-0.DLL - copy_coq_dll LIBPNG16-16.DLL - copy_coq_dll LIBXML2-2.DLL - copy_coq_dll ZLIB1.DLL - copy_coq_dll ICONV.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - - # Depends on if GTK is built from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - echo "Building GTK from sources is currently not supported" - exit 1 - fi; - - # Architecture dependent files - case $ARCH in - x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;; - i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; - *) false ;; - esac - - # Win pthread version change - copy_coq_dll LIBWINPTHREAD-1.DLL -} - -function copy_coq_objects { - # copy objects only from folders which exist in the target lib directory - find . -type d | while read -r FOLDER ; do - if [ -e "$PREFIXCOQ/lib/coq/$FOLDER" ] ; then - install_glob "$FOLDER" '*.cmxa' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cmi' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cma' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cmo' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.a' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.o' "$PREFIXCOQ/lib/coq/$FOLDER" - fi - done -} - -# Copy required GTK config and support files -# This must be called from inside the coq build folder! - -function copy_coq_gtk { - - glib-compile-schemas $PREFIXMINGW/share/glib-2.0/schemas/ - echo 'gtk-theme-name = "Default"' > "$PREFIXMINGW/etc/gtk-3.0/gtkrc" - - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIXMINGW/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" - install -D -T "$PREFIXMINGW/share/glib-2.0/schemas/gschemas.compiled" "$PREFIXCOQ/share/glib-2.0/schemas/gschemas.compiled" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" - install -D -T "ide/coqide/coq.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq.lang" - install -D -T "ide/coqide/coq-ssreflect.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq-ssreflect.lang" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" - install -D -T "ide/coqide/coq_style.xml" "$PREFIXCOQ/share/gtksourceview-3.0/styles/coq_style.xml" - - install_rec "$PREFIXMINGW/share/themes" '*' "$PREFIXCOQ/share/themes" - - FOLDERS="" - # The sizes include all default sizes given in index.theme - # The types used haven been recorded with ProcMon in an installation with all icons present - for SIZE in 16x16 22x22 32x32 48x48; do - for TYPE in \ - actions/bookmark actions/document devices/drive actions/format-text actions/go actions/list \ - actions/media actions/pan actions/process actions/system actions/window \ - mimetypes/text places/folder places/user status/dialog - do - CLASS=$(dirname $TYPE) - ICON=$(basename $TYPE) - if [[ ! "$FOLDERS" =~ "$SIZE/$CLASS" ]] ;then - FOLDERS="$FOLDERS$SIZE/$CLASS," - fi - install_rec "/usr/share/icons/Adwaita/$SIZE/$CLASS" "$ICON*" "$PREFIXCOQ/share/icons/Adwaita/$SIZE/$CLASS" - done - done - echo Folders=$FOLDERS - install -D -T "/usr/share/icons/Adwaita/index.theme" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - sed -i "s|^Directories=.*|Directories=$FOLDERS|" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - gtk-update-icon-cache -f "$PREFIXCOQ/share/icons/Adwaita/" - - # This below item look like a bug in make install - # if [ -d "$PREFIXCOQ/share/coq/" ] ; then - # COQSHARE="$PREFIXCOQ/share/coq/" - # else - # COQSHARE="$PREFIXCOQ/share/" - # fi - - # mkdir -p "$PREFIXCOQ/ide/coqide" - # mv "$COQSHARE"*.png "$PREFIXCOQ/ide/coqide" - # rmdir "$PREFIXCOQ/share/coq" || true - fi -} - -# Copy license and other info files - -function copy_coq_license { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install -D doc/LICENSE "$PREFIXCOQ/license_readme/coq/LicenseDoc.txt" - install -D LICENSE "$PREFIXCOQ/license_readme/coq/License.txt" - install -D plugins/micromega/LICENSE.sos "$PREFIXCOQ/license_readme/coq/LicenseMicromega.txt" - # FIXME: this is not the micromega license - # It only applies to code that was copied into one single file! - install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D INSTALL.md "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true - fi -} - -# Main function for creating Coq - -function make_coq { - make_ocaml - make_num - make_findlib - make_lablgtk - if - case $COQ_VERSION in - # e.g. git-v8.6 => download from https://github.com/coq/coq/archive/v8.6.zip - # e.g. git-trunk => download from https://github.com/coq/coq/archive/trunk.zip - git-*) - COQ_BUILD_PATH=/build/coq-${COQ_VERSION} - build_prep https://github.com/coq/coq/archive "${COQ_VERSION##git-}" zip 1 "coq-${COQ_VERSION}" - ;; - - # e.g. /cygdrive/d/coqgit - /*) - # Todo: --exclude-vcs-ignores doesn't work because tools/coqdoc/coqdoc.sty is excluded => fix .gitignore - # But this is not a big deal, only 2 files are removed with --exclude-vcs-ignores from a fresch clone - COQ_BUILD_PATH=/build/coq-local - tar -zcf $TARBALLS/coq-local.tar.gz --exclude-vcs -C "${COQ_VERSION%/*}" "${COQ_VERSION##*/}" - build_prep NEVER-DOWNLOADED coq-local tar.gz - ;; - - # e.g. 8.6 => https://coq.inria.fr/distrib/8.6/files/coq-8.6.tar.gz - *) - COQ_BUILD_PATH=/build/coq-$COQ_VERSION - build_prep "https://coq.inria.fr/distrib/V$COQ_VERSION/files" "coq-$COQ_VERSION" tar.gz - ;; - esac - then - if [ "$INSTALLMODE" == "relocatable" ]; then - # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man - elif [ "$INSTALLMODE" == "absolute" ]; then - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - else - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" - fi - - # 8.4x doesn't support parallel make - if [[ $COQ_VERSION == 8.4* ]] ; then - log1 make - else - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - fi - - if [ "$INSTALLMODE" == "relocatable" ]; then - logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - fi - - log2 make install - log1 copy_coq_dlls - log1 copy_coq_gtk - - if [ "$INSTALLOCAML" == "Y" ]; then - copy_coq_objects - fi - - log1 copy_coq_license - - # make clean seems to be broken for 8.5pl2 - # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile - # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" - # make clean - - # Copy these files somewhere the plugin builds can find them - logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ - - build_post - fi - - load_overlay_data -} - -##### GNU Make for MinGW ##### - -function make_mingw_make { - if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then - # The config.h.win32 file is fine - don't edit it - # We need to copy the mingw gcc here as "gcc" - then the batch file will use it - cp "/usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe" ./gcc.exe - # By some magic cygwin bash can run batch files - logn build ./build_w32.bat gcc - # Copy make to Coq folder - cp GccRel/gnumake.exe "$PREFIXCOQ/bin/make.exe" - build_post - fi -} - -##### GNU binutils for native OCaml ##### - -function make_binutils { - if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### GNU GCC for native OCaml ##### - -function make_gcc { - # Note: the bz2 file is smaller, but decompressing bz2 really takes ages - if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then - # This is equivalent to "contrib/download_prerequisites" but uses caching - # Update versions when updating gcc version - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure gmp-4.3.2 tar.bz2 1 gmp-4.3.2 gmp - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpc-0.8.1 tar.gz 1 mpc-0.8.1 mpc - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure isl-0.14 tar.bz2 1 isl-0.14 isl - - # For whatever reason gcc needs this (although it never puts anything into it) - # Error: "The directory that should contain system headers does not exist:" - # mkdir -p /mingw/include without --with-sysroot - mkdir -p "$PREFIXCOQ/mingw/include" - - # See https://gcc.gnu.org/install/configure.html - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" \ - --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" --disable-win32-registry --with-sysroot="$PREFIXCOQ" \ - --enable-languages=c --disable-nls \ - --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto - # --disable-decimal-float seems to be required - # --with-sysroot="$PREFIXMINGW" results in configure error that this is not an absolute path - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### Get sources for Cygwin MinGW packages ##### - -function get_cygwin_mingw_sources { - if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then - touch $FLAGFILES/cygwin_mingw_sources.started - - # Find all installed files with mingw in the name and download the corresponding source code file from cygwin - # Steps: - # grep /etc/setup/installed.db for mingw => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1 - # remove archive ending and trailing number => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2 - # replace space with / => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2 - # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2 - # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line) - # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line. - # We could strip off the path and just grep for the file, though. - # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705 - # source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95 - # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - - grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read -r ARCHIVE ; do - local ARCHIVEESC=${ARCHIVE//+/\\+} - local SOURCE - SOURCE=$(grep -E -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2) - local SOURCEFILE=${SOURCE##*/} - - # Get the source file (either from the source cache or online) - if [ ! -f "$TARBALLS/$SOURCEFILE" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS - else - wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" - mv "$SOURCEFILE" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$SOURCEFILE" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - done - - touch $FLAGFILES/cygwin_mingw_sources.finished - fi -} - -##### Coq Windows Installer ##### - -function make_coq_installer { - make_coq - get_cygwin_mingw_sources - - # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: - # ocaml: ocaml + menhir + camlp5 + findlib - # ocaml_coq: as above + coq - # ocaml_coq_addons: as above + lib/user-contrib/* - - # Create coq file list as ocaml_coq / ocaml - diff_files coq ocaml_coq ocaml - - # Filter out object files - filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' - - # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/coq/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' - - # Coq objects objects required for plugin development = coq objects except those for pre installed plugins - diff_files coq_plugindev coq_objects coq_objects_plugins - - # Addons (TODO: including objects that could go to the plugindev thing, but - # then one would have to make that package depend on this one, so not - # implemented yet) - diff_files coq_addons ocaml_coq_addons ocaml_coq - - # Coq files, except objects needed only for plugin development - diff_files coq_base coq coq_plugindev - - # Convert section files to NSIS format - files_to_nsis coq_base - files_to_nsis coq_addons - files_to_nsis coq_plugindev - files_to_nsis ocaml - - # Get and extract NSIS Binaries - if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then - NSIS=$(pwd)/makensis.exe - chmod u+x "$NSIS" - # Change to Coq folder - cd "$COQ_BUILD_PATH" - # Copy patched nsi file - cp ../patches/coq_new.nsi dev/nsis - cp ../patches/StrRep.nsh dev/nsis - cp ../patches/ReplaceInFile.nsh dev/nsis - VERSION=$(grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r') - cd dev/nsis - logn nsis-installer "$NSIS" -DVERSION="$VERSION" -DARCH="$ARCH" -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coqide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi - - build_post - fi -} - -###################### ADDON COQ LIBRARIES / PLUGINS / TOOLS ##################### - -# The bignums library -# Provides BigN, BigZ, BigQ that used to be part of Coq standard library - -function make_addon_bignums { - installer_addon_dependency bignums - if build_prep_overlay bignums; then - installer_addon_section bignums "Bignums" "Coq library for fast arbitrary size numbers" "" - # To make command lines shorter :-( - echo 'COQ_SRC_SUBDIRS:=$(filter-out plugins/%,$(COQ_SRC_SUBDIRS)) plugins/syntax' >> Makefile.coq.local - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - -# Equations plugin -# A function definition plugin - -function make_addon_equations { - installer_addon_dependency equations - if build_prep_overlay equations; then - installer_addon_section equations "Equations" "Coq plugin for defining functions by equations" "" - # Note: PATH is automatically saved/restored by build_prep / build_post - PATH=$COQBIN:$PATH - logn coq_makefile ${COQBIN}coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# mathcomp - ssreflect and mathematical components library - -function make_addon_mathcomp { - installer_addon_dependency mathcomp - if build_prep_overlay mathcomp; then - installer_addon_section mathcomp "Math-Components" "Coq library with mathematical components" "" - cd mathcomp - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# ssreflect part of mathcomp - -function make_addon_ssreflect { - # if mathcomp addon is requested, build this instead - if [[ "$COQ_ADDONS" == *mathcomp* ]]; then - make_addon_mathcomp - else - # Note: since either mathcomp or ssreflect is defined, it is fine to name both mathcomp - installer_addon_dependency ssreflect - if build_prep_overlay mathcomp; then - installer_addon_section ssreflect "SSReflect" "Coq support library for small scale reflection plugin" "" - cd mathcomp - logn make-makefile make Makefile.coq - logn make-ssreflect make $MAKE_OPT -f Makefile.coq ssreflect/all_ssreflect.vo - logn make-install make -f Makefile.coq install - build_post - fi - fi -} - -# UniCoq plugin -# An alternative unification algorithm -function make_addon_unicoq { - installer_addon_dependency unicoq - if build_prep_overlay unicoq; then - installer_addon_section unicoq "Unicoq" "Coq plugin for an enhanced unification algorithm" "" - log1 coq_makefile -f Make -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Mtac2 plugin -# An alternative typed tactic language -function make_addon_mtac2 { - installer_addon_dependency_beg mtac2 - make_addon_unicoq - installer_addon_dependency_end - if build_prep_overlay mtac2; then - installer_addon_section mtac2 "Mtac-2" "Coq plugin for a typed tactic language for Coq." "" - log1 coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Menhir parser generator - -function make_addon_menhir { - make_menhir - # If COQ and OCaml are installed to the same folder, there is nothing to do - installer_addon_dependency menhir - if [ "$PREFIXOCAML" != "$PREFIXCOQ" ] ; then - # Just install menhir files required for COQ to COQ target folder - if [ ! -f "$FLAGFILES/menhir-addon.finished" ] ; then - installer_addon_section menhir "Menhir" "Menhir parser generator windows executable and libraries" "" - LOGTARGET=menhir-addon - touch "$FLAGFILES/menhir-addon.started" - # Menhir executable - install_glob "$PREFIXOCAML/bin" 'menhir.exe' "$PREFIXCOQ/bin/" - # Menhir PDF doc - install_glob "$PREFIXOCAML/doc/menhir/" '*.pdf' "$PREFIXCOQ/doc/menhir/" - touch "$FLAGFILES/menhir-addon.finished" - LOGTARGET=other - installer_addon_end - fi - fi -} - -# COQ library for Menhir - -function make_addon_menhirlib { - installer_addon_dependency menhirlib - if build_prep_overlay menhirlib; then - installer_addon_section menhirlib "Menhirlib" "Coq support library for using Menhir generated parsers in Coq" "" - # The supplied makefiles don't work in any way on cygwin - # ToDo: dune also doesn't seem to work for the coq files - cd coq-menhirlib/src - echo -R . MenhirLib > _CoqProject - ls -1 *.v >> _CoqProject - log1 coq_makefile -f _CoqProject -o Makefile.coq - log1 make -f Makefile.coq $MAKE_OPT all - logn make-install make -f Makefile.coq install - build_post - fi -} - -# CompCert - -function make_addon_compcert { - installer_addon_dependency_beg compcert - make_menhir - make_addon_menhirlib - 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 - log1 make $MAKE_OPT - log2 make install - logn install-license-1 install -D -T "LICENSE" "$PREFIXCOQ/lib/coq/user-contrib/compcert/LICENSE" - logn install-license-2 install -D -T "LICENSE" "$PREFIXCOQ/lib/compcert/LICENSE" - build_post - fi -} - -# Princeton VST - -function install_addon_vst { - VSTDEST="$PREFIXCOQ/lib/coq/user-contrib/VST" - - # Install VST .v, .vo, .c and .h files - install_rec compcert '*.v' "$VSTDEST/compcert/" - install_rec compcert '*.vo' "$VSTDEST/compcert/" - install_glob "msl" '*.v' "$VSTDEST/msl/" - install_glob "msl" '*.vo' "$VSTDEST/msl/" - install_glob "sepcomp" '*.v' "$VSTDEST/sepcomp/" - install_glob "sepcomp" '*.vo' "$VSTDEST/sepcomp/" - install_glob "floyd" '*.v' "$VSTDEST/floyd/" - install_glob "floyd" '*.vo' "$VSTDEST/floyd/" - install_glob "progs" '*.v' "$VSTDEST/progs/" - install_glob "progs" '*.c' "$VSTDEST/progs/" - install_glob "progs" '*.h' "$VSTDEST/progs/" - install_glob "veric" '*.v' "$VSTDEST/veric/" - install_glob "veric" '*.vo' "$VSTDEST/veric/" - - # Install VST documentation files - install_glob "." 'LICENSE' "$VSTDEST" - install_glob "." '*.md' "$VSTDEST" - install_glob "compcert" '*' "$VSTDEST/compcert" - install_glob "doc" '*.pdf' "$VSTDEST/doc" - - # Install VST _CoqProject files - install_glob "." '_CoqProject*' "$VSTDEST" - install_glob "." '_CoqProject-export' "$VSTDEST/progs" -} - -function vst_patch_compcert_refs { - find . -type f -name '*.v' -print0 | xargs -0 sed -E -i \ - -e 's/(Require\s+(Import\s+|Export\s+)*)compcert\./\1VST.compcert./g' \ - -e 's/From compcert Require/From VST.compcert Require/g' -} - -function make_addon_vst { - installer_addon_dependency vst - if build_prep_overlay vst; then - installer_addon_section vst "VST" "ATTENTION: SOME INCLUDED COMPCERT PARTS ARE NOT OPEN SOURCE! Verified Software Toolchain for verifying C code" "off" - # log1 coq_set_timeouts_1000 - log1 vst_patch_compcert_refs - # The usage of the shell variable ARCH in VST collides with the usage in this shellscript - logn make env -u ARCH make IGNORECOQVERSION=true $MAKE_OPT - log1 install_addon_vst - build_post - fi -} - -# coquelicot Real analysis - -function make_addon_coquelicot { - installer_addon_dependency_beg coquelicot - make_addon_ssreflect - installer_addon_dependency_end - if build_prep_overlay coquelicot; then - installer_addon_section coquelicot "Coquelicot" "Coq library for real analysis" "" - log1 autoreconf -i -s - logn configure ./configure --libdir="$PREFIXCOQ/lib/coq/user-contrib/Coquelicot" - logn remake ./remake - logn remake-install ./remake install - build_post - fi -} - -# AAC associative / commutative rewriting - -function make_addon_aactactics { - installer_addon_dependency aac - if build_prep_overlay aac_tactics; then - installer_addon_section aac "AAC" "Coq plugin for extensible associative and commutative rewriting" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# extlib - -function make_addon_extlib { - installer_addon_dependency extlib - if build_prep_overlay ext_lib; then - installer_addon_section extlib "Ext-Lib" "Coq library with many reusable general purpose components" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# SimpleIO - -function make_addon_simple_io { - installer_addon_dependency simpleIO - if build_prep_overlay simple_io; then - installer_addon_section simpleIO "SimpleIO" "Coq plugin for reading and writing files directly from Coq code" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Quickchick Randomized Property-Based Testing Plugin for Coq - -function make_addon_quickchick { - installer_addon_dependency_beg quickchick - make_addon_ssreflect - make_addon_extlib - make_addon_simple_io - make_ocamlbuild - installer_addon_dependency_end - if build_prep_overlay quickchick; then - installer_addon_section quickchick "QuickChick" "Coq plugin for randomized testing and counter example search" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Flocq: Floating point library - -function make_addon_flocq { - if build_prep_overlay flocq; then - installer_addon_section flocq "Flocq" "Coq library for floating point arithmetic" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Coq-Interval: interval arithmetic and inequality proofs - -function make_addon_interval { - installer_addon_dependency_beg interval - make_addon_mathcomp - make_addon_coquelicot - make_addon_bignums - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay interval; then - installer_addon_section interval "Interval" "Coq library and tactic for proving real inequalities" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Gappa: Automatic generation of arithmetic proofs (mostly on limited precision arithmetic) - -function install_boost { - # The extra tar parameter extracts only the boost headers, not the boost library source code (which is huge and takes a long time) - if build_prep https://dl.bintray.com/boostorg/release/1.69.0/source boost_1_69_0 tar.gz 1 boost_1_69_0 boost boost_1_69_0/boost; then - # Move extracted boost folder where mingw-gcc can find it - mv boost /usr/$TARGET_ARCH/sys-root/mingw/include - build_post - fi -} - -function copy_gappa_dlls { - copy_coq_dll LIBGMP-10.DLL - copy_coq_dll LIBMPFR-6.DLL - copy_coq_dll LIBSTDC++-6.DLL -} - -function make_addon_gappa_tool { - install_boost - if build_prep_overlay gappa_tool; then - installer_addon_section gappa_tool "Gappa tool" "Stand alone tool for automated generation of numerical arithmetic proofs" "" - log1 autoreconf - # Note: configure.in seems to reference this file - touch stamp-config_h.in - logn configure ./configure --build="$HOST" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake -d install - log1 copy_gappa_dlls - build_post - fi -} - -function make_addon_gappa { - make_camlp5 - installer_addon_dependency_beg gappa - make_addon_gappa_tool - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay gappa_plugin ; then - installer_addon_section gappa "Gappa plugin" "Coq plugin for the Gappa tool" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake - logn install ./remake install - build_post - fi -} - -# Elpi: extension language for Coq based. It lets one define commands in tactics -# in a high level programming language with support for binders and unification -# variables. - -function make_addon_elpi { - make_elpi - installer_addon_dependency elpi - if build_prep_overlay elpi ; then - installer_addon_section elpi "Elpi extension language" "Coq plugin for the Elpi extension language" "" - logn build make - logn installe make install - build_post - fi -} - -# Hierarchy Builder: high level language to declare a hierarchy of structures -# compiled down to records and canonical structures. - -function make_addon_HB { - installer_addon_dependency_beg elpi_hb - make_addon_elpi - installer_addon_dependency_end - if build_prep_overlay elpi_hb ; then - installer_addon_section elpi_hb "Hierarchy Builder" "Coq library to declare algebraic hierarchies" "" - logn build make - logn install make install VFILES=structures.v - build_post - fi -} - -# Main function for building addons - -function make_addons { - # Note: ':' is the empty command, which does not produce any output - : > "/build/filelists/addon_dependencies.nsh" - : > "/build/filelists/addon_strings.nsh" - : > "/build/filelists/addon_descriptions.nsh" - : > "/build/filelists/addon_sections.nsh" - - for addon in $COQ_ADDONS; do - "make_addon_$addon" - done - - sort -u -o "/build/filelists/addon_dependencies.nsh" "/build/filelists/addon_dependencies.nsh" -} - -###################### TOP LEVEL BUILD ##################### - -ocamlfind list || true - -make_sed -make_ocaml -make_ocaml_tools -make_ocaml_libs - -list_files ocaml - -make_coq - -if [ "$INSTALLMAKE" == "Y" ] ; then - make_mingw_make -fi - -list_files ocaml_coq - -make_addons - -list_files_always ocaml_coq_addons - -if [ "$MAKEINSTALLER" == "Y" ] ; then - make_coq_installer -fi diff --git a/dev/build/windows/patches_coq/ReplaceInFile.nsh b/dev/build/windows/patches_coq/ReplaceInFile.nsh deleted file mode 100644 index 27c7eb2fd9..0000000000 --- a/dev/build/windows/patches_coq/ReplaceInFile.nsh +++ /dev/null @@ -1,67 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile -; Modifications: -; - Replace only once per line -; - Don't keep original as .old -; - Use StrRep instead of StrReplace (seems to be cleaner) - -Function Func_ReplaceInFile - ClearErrors - - Exch $0 ; REPLACEMENT - Exch - Exch $1 ; SEARCH_TEXT - Exch 2 - Exch $2 ; SOURCE_FILE - - Push $R0 ; SOURCE_FILE file handle - Push $R1 ; temporary file handle - Push $R2 ; unique temporary file name - Push $R3 ; a line to search and replace / save - Push $R4 ; shift puffer - - IfFileExists $2 +1 error ; Check if file exists and open it - FileOpen $R0 $2 "r" - - GetTempFileName $R2 ; Create temporary output file - FileOpen $R1 $R2 "w" - - loop: ; Loop over lines of file - FileRead $R0 $R3 ; Read line - IfErrors finished - Push "$R3" ; Replacine string in line once - Push "$1" - Push "$0" - Call Func_StrRep - Pop $R3 - FileWrite $R1 "$R3" ; Write result - Goto loop - - finished: - FileClose $R1 ; Close files - FileClose $R0 - Delete "$2" ; Delete original file and rename temporary file to target - Rename "$R2" "$2" - ClearErrors - Goto out - - error: - SetErrors - - out: - Pop $R4 - Pop $R3 - Pop $R2 - Pop $R1 - Pop $R0 - Pop $2 - Pop $0 - Pop $1 -FunctionEnd - -!macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT - Push "${SOURCE_FILE}" - Push "${SEARCH_TEXT}" - Push "${REPLACEMENT}" - Call Func_ReplaceInFile -!macroend - diff --git a/dev/build/windows/patches_coq/StrRep.nsh b/dev/build/windows/patches_coq/StrRep.nsh deleted file mode 100644 index d94a9f88b4..0000000000 --- a/dev/build/windows/patches_coq/StrRep.nsh +++ /dev/null @@ -1,60 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/StrRep -; Slightly modified - -Function Func_StrRep - Exch $R2 ;new - Exch 1 - Exch $R1 ;old - Exch 2 - Exch $R0 ;string - Push $R3 - Push $R4 - Push $R5 - Push $R6 - Push $R7 - Push $R8 - Push $R9 - - StrCpy $R3 0 - StrLen $R4 $R1 - StrLen $R6 $R0 - StrLen $R9 $R2 - loop: - StrCpy $R5 $R0 $R4 $R3 - StrCmp $R5 $R1 found - StrCmp $R3 $R6 done - IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character - Goto loop - found: - StrCpy $R5 $R0 $R3 - IntOp $R8 $R3 + $R4 - StrCpy $R7 $R0 "" $R8 - StrCpy $R0 $R5$R2$R7 - StrLen $R6 $R0 - IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string - Goto loop - done: - - Pop $R9 - Pop $R8 - Pop $R7 - Pop $R6 - Pop $R5 - Pop $R4 - Pop $R3 - Push $R0 - Push $R1 - Pop $R0 - Pop $R1 - Pop $R0 - Pop $R2 - Exch $R1 -FunctionEnd - -!macro StrRep output string old new - Push `${string}` - Push `${old}` - Push `${new}` - Call Func_StrRep - Pop ${output} -!macroend diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch deleted file mode 100644 index d047eb107f..0000000000 --- a/dev/build/windows/patches_coq/VST.patch +++ /dev/null @@ -1,14 +0,0 @@ -diff --git a/Makefile b/Makefile ---- a/Makefile -+++ b/Makefile -@@ -82,8 +82,8 @@ endif - - COMPCERTDIRS=lib common $(ARCHDIRS) cfrontend flocq exportclight $(BACKEND) - --COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) compcert.$(d)) --EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) compcert.$(d)) -+COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) VST.compcert.$(d)) -+EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) VST.compcert.$(d)) - # for ITrees - ifeq ($(wildcard InteractionTrees/the?ries),"InteractionTrees/theories") - EXTFLAGS:=$(EXTFLAGS) -Q InteractionTrees/theories ITree diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi deleted file mode 100644 index 9947965c28..0000000000 --- a/dev/build/windows/patches_coq/coq_new.nsi +++ /dev/null @@ -1,330 +0,0 @@ -; This script is used to build the Windows install program for Coq. - -; NSIS Modern User Interface -; Written by Joost Verburg -; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop - -; The following command line defines are expected: -; VERSION Coq version, e.g. 8.5-pl2 -; ARCH The target architecture, either x86_64 or i686 -; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter) -; COQ_ICON path of Coq icon file in Windows or MinGW format -; COQ_ADDONS list of addons that are shipped - -; Enable compression after debugging. -; SetCompress off -SetCompressor lzma - -!define MY_PRODUCT "Coq" ;Define your own software name here -!define OUTFILE "coq-${VERSION}-installer-windows-${ARCH}.exe" - -!include "MUI2.nsh" -!include "FileAssociation.nsh" -!include "StrRep.nsh" -!include "ReplaceInFile.nsh" -!include "winmessages.nsh" - -Var COQ_SRC_PATH_BS ; COQ_SRC_PATH with \ instead of / -Var COQ_SRC_PATH_DBS ; COQ_SRC_PATH with \\ instead of / -Var INSTDIR_DBS ; INSTDIR with \\ instead of \ - -;-------------------------------- -;Configuration - - Name "Coq" - - ;General - OutFile "${OUTFILE}" - - ;Folder selection page - InstallDir "C:\${MY_PRODUCT}" - - ;Remember install folder - InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" - -;-------------------------------- -;Extra license pages - -!macro MUI_PAGE_LICENSE_EXTRA Licensefile Header Subheader Bottom SelFunc - !define MUI_PAGE_HEADER_TEXT "${Header}" - !define MUI_PAGE_HEADER_SUBTEXT "${Subheader}" - !define MUI_LICENSEPAGE_TEXT_BOTTOM "${Bottom}" - !define MUI_PAGE_CUSTOMFUNCTION_PRE ${SelFunc} - !insertmacro MUI_PAGE_LICENSE "${Licensefile}" -!macroend - -;-------------------------------- -; Check for white spaces -Function .onVerifyInstDir - StrLen $0 "$INSTDIR" - StrCpy $1 0 - ${While} $1 < $0 - StrCpy $3 $INSTDIR 1 $1 - StrCmp $3 " " SpacesInPath - IntOp $1 $1 + 1 - ${EndWhile} - Goto done - SpacesInPath: - Abort - done: -FunctionEnd - -;-------------------------------- -;Installer Sections - -Section "Coq" Sec1 - - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_base.nsh" - - ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" - - ;Store install folder - WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR - - ;Create uninstaller - WriteUninstaller "$INSTDIR\Uninstall.exe" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayName" "Coq Version ${VERSION}" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "UninstallString" '"$INSTDIR\Uninstall.exe"' - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayVersion" "${VERSION}" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoModify" "1" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoRepair" "1" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "URLInfoAbout" "http://coq.inria.fr" - - ; Create start menu entries - ; SetOutPath is required for the path in the .lnk files - SetOutPath "$INSTDIR" - CreateDirectory "$SMPROGRAMS\Coq" - ; The first shortcut set here is treated as main application by Windows 7/8. - ; Use CoqIDE as main application - CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" - CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" - WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" - WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" - CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 - -SectionEnd - -;OCAML Section "Ocaml for native compute and plugin development" Sec2 -;OCAML SetOutPath "$INSTDIR\" -;OCAML !include "..\..\..\filelists\ocaml.nsh" -;OCAML -;OCAML ; Create a few slash / backslash variants of the source and install path -;OCAML ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR} -;OCAML !insertmacro StrRep $COQ_SRC_PATH_BS ${COQ_SRC_PATH} "/" "\" -;OCAML !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\" -;OCAML !insertmacro StrRep $INSTDIR_DBS $INSTDIR "\" "\\" -;OCAML -;OCAML ; Replace absolute paths in some OCaml config files -;OCAML ; These are not all, see ReadMe.txt -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/" "\" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS" "$INSTDIR" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS" -;OCAML SectionEnd - -SectionGroup "Coq addons" Sec2 - !include "..\..\..\filelists\addon_sections.nsh" -SectionGroupEnd - -Section "Coq files for plugin developers" Sec3 - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_plugindev.nsh" -SectionEnd - -;OCAML Section "OCAMLLIB current user" Sec4 -;OCAML WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;OCAML Section "OCAMLLIB all users" Sec5 -;OCAML WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;-------------------------------- -;Section dependencies - -; Parameters on the stack: -; top-0 : section B on which section A dependencies -; top-1 : section A, which depends on section B -; top-2 : name of section B -; top-3 : name of section A - -Function CheckSectionDependency - ; stack=nameB nameA secB secA rest - Exch $R3 ; stack=$R3 nameA secB secA rest; $R3=nameB - Exch ; stack=nameA $R3 secB secA rest - Exch $R2 ; stack=$R2 $R3 secB secA rest; $R2=nameA - Exch 2 ; stack=secB $R3 $R2 secA rest - Exch $R1 ; stack=$R1 $R3 $R2 secA rest; $R1=secB - Exch 3 ; stack=secA $R3 $R2 $R1 rest; - Exch $R0 ; stack=$R0 $R3 $R2 $R1 rest; $R0=secA - ; Take care of save order when popping the stack! - Push $R4 - Push $R5 - - SectionGetFlags $R0 $R0 - IntOp $R0 $R0 & ${SF_SELECTED} - - SectionGetFlags $R1 $R4 - IntOp $R5 $R4 & ${SF_SELECTED} - - ${If} $R0 == ${SF_SELECTED} - ${AndIf} $R5 != ${SF_SELECTED} - - IntOp $R5 $R4 | ${SF_SELECTED} - SectionSetFlags $R1 $R5 - MessageBox MB_OK '"$R3" has been selected, because "$R2" depends on it' - - ${EndIf} - - Pop $R5 - Pop $R4 - Pop $R0 - Pop $R3 - Pop $R2 - Pop $R1 -FunctionEnd - -!macro CheckSectionDependency secA secB nameA nameB - Push "${secA}" - Push "${secB}" - Push "${nameA}" - Push "${nameB}" - Call CheckSectionDependency -!macroend - -!define CheckSectionDependency "!insertmacro CheckSectionDependency" - -Function .onSelChange - !include "..\..\..\filelists\addon_dependencies.nsh" -FunctionEnd - -;-------------------------------- -;Modern UI Configuration - -; Note: this must be placed after the sections, because below we need to check at compile time -; if sections exist (by !ifdef <section_index_var>) to decide if the license page must be included. -; The section index variables are only defined after the section definitions. - - !define MUI_ICON "${COQ_ICON}" - - !insertmacro MUI_PAGE_WELCOME - !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt" - !insertmacro MUI_PAGE_COMPONENTS - - !ifdef Sec_compcert - !define LicCompCert_Title "CompCert License Agreement" - !define LicCompCert_SubTitle "You selected the CompCert addon. CompCert is not open source. Please review the license terms before installing CompCert!" - !define LicCompCert_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the CompCert addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/compcert/LICENSE" "${LicCompCert_Title}" "${LicCompCert_SubTitle}" "${LicCompCert_Bottom}" SelFuncCompCert - - Function SelFuncCompCert - ${Unless} ${SectionIsSelected} ${Sec_compcert} - Abort - ${EndUnless} - FunctionEnd - !endif - - !ifdef Sec_vst - !define LicVST_Title "Princeton VST License Agreement" - !define LicVST_SubTitle "You selected the VST addon. VST contains parts of CompCert which are not open source. Please review the license terms before installing VST!" - !define LicVST_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the VST addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/VST/LICENSE" "${LicVST_Title}" "${LicVST_SubTitle}" "${LicVST_Bottom}" SelFuncVST - - Function SelFuncVST - ${Unless} ${SectionIsSelected} ${Sec_vst} - Abort - ${EndUnless} - FunctionEnd - !endif - - !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." - !insertmacro MUI_PAGE_DIRECTORY - !insertmacro MUI_PAGE_INSTFILES - !insertmacro MUI_PAGE_FINISH - - !insertmacro MUI_UNPAGE_WELCOME - !insertmacro MUI_UNPAGE_CONFIRM - !insertmacro MUI_UNPAGE_INSTFILES - !insertmacro MUI_UNPAGE_FINISH - -;-------------------------------- -;Languages - - !insertmacro MUI_LANGUAGE "English" - -;-------------------------------- -;Language Strings - - ;Description - LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." - LangString DESC_2 ${LANG_ENGLISH} "This package contains the following extra Coq packages: ${COQ_ADDONS}" - LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." - ; LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user." - ; LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users." - !include "..\..\..\filelists\addon_strings.nsh" - -;-------------------------------- -;Descriptions - -!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN - !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5) - !include "..\..\..\filelists\addon_descriptions.nsh" -!insertmacro MUI_FUNCTION_DESCRIPTION_END - -;-------------------------------- -;Uninstaller Section - -Section "Uninstall" - ; Files and folders - RMDir /r "$INSTDIR\bin" - RMDir /r "$INSTDIR\doc" - RMDir /r "$INSTDIR\etc" - RMDir /r "$INSTDIR\lib" - RMDir /r "$INSTDIR\libocaml" - RMDir /r "$INSTDIR\share" - RMDir /r "$INSTDIR\ide" - RMDir /r "$INSTDIR\gtk-2.0" - RMDir /r "$INSTDIR\latex" - RMDir /r "$INSTDIR\license_readme" - RMDir /r "$INSTDIR\man" - RMDir /r "$INSTDIR\emacs" - - ; Start Menu - Delete "$SMPROGRAMS\Coq\Coq.lnk" - Delete "$SMPROGRAMS\Coq\CoqIde.lnk" - Delete "$SMPROGRAMS\Coq\Uninstall.lnk" - Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" - Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" - Delete "$INSTDIR\Uninstall.exe" - - ; Registry keys - DeleteRegKey HKCU "Software\${MY_PRODUCT}" - DeleteRegKey HKLM "SOFTWARE\Coq" - DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" - DeleteRegKey HKCU "Environment\OCAMLLIB" - DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB" - ${unregisterExtension} ".v" "Coq Script File" - - ; Root folders - RMDir "$INSTDIR" - RMDir "$SMPROGRAMS\Coq" - -SectionEnd diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch deleted file mode 100644 index 82806f9ea4..0000000000 --- a/dev/build/windows/patches_coq/flexdll-0.37.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: -difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 -TARFILE= tarballs/flexdll-0.37.tar.gz -FOLDER= flexdll-0.37 -TARSTRIP= 1 -TARPREFIX= flexdll-0.37/ -ORIGFOLDER= flexdll-0.37.orig ---- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 -+++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 -@@ -248,6 +248,9 @@ - String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest - | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> - "-link" :: String.sub s 5 (String.length s - 5) :: tr rest -+ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) -+ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> -+ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest - | "-arg" :: x :: rest -> - tr (Array.to_list (Arg.read_arg x)) @ rest - | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/isl-0.14.patch b/dev/build/windows/patches_coq/isl-0.14.patch deleted file mode 100644 index f3b8ead1ab..0000000000 --- a/dev/build/windows/patches_coq/isl-0.14.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- orig.isl-0.14/configure 2014-10-26 08:36:32.000000000 +0100 -+++ isl-0.14/configure 2016-10-10 18:16:01.430224500 +0200 -@@ -8134,7 +8134,7 @@ - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( -- /*) -+ /*|[A-Z]:\\*|[A-Z]:/*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') diff --git a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch deleted file mode 100644 index 1c6a038da9..0000000000 --- a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch +++ /dev/null @@ -1,76 +0,0 @@ -diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: -difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 -TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz -FOLDER= lablgtk-3.0.beta4 -TARSTRIP= 1 -TARPREFIX= lablgtk-3.0.beta4/ -ORIGFOLDER= lablgtk-3.0.beta4.orig ---- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 -@@ -72,6 +72,8 @@ - type id - external channel_of_descr : Unix.file_descr -> channel - = "ml_g_io_channel_unix_new" -+ external channel_of_descr_socket : Unix.file_descr -> channel -+ = "ml_g_io_channel_unix_new_socket" - external remove : id -> unit = "ml_g_source_remove" - external add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 -@@ -25,6 +25,8 @@ - #include <string.h> - #include <locale.h> - #ifdef _WIN32 -+/* to kill a #warning: include winsock2.h before windows.h */ -+#include <winsock2.h> - #include "win32.h" - #include <wtypes.h> - #include <io.h> -@@ -38,6 +40,11 @@ - #include <caml/callback.h> - #include <caml/threads.h> - -+#ifdef _WIN32 -+/* for Socket_val */ -+#include <caml/unixsupport.h> -+#endif -+ - #include "wrappers.h" - #include "ml_glib.h" - #include "glib_tags.h" -@@ -326,14 +333,23 @@ - - #ifndef _WIN32 - ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) -+CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { -+ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); -+} - - #else - CAMLprim value ml_g_io_channel_unix_new(value wh) - { - return Val_GIOChannel_noref -- (g_io_channel_unix_new -+ (g_io_channel_win32_new_fd - (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); - } -+ -+CAMLprim value ml_g_io_channel_unix_new_socket(value wh) -+{ -+ return Val_GIOChannel_noref -+ (g_io_channel_win32_new_socket(Socket_val(wh))); -+} - #endif - - static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c deleted file mode 100644 index 41f64f98b2..0000000000 --- a/dev/build/windows/patches_coq/ln.c +++ /dev/null @@ -1,137 +0,0 @@ -// (C) 2016 Intel Deutschland GmbH -// Author: Michael Soegtrop -// Released to the public under CC0 -// See https://creativecommons.org/publicdomain/zero/1.0/ - -// Windows drop in repacement for Linux ln -// Supports command form "ln TARGET LINK_NAME" -// Supports -s and -f options -// Does not support hard links to folders (but symlinks are ok) - -#include <windows.h> -#include <stdio.h> -#include <tchar.h> - -// Cygwin MinGW doesn't have this Vista++ function in windows.h -#ifdef UNICODE - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkW - #define CommandLineToArgv CommandLineToArgvW -#else - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkA - #define CommandLineToArgv CommandLineToArgvA -#endif -#define SYMBOLIC_LINK_FLAG_DIRECTORY 1 - -int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd ) -{ - int iarg; - BOOL symbolic = FALSE; - BOOL force = FALSE; - BOOL folder; - const _TCHAR *target; - const _TCHAR *link; - LPTSTR lpCmdLine; - int argc; - LPTSTR *argv; - - // Parse command line - // This is done explicitly here for two reasons - // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like - // 2.) We want to make sure that CommandLineToArgv is used - lpCmdLine = GetCommandLine(); - argv = CommandLineToArgv( lpCmdLine, &argc ); - - // Get target and link name - if( argc<3 ) - { - _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 ); - return 1; - } - target = argv[argc-2]; - link = argv[argc-1]; - - // Parse options - // The last two arguments are interpreted as file names - // All other arguments must be -s or -f os multi letter options like -sf - for(iarg=1; iarg<argc-2; iarg++ ) - { - const _TCHAR *pos = argv[iarg]; - if( *pos != _T('-') ) - { - _ftprintf( stderr, _T("Command line option expected in argument %d\n"), iarg ); - return 1; - } - pos ++; - - while( *pos ) - { - switch( *pos ) - { - case _T('s') : symbolic = TRUE; break; - case _T('f') : force = TRUE; break; - default : - _ftprintf( stderr, _T("Unknown option '%c'\n"), *pos ); - return 1; - } - pos ++; - } - } - - #ifdef IGNORE_SYMBOLIC - symbolic = FALSE; - #endif - - // Check if link already exists - delete it if force is given or abort - { - if( GetFileAttributes(link) != INVALID_FILE_ATTRIBUTES ) - { - if( force ) - { - if( !DeleteFile( link ) ) - { - _ftprintf( stderr, _T("Error deleting file '%s'\n"), link ); - return 1; - } - } - else - { - _ftprintf( stderr, _T("File '%s' exists!\n"), link ); - return 1; - } - } - } - - // Check if target is a folder - folder = ( (GetFileAttributes(target) & FILE_ATTRIBUTE_DIRECTORY) ) != 0; - - // Create link - if(symbolic) - { - if( !CreateSymbolicLink( link, target, folder ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0 ) ) - { - _ftprintf( stderr, _T("Error creating symbolic link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - else - { - if( folder ) - { - _ftprintf( stderr, _T("Cannot create hard link to folder") ); - return 1; - } - else - { - if( !CreateHardLink( link, target, NULL ) ) - { - _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - } - - // Everything is fine - return 0; -} diff --git a/dev/build/windows/patches_coq/ocaml-4.07.1.patch b/dev/build/windows/patches_coq/ocaml-4.07.1.patch deleted file mode 100644 index 2d61b5b838..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.07.1.patch +++ /dev/null @@ -1,97 +0,0 @@ -diff/patch file created on Tue, Jun 11, 2019 10:15:38 AM with: -difftar-folder.sh tarballs/ocaml-4.07.1.tar.gz ocaml-4.07.1 1 -TARFILE= tarballs/ocaml-4.07.1.tar.gz -FOLDER= ocaml-4.07.1/ -TARSTRIP= 1 -TARPREFIX= ocaml-4.07.1/ -ORIGFOLDER= ocaml-4.07.1.orig ---- ocaml-4.07.1.orig/byterun/caml/osdeps.h 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/caml/osdeps.h 2019-06-11 10:13:50.766997600 +0200 -@@ -98,6 +98,11 @@ - */ - extern char_os *caml_secure_getenv(char_os const *var); - -+/* Modify or delete environment variable. -+ Returns 0 on success or an error code. -+*/ -+extern int caml_putenv(char_os const *var, char_os const *value); -+ - /* If [fd] refers to a terminal or console, return the number of rows - (lines) that it displays. Otherwise, or if the number of rows - cannot be determined, return -1. */ ---- ocaml-4.07.1.orig/byterun/debugger.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/debugger.c 2019-06-11 10:14:02.706013700 +0200 -@@ -180,6 +180,7 @@ - if (address == NULL) return; - if (dbg_addr != NULL) caml_stat_free(dbg_addr); - dbg_addr = address; -+ caml_putenv(_T("CAML_DEBUG_SOCKET"),_T("")); - - #ifdef _WIN32 - winsock_startup(); ---- ocaml-4.07.1.orig/byterun/unix.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/unix.c 2019-06-11 10:14:11.252438800 +0200 -@@ -430,6 +430,19 @@ - #endif - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - int caml_num_rows_fd(int fd) - { - #ifdef TIOCGWINSZ ---- ocaml-4.07.1.orig/byterun/win32.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/win32.c 2019-06-11 10:14:19.485640700 +0200 -@@ -727,6 +727,19 @@ - return _wgetenv(var); - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - /* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a - way that they get direct access to the Win32 environment rather than to the - copy that is cached by the C runtime system. The result of caml_win32_getenv ---- ocaml-4.07.1.orig/config/Makefile.mingw 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw 2019-06-11 10:14:44.492969800 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 ---- ocaml-4.07.1.orig/config/Makefile.mingw64 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw64 2019-06-11 10:14:53.664784900 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 diff --git a/dev/build/windows/patches_coq/ocaml-4.08.1.patch b/dev/build/windows/patches_coq/ocaml-4.08.1.patch deleted file mode 100644 index a79033a061..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.08.1.patch +++ /dev/null @@ -1,25 +0,0 @@ -diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h -index 6aa98516b..8184c2797 100644 ---- a/runtime/caml/misc.h -+++ b/runtime/caml/misc.h -@@ -327,7 +327,6 @@ extern void caml_set_fields (intnat v, uintnat, uintnat); - - #if defined(_WIN32) && !defined(_UCRT) - extern int caml_snprintf(char * buf, size_t size, const char * format, ...); --#define snprintf caml_snprintf - #endif - - #ifdef CAML_INSTR -@@ -336,6 +335,12 @@ extern int caml_snprintf(char * buf, size_t size, const char * format, ...); - #include <time.h> - #include <stdio.h> - -+/* snprintf emulation for Win32 - do define after stdio.h, in case snprintf is defined */ -+ -+#if defined(_WIN32) && !defined(_UCRT) -+#define snprintf caml_snprintf -+#endif -+ - extern intnat caml_stat_minor_collections; - extern intnat caml_instr_starttime, caml_instr_stoptime; - diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c deleted file mode 100644 index c4c7ec2bff..0000000000 --- a/dev/build/windows/patches_coq/pkg-config.c +++ /dev/null @@ -1,29 +0,0 @@ -// MinGW personality wrapper for pkgconf -// This is an executable replacement for the shell scripts /bin/ARCH-pkg-config -// Compile with e.g. -// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe -// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe -// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! -// -// To test it execute e.g. -// $ ./pkg-config --path zlib -// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc - -#include <unistd.h> - -#define STRINGIFY1(arg) #arg -#define STRINGIFY(arg) STRINGIFY1(arg) - -int main(int argc, char *argv[]) -{ - // +1 for extra argument, +1 for trailing NULL - char * argvnew[argc+2]; - int id=0, is=0; - - argvnew[id++] = argv[is++]; - argvnew[id++] = "--personality="STRINGIFY(ARCH); - while( is<argc ) argvnew[id++] = argv[is++]; - argvnew[id++] = 0; - - return execv("/usr/bin/pkgconf", argvnew); -} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch deleted file mode 100644 index 4b7b86ff05..0000000000 --- a/dev/build/windows/patches_coq/quickchick.patch +++ /dev/null @@ -1,47 +0,0 @@ -diff/patch file created on Wed, Jul 17, 2019 8:06:45 PM with: -difftar-folder.sh tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 1 -TARFILE= tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz -FOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 -TARSTRIP= 1 -TARPREFIX= QuickChick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/ -ORIGFOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig ---- quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig/Makefile 2019-06-26 12:09:01.000000000 +0200 -+++ quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/Makefile 2019-07-17 20:05:44.322251200 +0200 -@@ -2,7 +2,7 @@ - .PHONY: plugin install install-plugin clean quickChickTool - - QCTOOL_DIR=quickChickTool --QCTOOL_EXE=quickChickTool.byte -+QCTOOL_EXE=quickChickTool.native - QCTOOL_SRC=$(QCTOOL_DIR)/quickChickTool.ml \ - $(QCTOOL_DIR)/quickChickToolTypes.ml \ - $(QCTOOL_DIR)/quickChickToolLexer.mll \ -@@ -20,8 +20,8 @@ - - all: quickChickTool plugin documentation-check - --plugin: Makefile.coq -- $(MAKE) -f Makefile.coq -+plugin: Makefile.coq -+ $(MAKE) -f Makefile.coq - - documentation-check: plugin - coqc -R src QuickChick -I src QuickChickInterface.v -@@ -32,7 +32,7 @@ - install: all - $(V)$(MAKE) -f Makefile.coq install > $(TEMPFILE) - # Manually copying the remaining files -- $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) $(shell opam config var bin)/quickChick -+ $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) "$(COQBIN)/quickChick" - # $(V)cp src/quickChickLib.cmx $(COQLIB)/user-contrib/QuickChick - # $(V)cp src/quickChickLib.o $(COQLIB)/user-contrib/QuickChick - -@@ -56,7 +56,7 @@ - $(MAKE) -C examples/RedBlack test - # cd examples/stlc; make clean && make - $(MAKE) -C examples/multifile-mutation test --# This takes too long. -+# This takes too long. - # $(MAKE) -C examples/c-mutation test - # coqc examples/BSTTest.v - coqc examples/DependentTest.v diff --git a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch b/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch deleted file mode 100644 index d210a04153..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/sed-4.2.2/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/sed-4.2.2/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/sed-4.2.2/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/sed-4.2.2/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/sed-4.2.2/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/sed-4.2.2/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/sed-4.2.2/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/sed-4.2.2/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/sed-4.2.2/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/sed-4.2.2/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed-4.2.2/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed-4.2.2/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ diff --git a/dev/build/windows/patches_coq/sed-4.2.2.patch b/dev/build/windows/patches_coq/sed-4.2.2.patch deleted file mode 100644 index c7ccd53c7f..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ 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..8bcbd90f0b 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" "flocq-3" ######################################################################## # 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-coq_performance_tests.sh b/dev/ci/ci-coq_performance_tests.sh index fde8df8e3d..2fa4d5c776 100755 --- a/dev/ci/ci-coq_performance_tests.sh +++ b/dev/ci/ci-coq_performance_tests.sh @@ -5,4 +5,9 @@ ci_dir="$(dirname "$0")" git_download coq_performance_tests -( cd "${CI_BUILD_DIR}/coq_performance_tests" && make coq perf-Sanity && make validate && make install ) +# run make -k; make again if make fails so that the failing file comes last, so that it's easier to find the error messages in the CI log +function make_full() { + if ! make -k "$@"; then make -k "$@"; exit 1; fi +} + +( cd "${CI_BUILD_DIR}/coq_performance_tests" && make_full coq perf-Sanity && make validate && make install ) 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/README.md b/dev/ci/docker/README.md index 16c4ac37d9..ed51c8afd3 100644 --- a/dev/ci/docker/README.md +++ b/dev/ci/docker/README.md @@ -4,31 +4,29 @@ This directory provides Docker images to be used by Coq's CI. The images do support Docker autobuild on `hub.docker.com` and Gitlab's private registry. -The Gitlab CI will build a docker image unless the CI environment variable +The Gitlab CI will build a Docker image unless the CI environment variable `SKIP_DOCKER` is set to `true`. This image will be stored in the [Gitlab container registry](https://gitlab.com/coq/coq/container_registry) under the name given by the `CACHEKEY` variable from the [Gitlab CI configuration file](../../../.gitlab-ci.yml). -In Coq's default CI, `SKIP_DOCKER` is set so as to avoid running a lengthy redundant job. +`SKIP_DOCKER` is set to "true" in `https://gitlab.com/coq/coq` to avoid running +a lengthy redundant job. For efficiency, users should enable that setting +in forked repositories after the initial Docker build in the fork succeeds. -It can be used to regenerate a fresh Docker image on Gitlab through the following steps. -- Change the `CACHEKEY` variable to a fresh name in the CI configuration in a new commit. -- Push this commit to a Github PR. This will trigger a Gitlab CI run that will - immediately fail, as the Docker image is missing and the `SKIP_DOCKER` +The steps to generate a new Docker image are: +- Update the `CACHEKEY` variable in .gitlab-ci.yml with the date and md5. +- Submit the change in a PR. This triggers a Gitlab CI run that + immediately fails, as the Docker image is missing and the `SKIP_DOCKER` default value prevents rebuilding the image. -- Run a new pipeline on Gitlab with that PR branch, using the green "Run pipeline" - button on the [web interface](https://gitlab.com/coq/coq/pipelines), - with the `SKIP_DOCKER` environment variable set to `false`. This will run a `docker-boot` process, and - once completed, a new Docker image will be available in the container registry, - with the name set in `CACHEKEY`. +- Run a new pipeline on Gitlab with that PR branch (e.g. "pr-99999"), using the green + "Run pipeline" button on the [web interface](https://gitlab.com/coq/coq/pipelines), + with the `SKIP_DOCKER` environment variable set to `false`. This will run a + `docker-boot` process, and once completed, a new Docker image will be available in + the container registry, with the name set in `CACHEKEY`. - Any pipeline with the same `CACHEKEY` will now automatically reuse that image without rebuilding it from scratch. -For documentation purposes, we also require keeping in sync the `CACHEKEY` comment -from the first line of the [Dockerfile](bionic_coq/Dockerfile) in the same -commit. - In case you do not have the rights to run Gitlab CI pipelines, you should ask the ci-maintainers Github team to do it for you. diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index c17ec502e7..b4b6411d28 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. @@ -70,3 +71,6 @@ RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM $CI_OPAM RUN opam clean -a -c + +# set the locale for the benefit of Python +ENV LANG C.UTF-8 diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat deleted file mode 100755 index dc6423332f..0000000000 --- a/dev/ci/gitlab.bat +++ /dev/null @@ -1,141 +0,0 @@ -@ECHO OFF
-
-REM This script builds and signs the Windows packages on Gitlab
-
-ECHO "Start Time"
-TIME /T
-
-REM List currently used cygwin and target folders for debugging / maintenance purposes
-
-ECHO "Currently used cygwin folders"
-DIR C:\ci\cygwin*
-ECHO "Currently used target folders"
-DIR C:\ci\coq*
-ECHO "Root folders"
-DIR C:\
-
-if %ARCH% == 32 (
- SET ARCHLONG=i686
- SET SETUP=setup-x86.exe
-)
-
-if %ARCH% == 64 (
- SET ARCHLONG=x86_64
- SET SETUP=setup-x86_64.exe
-)
-
-SET CYGROOT=C:\ci\cygwin%ARCH%
-SET DESTCOQ=C:\ci\coq%ARCH%
-SET CYGCACHE=C:\ci\cache\cgwin
-
-CALL :MakeUniqueFolder %CYGROOT% CYGROOT
-CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ
-
-powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')"
-SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
-SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
-SET COQREGTESTING=Y
-SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin
-
-IF "%WINDOWS%" == "enabled_all_addons" (
- SET EXTRA_ADDONS=^
- -addon=bignums ^
- -addon=equations ^
- -addon=mtac2 ^
- -addon=mathcomp ^
- -addon=menhir ^
- -addon=menhirlib ^
- -addon=compcert ^
- -addon=extlib ^
- -addon=quickchick ^
- -addon=coquelicot ^
- -addon=vst ^
- -addon=aactactics ^
- -addon=flocq ^
- -addon=interval ^
- -addon=gappa_tool ^
- -addon=gappa ^
- -addon=elpi ^
- -addon=HB
-) ELSE (
- SET "EXTRA_ADDONS= "
-)
-
-call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
- -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^
- -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
- %EXTRA_ADDONS% ^
- -make=N ^
- -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit
-
-ECHO "Start Artifact Creation"
-TIME /T
-
-mkdir artifacts
-
-CALL :CopyLogFiles
-
-copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" artifacts || GOTO ErrorExit
-REM The open source archive is only required for release builds
-IF DEFINED WIN_CERTIFICATE_PATH (
- 7z a artifacts\coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
-) ELSE (
- REM In non release builds, create a dummy file
- ECHO "This is not a release build - open source archive not created / uploaded" > artifacts\coq-opensource-info.txt
-)
-
-REM DO NOT echo the signing command below, as this would leak secrets in the logs
-IF DEFINED WIN_CERTIFICATE_PATH (
- IF DEFINED WIN_CERTIFICATE_PASSWORD (
- ECHO Signing package
- @signtool sign /f %WIN_CERTIFICATE_PATH% /p %WIN_CERTIFICATE_PASSWORD% dev\nsis\*.exe
- signtool verify /pa dev\nsis\*.exe
- )
-)
-
-ECHO "Finished Artifact Creation"
-TIME /T
-
-CALL :CleanupFolders
-
-ECHO "Finished Cleanup"
-TIME /T
-
-GOTO :EOF
-
-:CopyLogFiles
- ECHO Copy log files for artifact upload
- MKDIR artifacts\buildlogs
- COPY %CYGROOT%\build\buildlogs\* artifacts\buildlogs
- MKDIR artifacts\filelists
- COPY %CYGROOT%\build\filelists\* artifacts\filelists
- MKDIR artifacts\flagfiles
- COPY %CYGROOT%\build\flagfiles\* artifacts\flagfiles
- GOTO :EOF
-
-:CleanupFolders
- ECHO "Cleaning %CYGROOT%"
- RMDIR /S /Q "%CYGROOT%"
- ECHO "Cleaning %DESTCOQ%"
- RMDIR /S /Q "%DESTCOQ%"
- GOTO :EOF
-
-:MakeUniqueFolder
- REM Create a uniquely named folder
- REM This script is safe because folder creation is atomic - either we create it or fail
- REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this)
- REM %2 = name of the variable which receives the unique folder name
- SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%"
- MKDIR "%UNIQUENAME%"
- IF ERRORLEVEL 1 GOTO :MakeUniqueFolder
- SET "%2=%UNIQUENAME%"
- GOTO :EOF
-
-:ErrorCopyLogFilesAndExit
- CALL :CopyLogFiles
- REM fall through
-
-:ErrorExit
- CALL :CleanupFolders
- ECHO ERROR %0 failed
- EXIT /b 1
diff --git a/dev/ci/platform-windows.bat b/dev/ci/platform-windows.bat new file mode 100755 index 0000000000..513aec5f94 --- /dev/null +++ b/dev/ci/platform-windows.bat @@ -0,0 +1,105 @@ +REM @ECHO OFF
+
+REM SET ARCH=64
+REM SET PLATFORM=https://github.com/coq/platform/archive/v8.13.zip
+REM SET CI_PROJECT_DIR=C:\root
+
+REM This script builds a minimal Windows platform on Gitlab
+
+ECHO "Start Time"
+TIME /T
+
+REM List currently used cygwin and target folders for debugging / maintenance purposes
+
+ECHO "Currently used cygwin folders"
+DIR C:\ci\cygwin*
+ECHO "Currently used target folders"
+DIR C:\ci\coq*
+ECHO "Root folders"
+DIR C:\
+ECHO "Powershell version"
+powershell -Command "Get-Host"
+ECHO "Git installation of Mingw"
+DIR "C:\Program Files\Git\mingw64\bin\*.exe"
+
+ECHO "--------- START -------"
+
+SET CYGROOT=C:\ci\cygwin%ARCH%
+SET CYGCACHE=C:\ci\cache\cgwin
+
+CALL :MakeUniqueFolder %CYGROOT% CYGROOT
+
+SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
+SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
+SET COQREGTESTING=y
+SET PATH=%PATH%;C:\Program Files\7-Zip;C:\Program Files\Git\mingw64\bin
+
+
+ECHO "Downloading %PLATFORM%"
+curl -L -o platform.zip "%PLATFORM%"
+7z x platform.zip
+
+cd platform-*
+
+call coq_platform_make_windows.bat ^
+ -arch=%ARCH% ^
+ -destcyg=%CYGROOT% ^
+ -cygcache=%CYGCACHE% ^
+ -extent=i ^
+ -parallel=p ^
+ -jobs=2 ^
+ -switch=d || GOTO ErrorCopyLogFilesAndExit
+
+cd ..
+
+SET BASH=%CYGROOT%\bin\bash
+
+ECHO "Start Artifact Creation"
+TIME /T
+
+MKDIR %CI_PROJECT_DIR%\artifacts
+%BASH% --login -c "cd coq-platform && windows/create_installer_windows.sh && cp windows_installer/*.exe %CI_PROJECT_DIR_CFMT%/artifacts" || GOTO ErrorCopyLogFilesAndExit
+TIME /T
+
+CALL :CopyLogFiles
+
+ECHO "Finished Artifact Creation"
+TIME /T
+
+CALL :CleanupFolders
+
+ECHO "Finished Cleanup"
+TIME /T
+
+GOTO :EOF
+
+:CopyLogFiles
+ ECHO Copy log files for artifact upload
+ REM This is currently not supported by the opam based build scripts
+ GOTO :EOF
+
+:CleanupFolders
+ ECHO "Cleaning %CYGROOT%"
+ RMDIR /S /Q "%CYGROOT%"
+ GOTO :EOF
+
+:MakeUniqueFolder
+ REM Create a uniquely named folder
+ REM This script is safe because folder creation is atomic - either we create it or fail
+ REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this)
+ REM %2 = name of the variable which receives the unique folder name
+ SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%"
+ MKDIR "%UNIQUENAME%"
+ IF ERRORLEVEL 1 GOTO :MakeUniqueFolder
+ RMDIR "%UNIQUENAME%"
+ SET "%2=%UNIQUENAME%"
+ GOTO :EOF
+
+:ErrorCopyLogFilesAndExit
+ CALL :CopyLogFiles
+ REM fall through
+
+:ErrorExit
+ CALL :CleanupFolders
+ ECHO ERROR %0 failed
+ EXIT /b 1
diff --git a/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh new file mode 100644 index 0000000000..dc57e6efb9 --- /dev/null +++ b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh @@ -0,0 +1,9 @@ +overlay coq_dpdgraph https://github.com/ppedrot/coq-dpdgraph compact-case-repr 13563 +overlay coqhammer https://github.com/ppedrot/coqhammer compact-case-repr 13563 +overlay elpi https://github.com/ppedrot/coq-elpi compact-case-repr 13563 +overlay equations https://github.com/ppedrot/Coq-Equations compact-case-repr 13563 +overlay metacoq https://github.com/ppedrot/metacoq compact-case-repr 13563 +overlay mtac2 https://github.com/ppedrot/Mtac2 compact-case-repr 13563 +overlay paramcoq https://github.com/ppedrot/paramcoq compact-case-repr 13563 +overlay relation_algebra https://github.com/ppedrot/relation-algebra compact-case-repr 13563 +overlay unicoq https://github.com/ppedrot/unicoq compact-case-repr 13563 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/13299-jashug-preserve-universes-notation.sh b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh new file mode 100644 index 0000000000..27e7cee42e --- /dev/null +++ b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13299" ] || [ "$CI_BRANCH" = "preserve-universes-notation" ]; then + + elpi_CI_REF=overlay-universes-in-notations + elpi_CI_GITURL=https://github.com/jashug/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/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh b/dev/ci/user-overlays/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh new file mode 100644 index 0000000000..0f62d0ee9f --- /dev/null +++ b/dev/ci/user-overlays/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh @@ -0,0 +1 @@ +overlay equations https://github.com/ppedrot/Coq-Equations mv-evaluable-global-ref-out-of-kernel 13321 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/case-repr.md b/dev/doc/case-repr.md new file mode 100644 index 0000000000..e1a78797bd --- /dev/null +++ b/dev/doc/case-repr.md @@ -0,0 +1,122 @@ +## Case representation + +Starting from Coq 8.14, the term representation of pattern-matching uses a +so-called *compact form*. Compared to the previous representation, the major +difference is that all type and term annotations on lambda and let abstractions +that were present in branches and return clause of pattern-matchings were +removed. In order to keep the ability to construct the old expanded form out of +the new compact form, the case node also makes explicit data that was stealthily +present in the expanded return clause, namely universe instances and parameters +of the inductive type being eliminated. + +### ML Representation + +The case node now looks like +``` +Case of + case_info * + Instance.t * (* universe instances of the inductive *) + constr array * (* parameters of the inductive *) + case_return * (* erased return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + case_branch array (* erased branches *) +``` +where +``` +type case_branch = Name.t binder_annot array * constr +type case_return = Name.t binder_annot array * types +``` + +For comparison, pre-8.14 case nodes were defined as follows. +``` +Case of + case_info * + constr * (* annotated return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + constr array (* annotated branches *) +``` + +### Typing Rules and Invariants + +Disregarding the `case_info` cache and the SProp inversion, the typing rules for +the case node can be given as follows. + +Provided +- Γ ⊢ c : Ind@{u} pms Indices +- Inductive Ind@{i} Δ : forall Θ, Type := cᵢ : forall Ξᵢ, Ind Δ Aᵢ +- Γ, Θ@{i := u}{Δ := pms} ⊢ p : Type +- Γ, Ξᵢ@{i := u}{Δ := pms} ⊢ snd brᵢ : p{Θ := Aᵢ{Δ := pms}} + +Then Γ ⊢ Case (_, u, pms, ( _, p), _, c, br) : p{Θ := Indices} + +In particular, this implies that Γ ⊢ pms : Δ@{i := u}. Parameters are stored in +the same order as in the application node. + +The u universe instance must be a valid instance for the corresponding +inductive type, in particular their length must coincide. + +The `Name.t binder_annot array` appearing both in the return clause and +in the branches must satisfy these invariants: +- For branches, it must have the same length as the corresponding Ξᵢ context +(including let-ins) +- For the return clause, it must have the same length as the context +Θ, self : Ind@{u} pms Θ (including let-ins). The last variable appears as +the term being destructed and corresponds to the variable introduced by the +"as" clause of the user-facing syntax. +- The relevance annotations must match with the corresponding sort of the +variable from the context. + +Note that the annotated variable array is reversed w.r.t. the context, +i.e. variables appear left to right as in standard practice. + +Let-bindings can appear in Δ, Θ or Ξᵢ, since they are arbitrary +contexts. As a general rule, let bindings appear as binders but not as +instances. That is, they MUST appear in the variable array, but they MUST NOT +appear in the parameter array. + +Example: +``` +Inductive foo (X := tt) : forall (Y := X), Type := Foo : forall (Z := X), foo. + +Definition case (x : foo) : unit := match x as x₀ in foo with Foo _ z => z end +``` +The case node of the `case` function is represented as +``` +Case ( + _, + Instance.empty, + [||], + ([|(Y, Relevant); (x₀, Relevant)|], unit), (* let (Y := tt) in fun (x₀ : foo) => unit *) + NoInvert, + #1, + [| + ([|(z, Relevant)|], #1) (* let z := tt in z *) + |] +) +``` + +This choice of representation for let-bindings requires access to the +environment in some cases, e.g. to compute branch reduction. There is a +fast-path for non-let-containing inductive types though, which are the vast +majority. + +### Porting plugins + +The conversion functions from and to the expanded form are: +- `[Inductive, EConstr].expand_case` which goes from the compact to the expanded +form and cannot fail (assuming the term was well-typed) +- `[Inductive, EConstr].contract_case` which goes the other way and will +raise anomalies if the expanded forms are not fully eta-expanded. + +As such, it is always painless to convert to the old representation. Converting +the other way, you must ensure that all the terms you provide the +compatibility function with are fully eta-expanded, **including let-bindings**. +This works as expected for the common case with eta-expanded branches but will +fail for plugins that generate non-eta-expanded branches. + +Some other useful variants of these functions are: +- `Inductive.expand_case_specif` +- `EConstr.annotate_case` +- `EConstr.expand_branch` 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/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/include_printers b/dev/include_printers index 7583762970..414468ca65 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -54,4 +54,6 @@ #install_printer (* fconstr *) ppfconstr;; +#install_printer (* fsubst *) ppfsubst;; + #install_printer (* Future.computation *) ppfuture;; 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 bfc186c862..fe95a59d9b 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,6 +23,7 @@ install_printer Top_printers.ppconstr_expr install_printer Top_printers.ppglob_constr install_printer Top_printers.pppattern install_printer Top_printers.ppfconstr +install_printer Top_printers.ppfsubst install_printer Top_printers.ppnumtokunsigned install_printer Top_printers.ppnumtokunsignednat install_printer Top_printers.ppintset diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a9438c4aca..f3d6239c6f 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,11 +80,20 @@ 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) +let ppfsubst s = + let (s, k) = Esubst.Internal.repr s in + let sep () = str ";" ++ spc () in + let pr = function + | Esubst.Internal.REL n -> str "<#" ++ int n ++ str ">" + | Esubst.Internal.VAL (k, x) -> pr_constr (Vars.lift k (CClosure.term_of_fconstr x)) + in + pp @@ str "[" ++ prlist_with_sep sep pr s ++ str "| " ++ int k ++ str "]" + let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) @@ -130,7 +144,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) @@ -212,7 +226,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) @@ -226,7 +240,7 @@ let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx -let ppuniverses u = pp (UGraph.pr_universes Level.pr u) +let ppuniverses u = pp (UGraph.pr_universes Level.pr (UGraph.repr u)) let ppnamedcontextval e = let env = Global.env () in let sigma = Evd.from_env env in @@ -293,9 +307,9 @@ let constr_display csr = "MutConstruct(("^(MutInd.to_string sp)^","^(string_of_int i)^")," ^","^(universes_display u)^(string_of_int j)^")" | Proj (p, c) -> "Proj("^(Constant.to_string (Projection.constant p))^","^term_display c ^")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,(_,p),iv,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," - ^(array_display bl)^")" + ^(array_display (Array.map snd bl))^")" | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," @@ -406,13 +420,25 @@ let print_pure_constr csr = print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + Array.iter (fun na -> print_cut (); name_display na) nas; + print_string " |- "; + box_display c + in open_vbox 0; - print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; - print_space(); box_display c; print_space (); print_string "of"; + print_space(); box_display c; print_space (); + print_cut(); print_string "in"; + print_cut(); print_string "Ind("; + sp_display (fst ci.ci_ind); + print_string ","; print_int (snd ci.ci_ind); print_string ")"; + print_string "@{"; universes_display u; print_string "}"; + Array.iter (fun x -> print_space (); box_display x) pms; + print_cut(); print_string "return <"; pr_ctx p; print_string ">"; + print_cut(); print_string "with"; open_vbox 0; - Array.iter (fun x -> print_cut(); box_display x) bl; + Array.iter (fun x -> print_cut(); pr_ctx x) bl; close_box(); print_cut(); print_string "end"; diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 50495dc0a4..e8ed6c709e 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -52,6 +52,7 @@ val ppconstr_expr : Constrexpr.constr_expr -> unit val ppglob_constr : 'a Glob_term.glob_constr_g -> unit val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit +val ppfsubst : CClosure.fconstr Esubst.subs -> unit val ppnumtokunsigned : NumTok.Unsigned.t -> unit val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit diff --git a/doc/README.md b/doc/README.md index 79d1e1b756..440b104c16 100644 --- a/doc/README.md +++ b/doc/README.md @@ -69,6 +69,16 @@ Or if you want to use less disk space: apt install texlive-latex-extra texlive-fonts-recommended texlive-xetex \ latexmk fonts-freefont-otf +### Setting the locale for Python + +Make sure that the locale is configured on your platform so that Python encodes +printed messages with utf-8 rather than generating runtime exceptions +for non-ascii characters. The `.UTF-8` in `export LANG=C.UTF-8` sets UTF-8 encoding. +The `C` can be replaced with any supported language code. You can set the default +for a Docker build with `ENV LANG C.UTF-8`. (Python may look at other +environment variables to determine the locale; see the +[Python documentation](https://docs.python.org/3/library/locale.html#locale.getdefaultlocale)). + Compilation ----------- 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/01-kernel/13563-compact-case-repr.rst b/doc/changelog/01-kernel/13563-compact-case-repr.rst new file mode 100644 index 0000000000..c8ee9bc1e6 --- /dev/null +++ b/doc/changelog/01-kernel/13563-compact-case-repr.rst @@ -0,0 +1,15 @@ +- **Changed:** + The term representation of pattern-matchings now uses a compact form that + provides a few static guarantees such as eta-expansion of branches and return + clauses and is usually more efficient. The most visible user change is that for + the time being, the :tacn:`destruct` tactic and its variants generate dummy + cuts (β redexes) in the branches of the generated proof. + This can also generate very uncommon backwards incompatibilities, such as a + change of occurrence numbering for subterms, or breakage of unification in + complex situations involving pattern-matchings whose underlying inductive type + declares let-bindings in parameters, arity or constructor types. For ML plugin + developers, an in-depth description of the new representation, as well as + porting tips, can be found in dev/doc/case-repr.md + (`#13563 <https://github.com/coq/coq/pull/13563>`_, + fixes `#3166 <https://github.com/coq/coq/issues/3166>`_, + by Pierre-Marie Pédrot). 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/12246-master+apply-in-many-hyps.rst b/doc/changelog/04-tactics/12246-master+apply-in-many-hyps.rst deleted file mode 100644 index 15ab18dcf1..0000000000 --- a/doc/changelog/04-tactics/12246-master+apply-in-many-hyps.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - `apply in` supports several hypotheses - (`#12246 <https://github.com/coq/coq/pull/12246>`_, - by Hugo Herbelin; grants - `#9816 <https://github.com/coq/coq/pull/9816>`_). diff --git a/doc/changelog/04-tactics/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/13417-no_int_or_var.rst b/doc/changelog/04-tactics/13417-no_int_or_var.rst deleted file mode 100644 index 667ee28eea..0000000000 --- a/doc/changelog/04-tactics/13417-no_int_or_var.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Removed:** - A number of tactics that formerly accepted negative - numbers as parameters now give syntax errors for negative - values. These include {e}constructor, do, timeout, - 9 {e}auto tactics and psatz*. - (`#13417 <https://github.com/coq/coq/pull/13417>`_, - by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13469-no-int-in-fail.rst b/doc/changelog/04-tactics/13469-no-int-in-fail.rst new file mode 100644 index 0000000000..e0fcbb924e --- /dev/null +++ b/doc/changelog/04-tactics/13469-no-int-in-fail.rst @@ -0,0 +1,5 @@ +- **Removed:** + :tacn:`fail` and :tacn:`gfail`, which formerly accepted negative + values as a parameter, now give syntax errors for negative + values (`#13469 <https://github.com/coq/coq/pull/13469>`_, + 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/04-tactics/13696-deprecate_at_in_conversion.rst b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst new file mode 100644 index 0000000000..306fe8052d --- /dev/null +++ b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst @@ -0,0 +1,7 @@ +- **Deprecated:** + In :tacn:`change` and :tacn:`change_no_check`, the + `at ... with ...` form is deprecated. Use + `with ... at ...` instead. For `at ... with ... in H |-`, + use `with ... in H at ... |-`. + (`#13696 <https://github.com/coq/coq/pull/13696>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13715-lia_implb.rst b/doc/changelog/04-tactics/13715-lia_implb.rst new file mode 100644 index 0000000000..dd61872342 --- /dev/null +++ b/doc/changelog/04-tactics/13715-lia_implb.rst @@ -0,0 +1,2 @@ +- **Added:** + :tacn:`lia` supports the boolean operator `Bool.implb` (`#13715 <https://github.com/coq/coq/pull/13715>`_, by Frédéric Besson). 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/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/README.rst b/doc/sphinx/README.rst index bfdbc4c4db..9495fd0e45 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -107,7 +107,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. 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/extraction.rst b/doc/sphinx/addendum/extraction.rst index 3662822a5e..8e72bb4ffd 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -100,7 +100,6 @@ Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Extraction Language @language - :name: Extraction Language .. insertprodn language language @@ -431,12 +430,10 @@ Additional settings ~~~~~~~~~~~~~~~~~~~ .. opt:: Extraction File Comment @string - :name: Extraction File Comment Provides a comment that is included at the beginning of the output files. .. opt:: Extraction Flag @natural - :name: Extraction Flag Controls which optimizations are used during extraction, providing a finer-grained control than :flag:`Extraction Optimize`. The bits of :token:`natural` are used as a bit mask. diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 27ae7cea3a..9ac05fab2e 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -101,7 +101,7 @@ morphisms, that are required to be simultaneously monotone on every argument. Morphisms can also be contravariant in one or more of their arguments. -A morphism is contravariant on an argument associated to the relation +A morphism is contravariant on an argument associated with the relation instance :math:`R` if it is covariant on the same argument when the inverse relation :math:`R^{−1}` (``inverse R`` in Coq) is considered. The special arrow ``-->`` is used in signatures for contravariant morphisms. @@ -336,7 +336,7 @@ respective relation instances. in the previous example). Applying ``union_compat`` by hand we are left with the goal ``eq_set (union S S) (union S S)``. -When the relations associated to some arguments are not reflexive, the +When the relations associated with some arguments are not reflexive, the tactic cannot automatically prove the reflexivity goals, that are left to the user. @@ -477,8 +477,8 @@ documentation on :ref:`typeclasses` and the theories files in Classes for further explanations. One can inform the rewrite tactic about morphisms and relations just -by using the typeclass mechanism to declare them using Instance and -Context vernacular commands. Any object of type Proper (the type of +by using the typeclass mechanism to declare them using the :cmd:`Instance` and +:cmd:`Context` commands. Any object of type Proper (the type of morphism declarations) in the local context will also be automatically used by the rewriting tactic to solve constraints. @@ -535,17 +535,25 @@ 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 omitted, it defaults to the ``DefaultRelation`` instance on the type of the objects. By default, it means the most recent ``Equivalence`` instance - in the environment, but it can be customized by declaring + in the global environment, but it can be customized by declaring new ``DefaultRelation`` instances. As Leibniz equality is a declared equivalence, it will fall back to it if no other relation is declared on a given type. @@ -600,7 +608,6 @@ Deprecated syntax and backward incompatibilities an old development to the new semantics is usually quite simple. .. cmd:: Declare Morphism @one_term : @ident - :name: Declare Morphism Declares a parameter in a module type that is a morphism. @@ -678,7 +685,7 @@ Note that when one does rewriting with a lemma under a binder using variable, as the semantics are different from rewrite where the lemma is first matched on the whole term. With the new :tacn:`setoid_rewrite`, matching is done on each subterm separately and in its local -environment, and all matches are rewritten *simultaneously* by +context, and all matches are rewritten *simultaneously* by default. The semantics of the previous :tacn:`setoid_rewrite` implementation can almost be recovered using the ``at 1`` modifier. @@ -714,9 +721,35 @@ 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 ------------------------ +Usage +~~~~~ + +.. tacn:: rewrite_strat @rewstrategy {? in @ident } + :name: rewrite_strat + + Rewrite using :n:`@rewstrategy` in the conclusion or in the hypothesis :n:`@ident`. + + .. exn:: Nothing to rewrite. + + The strategy didn't find any matches. + + .. exn:: No progress made. + + If the strategy succeeded but made no progress. + + .. exn:: Unable to satisfy the rewriting constraints. + + If the strategy succeeded and made progress but the + corresponding rewriting constraints are not satisfied. + + :tacn:`setoid_rewrite` :n:`@one_term` is basically equivalent to + :n:`rewrite_strat outermost @one_term`. + Definitions ~~~~~~~~~~~ @@ -764,7 +797,7 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. failure :n:`id` - identity + identity :n:`refl` reflexivity @@ -794,10 +827,16 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. all subterms :n:`innermost @rewstrategy` - innermost first + Innermost first. + When there are multiple nested matches in a subterm, the innermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`(b + a) + c`. :n:`outermost @rewstrategy` - outermost first + Outermost first. + When there are multiple nested matches in a subterm, the outermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`c + (a + b)`. :n:`bottomup @rewstrategy` bottom-up @@ -824,8 +863,8 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. to be documented -A few of these are defined in terms of the others using a -primitive fixpoint operator: +Conceptually, a few of these are defined in terms of the others using a +primitive fixpoint operator `fix`, which the tactic doesn't currently support: - :n:`try @rewstrategy := choice @rewstrategy id` - :n:`any @rewstrategy := fix @ident. try (@rewstrategy ; @ident)` @@ -867,30 +906,30 @@ if it reduces the subterm under consideration. The ``fold`` strategy takes a :token:`term` and tries to *unify* it to the current subterm, converting it to :token:`term` on success. It is stronger than the tactic ``fold``. +.. _rewrite_strat_innermost_outermost: -Usage -~~~~~ - - -.. tacn:: rewrite_strat @rewstrategy {? in @ident } - :name: rewrite_strat +.. example:: :n:`innermost` and :n:`outermost` - Rewrite using the strategy s in hypothesis ident or the conclusion. + The type of `Nat.add_comm` is `forall n m : nat, n + m = m + n`. - .. exn:: Nothing to rewrite. + .. coqtop:: all - If the strategy failed. + Require Import Coq.Arith.Arith. + Set Printing Parentheses. + Goal forall a b c: nat, a + b + c = 0. + rewrite_strat innermost Nat.add_comm. - .. exn:: No progress made. + .. coqtop:: none - If the strategy succeeded but made no progress. + Abort. + Goal forall a b c: nat, a + b + c = 0. - .. exn:: Unable to satisfy the rewriting constraints. + Using :n:`outermost` instead gives this result: - If the strategy succeeded and made progress but the - corresponding rewriting constraints are not satisfied. + .. coqtop:: all + rewrite_strat outermost Nat.add_comm. - The ``setoid_rewrite c`` tactic is basically equivalent to - ``rewrite_strat (outermost c)``. + .. coqtop:: none + Abort. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 0f0ccd6a20..09b2bb003a 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -202,7 +202,6 @@ Use :n:`:>` instead of :n:`:` before the :undocumented: .. cmd:: SubClass @ident_decl @def_body - :name: SubClass If :n:`@type` is a class :n:`@ident'` applied to some arguments then :n:`@ident` is defined and an identity coercion of name @@ -243,7 +242,6 @@ Activating the Printing of Coercions By default, coercions are not printed. .. table:: Printing Coercion @qualid - :name: Printing Coercion Specifies a set of qualids for which coercions are always displayed. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 28b60878d2..38c4886e0f 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -140,7 +140,6 @@ and checked to be :math:`-1`. ------------------------------------------------------------------- .. tacn:: lra - :name: lra This tactic is searching for *linear* refutations. As a result, this tactic explores a subset of the *Cone* defined as @@ -154,7 +153,6 @@ and checked to be :math:`-1`. --------------------------------------------- .. tacn:: lia - :name: lia This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. @@ -220,7 +218,6 @@ a proof. -------------------------------------------------- .. tacn:: nra - :name: nra This tactic is an *experimental* proof procedure for non-linear arithmetic. The tactic performs a limited amount of non-linear @@ -241,7 +238,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------------- .. tacn:: nia - :name: nia This tactic is a proof procedure for non-linear integer arithmetic. It performs a pre-processing similar to :tacn:`nra`. The obtained goal is @@ -251,7 +247,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------- .. tacn:: psatz @one_term {? @nat_or_var } - :name: psatz This tactic explores the *Cone* by increasing degrees – hence the depth parameter :token:`nat_or_var`. In theory, such a proof search is complete – if the @@ -281,7 +276,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. ------------------------------------------ .. tacn:: zify - :name: zify This tactic is internally called by :tacn:`lia` to support additional types, e.g., :g:`nat`, :g:`positive` and :g:`N`. Additional support is provided by the following modules: diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 2b10f5671d..0997c5e868 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -28,7 +28,6 @@ Description of ``omega`` ------------------------ .. tacn:: omega - :name: omega .. deprecated:: 8.12 diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index e824ae152d..ea506cec84 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -70,7 +70,7 @@ Coq 8.6 introduced a mechanism for error resilience: in interactive mode Coq is able to completely check a document containing errors instead of bailing out at the first failure. -Two kind of errors are supported: errors occurring in vernacular +Two kind of errors are supported: errors occurring in commands and errors occurring in proofs. To properly recover from a failing tactic, Coq needs to recognize the @@ -89,8 +89,8 @@ kind of proof blocks, and an ML API to add new ones. Caveats ```````` -When a vernacular command fails the subsequent error messages may be -bogus, i.e. caused by the first error. Error resilience for vernacular +When a command fails the subsequent error messages may be +bogus, i.e. caused by the first error. Error resilience for commands can be switched off by passing ``-async-proofs-command-error-resilience off`` to CoqIDE. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 104f84a253..2b24ced8a1 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -161,7 +161,7 @@ Program Definition A :cmd:`Definition` command with the :attr:`program` attribute types the value term in Russell and generates proof obligations. Once solved using the commands shown below, it binds the -final Coq term to the name :n:`@ident` in the environment. +final Coq term to the name :n:`@ident` in the global environment. :n:`Program Definition @ident : @type := @term` @@ -268,7 +268,6 @@ obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. .. cmd:: Obligation Tactic := @ltac_expr - :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations automatically, whether to solve them or when starting to prove one, diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index c93d621048..954c2c1446 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -421,7 +421,7 @@ Error messages: .. exn:: Ring operation should be declared as a morphism. - A setoid associated to the carrier of the ring structure has been found, + A setoid associated with the carrier of the ring structure has been found, but the ring operation should be declared as morphism. See :ref:`tactics-enabled-on-user-provided-relations`. How does it work? diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 2b1f343e14..8c20e08154 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -19,7 +19,6 @@ Use of |SProp| may be disabled by passing ``-disallow-sprop`` to the Coq program or by turning the :flag:`Allow StrictProp` flag off. .. flag:: Allow StrictProp - :name: Allow StrictProp Enables or disables the use of |SProp|. It is enabled by default. The command-line flag ``-disallow-sprop`` disables |SProp| at @@ -283,7 +282,6 @@ This means that some errors will be delayed until ``Qed``: Abort. .. flag:: Elaboration StrictProp Cumulativity - :name: Elaboration StrictProp Cumulativity Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. @@ -320,7 +318,6 @@ so correctly converts ``x`` and ``y``. it to find when your tactics are producing incorrect marks. .. flag:: Cumulative StrictProp - :name: Cumulative StrictProp Set this flag (it is off by default) to make the kernel accept cumulativity between |SProp| and other universes. This makes diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 98445fca1a..8dc0030115 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -160,7 +160,7 @@ Sections and contexts --------------------- To ease developments parameterized by many instances, one can use the -:cmd:`Context` command to introduce these parameters into section contexts, +:cmd:`Context` command to introduce the parameters into the :term:`local context`, it works similarly to the command :cmd:`Variable`, except it accepts any binding context as an argument, so variables can be implicit, and :ref:`implicit-generalization` can be used. @@ -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 @@ -428,7 +422,7 @@ Summary of the commands resolution with the local hypotheses use full conversion during unification. - + The mode hints (see :cmd:`Hint Mode`) associated to a class are + + The mode hints (see :cmd:`Hint Mode`) associated with a class are taken into account by :tacn:`typeclasses eauto`. When a goal does not match any of the declared modes for its head (if any), instead of failing like :tacn:`eauto`, the goal is suspended and @@ -476,7 +470,6 @@ Summary of the commands refinement engine will be able to backtrack. .. tacn:: autoapply @one_term with @ident - :name: autoapply The tactic ``autoapply`` applies :token:`one_term` using the transparency information of the hint database :token:`ident`, and does *no* typeclass resolution. This can @@ -503,7 +496,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 +548,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 @@ -596,7 +589,6 @@ Settings :cmd:`Typeclasses eauto` is another way to set this flag. .. opt:: Typeclasses Depth @natural - :name: Typeclasses Depth Sets the maximum proof search depth. The default is unbounded. :cmd:`Typeclasses eauto` is another way to set this option. @@ -608,7 +600,6 @@ Settings is another way to set this flag. .. opt:: Typeclasses Debug Verbosity @natural - :name: Typeclasses Debug Verbosity Determines how much information is shown for typeclass resolution steps during search. 1 is the default level. 2 shows additional information such as tried tactics and shelving @@ -619,7 +610,6 @@ Typeclasses eauto ~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses eauto := {? debug } {? ( {| bfs | dfs } ) } {? @natural } - :name: Typeclasses eauto Allows more global customization of the :tacn:`typeclasses eauto` tactic. The options are: diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 4615a8dfca..d0b05a03f9 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -328,7 +328,7 @@ Cumulativity Weak Constraints Global and local universes --------------------------- -Each universe is declared in a global or local environment before it +Each universe is declared in a global or local context before it can be used. To ensure compatibility, every *global* universe is set to be strictly greater than :g:`Set` when it is introduced, while every *local* (i.e. polymorphically quantified) universe is introduced as @@ -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 @@ -617,7 +617,7 @@ definitions in the section sharing a common variable will both get parameterized by the universes produced by the variable declaration. This is in contrast to a “mononorphic” variable which introduces global universes and constraints, making the two definitions depend on -the *same* global universes associated to the variable. +the *same* global universes associated with the variable. It is possible to mix universe polymorphism and monomorphism in sections, except in the following ways: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 24fa71059c..d9e4e4f2b3 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -8,6 +8,699 @@ 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). + +Changes in 8.13.0 +~~~~~~~~~~~~~~~~~ + +Commands and options +^^^^^^^^^^^^^^^^^^^^ + +- **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). + Version 8.12 ------------ @@ -261,7 +954,7 @@ Notations by Hugo Herbelin). - **Fixed:** Different interpretations in different scopes of the same notation - string can now be associated to different printing formats (`#10832 + string can now be associated with different printing formats (`#10832 <https://github.com/coq/coq/pull/10832>`_, by Hugo Herbelin, fixes `#6092 <https://github.com/coq/coq/issues/6092>`_ and `#7766 <https://github.com/coq/coq/issues/7766>`_). @@ -551,7 +1244,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 +2029,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 ------------ @@ -1521,7 +2233,7 @@ Changes in 8.11+beta1 documentation. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) - **Added:** - The :cmd:`Section` vernacular command now accepts the "universes" attribute. In + The :cmd:`Section` command now accepts the "universes" attribute. In addition to setting the section universe polymorphism, it also locally sets the universe polymorphic option inside the section. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) @@ -2520,7 +3232,7 @@ Other changes in 8.10+beta1 New `relpre R f` definition for the preimage of a relation R under f (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). -- Vernacular commands: +- Commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. Names may not be repeated, and may not overlap with section variable names @@ -2852,7 +3564,7 @@ Changes in 8.10.2 **Notations** -- Fixed an 8.10 regression related to the printing of coercions associated to notations +- Fixed an 8.10 regression related to the printing of coercions associated with notations (`#11090 <https://github.com/coq/coq/pull/11090>`_, fixes `#11033 <https://github.com/coq/coq/issues/11033>`_, by Hugo Herbelin). @@ -3093,7 +3805,7 @@ Focusing - Focusing bracket `{` now supports named goal selectors, e.g. `[x]: {` will focus on a goal (existential variable) named `x`. - As usual, unfocus with `}` once the sub-goal is fully solved. + As usual, unfocus with `}` once the subgoal is fully solved. Specification language @@ -3158,7 +3870,7 @@ Tools please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. -Vernacular Commands +Commands - Removed deprecated commands `Arguments Scope` and `Implicit Arguments` (not the option). Use the `Arguments` command instead. @@ -3170,7 +3882,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 @@ -3429,11 +4141,11 @@ Tactics Focusing - Focusing bracket `{` now supports single-numbered goal selector, - e.g. `2: {` will focus on the second sub-goal. As usual, unfocus - with `}` once the sub-goal is fully solved. + e.g. `2: {` will focus on the second subgoal. As usual, unfocus + with `}` once the subgoal is fully solved. The `Focus` and `Unfocus` commands are now deprecated. -Vernacular Commands +Commands - Proofs ending in "Qed exporting ident, .., ident" are not supported anymore. Constants generated during `abstract` are kept private to the @@ -3807,7 +4519,7 @@ Gallina - Now supporting all kinds of binders, including 'pat, in syntax of record fields. -Vernacular Commands +Commands - Goals context can be printed in a more compact way when `Set Printing Compact Contexts` is activated. @@ -4045,7 +4757,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. @@ -4639,7 +5351,7 @@ Logic the dependent one. To recover the old behavior, explicitly define your inductive types in Set. -Vernacular commands +Commands - A command "Variant" allows to define non-recursive variant types. - The command "Record foo ..." does not generate induction principles @@ -5096,7 +5808,7 @@ API Details of changes in 8.5beta3 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New command "Redirect" to redirect the output of a command to a file. - New command "Undelimit Scope" to remove the delimiter of a scope. @@ -5140,7 +5852,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 @@ -5475,7 +6187,7 @@ Regarding decision tactics, Loïc Pottier maintained nsatz, moving in particular to a typeclass based reification of goals while Frédéric Besson maintained Micromega, adding in particular support for division. -Regarding vernacular commands, Stéphane Glondu provided new commands to +Regarding commands, Stéphane Glondu provided new commands to analyze the structure of type universes. Regarding libraries, a new library about lists of a given length (called @@ -5672,7 +6384,7 @@ Tactics constructor. Last one can mark a constant so that it is unfolded only if the simplified term does not expose a match in head position. -Vernacular commands +Commands - It is now mandatory to have a space (or tabulation or newline or end-of-file) after a "." ending a sentence. @@ -5776,7 +6488,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. @@ -5862,7 +6574,7 @@ Tools Details of changes in 8.4beta2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - Commands "Back" and "BackTo" are now handling the proof states. They may perform some extra steps of backtrack to avoid states where the proof @@ -5911,7 +6623,7 @@ CoqIDE Details of changes in 8.4 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - The "Reset" command is now supported again in files given to coqc or Load. - "Show Script" now indents again the displayed scripts. It can also work @@ -6215,7 +6927,7 @@ Type classes anonymous instances, declarations giving terms, better handling of sections and [Context]. -Vernacular commands +Commands - New command "Timeout <n> <command>." interprets a command and a timeout interrupts the execution after <n> seconds. @@ -6388,7 +7100,7 @@ implement a new resolution-based version of the tactics dedicated to rewriting on arbitrary transitive relations. Another major improvement of Coq 8.2 is the evolution of the arithmetic -libraries and of the tools associated to them. Benjamin Grégoire and +libraries and of the tools associated with them. Benjamin Grégoire and Laurent Théry contributed a modular library for building arbitrarily large integers from bounded integers while Evgeny Makarov contributed a modular library of abstract natural and integer arithmetic together @@ -6496,7 +7208,7 @@ Language of easily fixed incompatibility in case of manual definition of a recursor in a recursive singleton inductive type]. -Vernacular commands +Commands - Added option Global to "Arguments Scope" for section surviving. - Added option "Unset Elimination Schemes" to deactivate the automatic @@ -6830,7 +7542,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 @@ -7096,7 +7808,7 @@ Syntax - Support for primitive interpretation of string literals - Extended support for Unicode ranges -Vernacular commands +Commands - Added "Print Ltac qualid" to print a user defined tactic. - Added "Print Rewrite HintDb" to print the content of a DB used by @@ -7274,7 +7986,7 @@ Libraries - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on the allowance for recursively non uniform parameters (possible source of incompatibilities: explicit pattern-matching on these - types may require to remove the occurrence associated to their + types may require to remove the occurrence associated with their recursively non uniform parameter). - Coq.List.In_dec has been set transparent (this may exceptionally break proof scripts, set it locally opaque for compatibility). @@ -7493,7 +8205,7 @@ Syntax for arithmetic - Locate applied to a simple string (e.g. "+") searches for all notations containing this string -Vernacular commands +Commands - "Declare ML Module" now allows to import .cma files. This avoids to use a bunch of "Declare ML Module" statements when using several ML files. @@ -7654,7 +8366,7 @@ New concrete syntax - A completely new syntax for terms - A more uniform syntax for tactics and the tactic language -- A few syntactic changes for vernacular commands +- A few syntactic changes for commands - A smart automatic translator translating V8.0 files in old syntax to files valid for V8.0 @@ -7725,7 +8437,7 @@ Known problems of the automatic translation Details of changes in 8.0 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New option "Set Printing All" to deactivate all high-level forms of printing (implicit arguments, coercions, destructing let, diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index af5d1e3a00..edbc89aad8 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,15 +183,10 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'tactic', 'induction_clause', - 'conversion', 'where', - 'oriented_rewriter', - 'hintbases', 'bindings_with_parameters', - 'destruction_arg', - 'clause_dft_concl' + 'destruction_arg' ]] # -- Options for HTML output ---------------------------------------------- @@ -222,7 +217,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/"), @@ -495,3 +490,6 @@ epub_exclude_files = ['search.html'] # navtree options navtree_shift = True + +# since sphinxcontrib-bibtex version 2 we need this +bibtex_bibfiles = [ "biblio.bib" ] diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index c5ef92a1bf..44f2d23801 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -954,7 +954,7 @@ Parsing and grammar extension for Time and to write grammar rules abbreviating several commands) (+) - The default parser for actions in the grammar rules (and for - patterns in the pretty-printing rules) is now the one associated to + patterns in the pretty-printing rules) is now the one associated with the grammar (i.e. vernac, tactic or constr); no need then for quotations as in <:vernac:<...>>; to return an "ast", the grammar must be explicitly typed with tag ": ast" or ": ast list", or if a @@ -1346,12 +1346,12 @@ Language instead to simulate the old behaviour of Local (the section part of the name is not kept though) -ML tactic and vernacular commands +ML tactics and commands - "Grammar tactic" and "Grammar vernac" of type "ast" are no longer supported (only "Grammar tactic simple_tactic" of type "tactic" remains available). -- Concrete syntax for ML written vernacular commands and tactics is +- Concrete syntax for ML written commands and tactics is now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC COMMAND EXTEND. - "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 06a677d837..0b183d3f3f 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -45,9 +45,9 @@ This manual is organized in three main parts, plus an appendix: translated down to the language of the kernel by means of an "elaboration process". -- **The second part presents the interactive proof mode**, the central +- **The second part presents proof mode**, the central feature of Coq. :ref:`writing-proofs` introduces this interactive - proof mode and the available proof languages. + mode and the available proof languages. :ref:`automatic-tactics` presents some more advanced tactics, while :ref:`writing-tactics` is about the languages that allow a user to combine tactics together and develop new ones. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 85b04f6df0..1cfd8dac50 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -101,7 +101,7 @@ and it can be applied to any expression of type :math:`\nat`, say :math:`t`, to object :math:`P~t` of type :math:`\Prop`, namely a proposition. Furthermore :g:`forall x:nat, P x` will represent the type of functions -which associate to each natural number :math:`n` an object of type :math:`(P~n)` and +which associate with each natural number :math:`n` an object of type :math:`(P~n)` and consequently represent the type of proofs of the formula “:math:`∀ x.~P(x)`”. @@ -111,51 +111,49 @@ Typing rules ---------------- As objects of type theory, terms are subjected to *type discipline*. -The well typing of a term depends on a global environment and a local -context. - +The well typing of a term depends on a local context and a global environment. .. _Local-context: **Local context.** -A *local context* is an ordered list of *local declarations* of names -which we call *variables*. The declaration of some variable :math:`x` is -either a *local assumption*, written :math:`x:T` (:math:`T` is a type) or a *local -definition*, written :math:`x:=t:T`. We use brackets to write local contexts. -A typical example is :math:`[x:T;~y:=u:U;~z:V]`. Notice that the variables +A :term:`local context` is an ordered list of declarations of *variables*. +The declaration of a variable :math:`x` is +either an *assumption*, written :math:`x:T` (where :math:`T` is a type) or a +*definition*, written :math:`x:=t:T`. Local contexts are written in brackets, +for example :math:`[x:T;~y:=u:U;~z:V]`. The variables declared in a local context must be distinct. If :math:`Γ` is a local context -that declares some :math:`x`, we -write :math:`x ∈ Γ`. By writing :math:`(x:T) ∈ Γ` we mean that either :math:`x:T` is an -assumption in :math:`Γ` or that there exists some :math:`t` such that :math:`x:=t:T` is a -definition in :math:`Γ`. If :math:`Γ` defines some :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. +that declares :math:`x`, we +write :math:`x ∈ Γ`. Writing :math:`(x:T) ∈ Γ` means there is an assumption +or a definition giving the type :math:`T` to :math:`x` in :math:`Γ`. +If :math:`Γ` defines :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. For the rest of the chapter, :math:`Γ::(y:T)` denotes the local context :math:`Γ` enriched with the local assumption :math:`y:T`. Similarly, :math:`Γ::(y:=t:T)` denotes the local context :math:`Γ` enriched with the local definition :math:`(y:=t:T)`. The -notation :math:`[]` denotes the empty local context. By :math:`Γ_1 ; Γ_2` we mean +notation :math:`[]` denotes the empty local context. Writing :math:`Γ_1 ; Γ_2` means concatenation of the local context :math:`Γ_1` and the local context :math:`Γ_2`. - .. _Global-environment: **Global environment.** -A *global environment* is an ordered list of *global declarations*. -Global declarations are either *global assumptions* or *global -definitions*, but also declarations of inductive objects. Inductive -objects themselves declare both inductive or coinductive types and -constructors (see Section :ref:`inductive-definitions`). - -A *global assumption* will be represented in the global environment as -:math:`(c:T)` which assumes the name :math:`c` to be of some type :math:`T`. A *global -definition* will be represented in the global environment as :math:`c:=t:T` -which defines the name :math:`c` to have value :math:`t` and type :math:`T`. We shall call +A :term:`global environment` is an ordered list of *declarations*. +Global declarations are either *assumptions*, *definitions* +or declarations of inductive objects. Inductive +objects declare both constructors and inductive or +coinductive types (see Section :ref:`inductive-definitions`). + +In the global environment, +*assumptions* are written as +:math:`(c:T)`, indicating that :math:`c` is of the type :math:`T`. *Definitions* +are written as :math:`c:=t:T`, indicating that :math:`c` has the value :math:`t` +and type :math:`T`. We shall call such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes -the global environment :math:`E` enriched with the global assumption :math:`c:T`. +the global environment :math:`E` enriched with the assumption :math:`c:T`. Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the -global definition :math:`(c:=t:T)`. +definition :math:`(c:=t:T)`. The rules for inductive definitions (see Section :ref:`inductive-definitions`) have to be considered as assumption -rules to which the following definitions apply: if the name :math:`c` +rules in which the following definitions apply: if the name :math:`c` is declared in :math:`E`, we write :math:`c ∈ E` and if :math:`c:T` or :math:`c:=t:T` is declared in :math:`E`, we write :math:`(c : T) ∈ E`. @@ -315,7 +313,7 @@ following rules. .. note:: We may have :math:`\letin{x}{t:T}{u}` well-typed without having :math:`((λ x:T.~u)~t)` well-typed (where :math:`T` is a type of - :math:`t`). This is because the value :math:`t` associated to + :math:`t`). This is because the value :math:`t` associated with :math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index d061ed41f1..4f54e33758 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -902,7 +902,6 @@ In addition to the powerful ``ring``, ``field`` and ``lra`` tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR - :name: discrR Proves that two real integer constants are different. @@ -916,7 +915,6 @@ tactics (see Chapter :ref:`tactics`), there are also: discrR. .. tacn:: split_Rabs - :name: split_Rabs Allows unfolding the ``Rabs`` constant and splits corresponding conjunctions. @@ -930,7 +928,6 @@ tactics (see Chapter :ref:`tactics`), there are also: intro; split_Rabs. .. tacn:: split_Rmult - :name: split_Rmult Splits a condition that a product is non null into subgoals corresponding to the condition on each operand of the product. diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index e029068630..8dbc1626ba 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -115,10 +115,10 @@ Section :ref:`explicit-applications`). Assumptions ----------- -Assumptions extend the environment with axioms, parameters, hypotheses +Assumptions extend the global environment with axioms, parameters, hypotheses or variables. An assumption binds an :n:`@ident` to a :n:`@type`. It is accepted -by Coq if and only if this :n:`@type` is a correct type in the environment -preexisting the declaration and if :n:`@ident` was not previously defined in +by Coq only if :n:`@type` is a correct type in the global environment +before the declaration and if :n:`@ident` was not previously defined in the same module. This :n:`@type` is considered to be the type (or specification, or statement) assumed by :n:`@ident` and we say that :n:`@ident` has type :n:`@type`. @@ -141,7 +141,7 @@ has type :n:`@type`. of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in - the global context. The fact asserted by :n:`@type` (or, equivalently, the existence + the global environment. The fact asserted by :n:`@type` (or, equivalently, the existence of an object of this type) is accepted as a postulate. They accept the :attr:`program` attribute. :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms @@ -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/basic.rst b/doc/sphinx/language/core/basic.rst index 2b262b89c0..0a61c4ce22 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -64,7 +64,7 @@ appending the level to the nonterminal name (as in :n:`@term100` or populated by notations or plugins. Furthermore, some parsing rules are only activated in certain - contexts (:ref:`interactive proof mode <proofhandling>`, + contexts (:ref:`proof mode <proofhandling>`, :ref:`custom entries <custom-entries>`...). .. warning:: @@ -332,9 +332,9 @@ rest of the Coq manual: :term:`terms <term>` and :term:`types tactic - Tactics specify how to transform the current proof state as a + A :production:`tactic` specifies how to transform the current proof state as a step in creating a proof. They are syntactically valid only when - Coq is in proof mode, such as after a :cmd:`Theorem` command + Coq is in :term:`proof mode`, such as after a :cmd:`Theorem` command and before any subsequent proof-terminating command such as :cmd:`Qed`. See :ref:`proofhandling` for more on proof mode. @@ -450,7 +450,6 @@ they appear after a boldface label. They are listed in the :ref:`options_index`. .. cmd:: Set @setting_name {? {| @integer | @string } } - :name: Set If :n:`@setting_name` is a flag, no value may be provided; the flag is set to on. @@ -471,7 +470,6 @@ they appear after a boldface label. They are listed in the Coq versions. .. cmd:: Unset @setting_name - :name: Unset If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is set to its default value. diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index 43bbc8b40d..e742139134 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:: @@ -193,7 +194,7 @@ Top-level definitions of co-recursive functions As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously defining several mutual cofixpoints. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 7395b12339..09c619338b 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -47,7 +47,7 @@ refer the interested reader to :cite:`Coq85`. ι-reduction ~~~~~~~~~~~ -A specific conversion rule is associated to the inductive objects in +A specific conversion rule is associated with the inductive objects in the global environment. We shall give later on (see Section :ref:`Well-formed-inductive-definitions`) the precise rules but it just says that a destructor applied to an object built from a @@ -159,7 +159,8 @@ relation :math:`t` reduces to :math:`u` in the global environment reductions β, δ, ι or ζ. We say that two terms :math:`t_1` and :math:`t_2` are -*βδιζη-convertible*, or simply :gdef:`convertible`, or *equivalent*, in the +*βδιζη-convertible*, or simply :gdef:`convertible`, or +:term:`definitionally equal <definitional equality>`, in the global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 57771c9036..7196c082ed 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -56,7 +56,7 @@ has type :n:`@type`. Top-level definitions --------------------- -Definitions extend the environment with associations of names to terms. +Definitions extend the global environment with associations of names to terms. A definition can be seen as a way to give a meaning to a name or as a way to abbreviate a term. In any case, the name can later be replaced at any time by its definition. @@ -82,7 +82,7 @@ Section :ref:`typing-rules`. | {* @binder } : @type reduce ::= Eval @red_expr in - These commands bind :n:`@term` to the name :n:`@ident` in the environment, + These commands bind :n:`@term` to the name :n:`@ident` in the global environment, provided that :n:`@term` is well-typed. They can take the :attr:`local` :term:`attribute`, which makes the defined :n:`@ident` accessible by :cmd:`Import` and its variants only through their fully qualified names. @@ -90,10 +90,11 @@ 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. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -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'. @@ -119,10 +120,11 @@ Section :ref:`typing-rules`. Assertions and proofs --------------------- -An assertion states a proposition (or a type) of which the proof (or an -inhabitant of the type) is interactively built using tactics. The interactive -proof mode is described in Chapter :ref:`proofhandling` and the tactics in -Chapter :ref:`Tactics`. The basic assertion command is: +An assertion states a proposition (or a type) for which the proof (or an +inhabitant of the type) is interactively built using :term:`tactics <tactic>`. +Assertions cause Coq to enter :term:`proof mode` (see :ref:`proofhandling`). +Common tactics are described in the :ref:`writing-proofs` chapter. +The basic assertion command is: .. cmd:: @thm_token @ident_decl {* @binder } : @type {* with @ident_decl {* @binder } : @type } :name: Theorem; Lemma; Fact; Remark; Corollary; Proposition; Property @@ -141,7 +143,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: After the statement is asserted, Coq needs a proof. Once a proof of :n:`@type` under the assumptions represented by :n:`@binder`\s is given and validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and - the theorem is bound to the name :n:`@ident` in the environment. + the theorem is bound to the name :n:`@ident` in the global environment. These commands accept the :attr:`program` attribute. See :ref:`program_lemma`. @@ -158,42 +160,43 @@ Chapter :ref:`Tactics`. The basic assertion command is: have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that recursive proof arguments are correct is done only at the time of registering - the lemma in the environment. To know if the use of induction hypotheses is + the lemma in the global environment. To know if the use of induction hypotheses 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. + You are asserting a new statement when you're already in proof mode. This feature, called nested proofs, is disabled by default. To activate it, turn the :flag:`Nested Proofs Allowed` flag on. -Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof editing mode -until the proof is completed. In proof editing mode, the user primarily enters -tactics, which are described in chapter :ref:`Tactics`. The user may also enter -commands to manage the proof editing mode. They are described in Chapter -:ref:`proofhandling`. +Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof mode +until the proof is completed. In proof mode, the user primarily enters +tactics (see :ref:`writing-proofs`). The user may also enter +commands to manage the proof mode (see :ref:`proofhandling`). When the proof is complete, use the :cmd:`Qed` command so the kernel verifies -the proof and adds it to the environment. +the proof and adds it to the global environment. .. note:: #. Several statements can be simultaneously asserted provided the :flag:`Nested Proofs Allowed` flag was turned on. - #. Not only other assertions but any vernacular command can be given + #. Not only other assertions but any command can be given while in the process of proving a given assertion. In this case, the command is understood as if it would have been given before the statements still to be proved. Nonetheless, this practice is discouraged @@ -208,4 +211,4 @@ the proof and adds it to the environment. side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the - current asserted statement into an axiom and exit the proof editing mode. + current asserted statement into an axiom and exit proof mode. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 251b5e4955..4e892f709d 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,11 +31,12 @@ 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. - The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. + The :n:`@ident`\s are simultaneously added to the global environment before the types of constructors are checked. Each :n:`@ident` can be used independently thereafter. See :ref:`mutually_inductive_types`. @@ -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. @@ -84,7 +86,7 @@ A simple inductive type belongs to a universe that is a simple :n:`@sort`. The type nat is defined as the least :g:`Set` containing :g:`O` and closed by the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the - environment. + global environment. This definition generates four elimination principles: :g:`nat_rect`, :g:`nat_ind`, :g:`nat_rec` and :g:`nat_sind`. The type of :g:`nat_ind` is: @@ -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 @@ -410,7 +413,7 @@ constructions. It is especially useful when defining functions over mutually defined inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -633,7 +636,7 @@ contains an inductive definition. .. example:: - Provided that our environment :math:`E` contains inductive definitions we showed before, + Provided that our global environment :math:`E` contains inductive definitions we showed before, these two inference rules above enable us to conclude that: .. math:: @@ -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..93d70c773f 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.` @@ -282,7 +283,6 @@ are now available through the dot notation. Check A.B.U. .. cmd:: Export {+ @filtered_import } - :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. @@ -464,7 +464,7 @@ We also need additional typing judgments: + :math:`\WFT{E}{S}`, denoting that a structure :math:`S` is well-formed, + :math:`\WTM{E}{p}{S}`, denoting that the module pointed by :math:`p` has type :math:`S` in - environment :math:`E`. + the global environment :math:`E`. + :math:`\WEV{E}{S}{\ovl{S}}`, denoting that a structure :math:`S` is evaluated to a structure :math:`S` in weak head normal form. + :math:`\WS{E}{S_1}{S_2}` , denoting that a structure :math:`S_1` is a subtype of a @@ -964,7 +964,7 @@ names. A logical prefix Lib can be associated with a physical path using the command line option ``-Q`` `path` ``Lib``. All subfolders of path are -recursively associated to the logical path ``Lib`` extended with the +recursively associated with the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding to invalid Coq identifiers are skipped, and, by convention, @@ -972,7 +972,7 @@ subdirectories named ``CVS`` or ``_darcs`` are skipped too. Thanks to this mechanism, ``.vo`` files are made available through the logical name of the folder they are in, extended with their own -basename. For example, the name associated to the file +basename. For example, the name associated with the file ``path/fOO/Bar/File.vo`` is ``Lib.fOO.Bar.File``. The same caveat applies for invalid identifiers. When compiling a source file, the ``.vo`` file stores its logical name, so that an error is issued if it is loaded with the diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 7eedbcd59a..6671c67fb2 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -119,13 +119,11 @@ The following settings let you control the display format for types: You can override the display format for specified types by adding entries to these tables: .. table:: Printing Record @qualid - :name: Printing Record Specifies a set of qualids which are displayed as records. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. .. table:: Printing Constructor @qualid - :name: Printing Constructor Specifies a set of qualids which are displayed as constructors. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. @@ -208,7 +206,7 @@ other arguments are the parameters of the inductive type. This message is followed by an explanation of this impossibility. There may be three reasons: - #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). + #. The name :token:`ident` already exists in the global environment (see :cmd:`Axiom`). #. The body of :token:`ident` uses an incorrect elimination for :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). #. The type of the projections :token:`ident` depends on previous diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index df50dbafe3..c16152ff4f 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -3,57 +3,33 @@ Section mechanism ----------------- -Sections create local contexts which can be shared across multiple definitions. - -.. example:: - - Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. - - .. coqtop:: all - - Section s1. - - Inside a section, local parameters can be introduced using :cmd:`Variable`, - :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for - the first two). - - .. coqtop:: all - - Variables x y : nat. - - The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions - won't persist when the section is closed, and all persistent definitions which - depend on `y'` will be prefixed with `let y' := y in`. - - .. coqtop:: in - - Let y' := y. - Definition x' := S x. - Definition x'' := x' + y'. - - .. coqtop:: all - - Print x'. - Print x''. - - End s1. - - Print x'. - Print x''. - - Notice the difference between the value of :g:`x'` and :g:`x''` inside section - :g:`s1` and outside. +Sections are naming scopes that permit creating section-local declarations that can +be used by other declarations in the section. Declarations made +with :cmd:`Variable`, :cmd:`Hypothesis`, :cmd:`Context`, +:cmd:`Let`, :cmd:`Let Fixpoint` and +:cmd:`Let CoFixpoint` (or the plural variants of the first two) within sections +are local to the section. + +In proofs done within the section, section-local declarations +are included in the :term:`local context` of the initial goal of the proof. +They are also accessible in definitions made with the :cmd:`Definition` command. + +Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. +Sections can be nested. +When a section is closed, its local declarations are no longer available. +Global declarations that refer to them will be adjusted so they're still +usable outside the section as shown in this :ref:`example <section_local_declarations>`. .. cmd:: Section @ident - This command is used to open a section named :token:`ident`. + Opens the section named :token:`ident`. Section names do not need to be unique. .. cmd:: End @ident - This command closes the section or module named :token:`ident`. - See :ref:`Terminating an interactive module or module type definition<terminating_module>` + Closes the section or module named :token:`ident`. + See :ref:`Terminating an interactive module or module type definition <terminating_module>` for a description of its use with modules. After closing the @@ -69,7 +45,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 @@ -77,14 +54,14 @@ Sections create local contexts which can be shared across multiple definitions. Let CoFixpoint @cofix_definition {* with @cofix_definition } :name: Let; Let Fixpoint; Let CoFixpoint - These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that + These are similar to :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that the declared constant is local to the current section. When the section is closed, all persistent definitions and theorems within it that depend on the constant will be wrapped with a :n:`@term_let` with the same declaration. As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, - if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -102,3 +79,38 @@ Sections create local contexts which can be shared across multiple definitions. Context (b' := b). .. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. + +.. _section_local_declarations: + +.. example:: Section-local declarations + + .. coqtop:: all + + Section s1. + + .. coqtop:: all + + Variables x y : nat. + + The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions + won't persist when the section is closed, and all persistent definitions which + depend on `y'` will be prefixed with `let y' := y in`. + + .. coqtop:: in + + Let y' := y. + Definition x' := S x. + Definition x'' := x' + y'. + + .. coqtop:: all + + Print x'. + Print x''. + + End s1. + + Print x'. + Print x''. + + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index 2460461ede..214541570c 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -4,7 +4,6 @@ Setting properties of a function's arguments ++++++++++++++++++++++++++++++++++++++++++++ .. cmd:: Arguments @reference {* @arg_specs } {* , {* @implicits_alt } } {? : {+, @args_modifier } } - :name: Arguments .. insertprodn argument_spec args_modifier @@ -79,7 +78,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 +88,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..4cc35794cc 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -199,8 +199,8 @@ but also that the infix relation was bound to the ``nat_eq`` relation. This relation is selected whenever ``==`` is used on terms of type nat. This can be read in the line declaring the canonical structure ``nat_EQty``, where the first argument to ``Pack`` is the key and its second -argument a group of canonical values associated to the key. In this -case we associate to nat only one canonical value (since its class, +argument a group of canonical values associated with the key. In this +case we associate with nat only one canonical value (since its class, ``nat_EQcl`` has just one member). The use of the projection ``op`` requires its argument to be in the class ``EQ``, and uses such a member (function) to actually compare its arguments. @@ -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"). @@ -530,7 +530,7 @@ instances of the ``LEQ`` class. The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all the other pieces of the class ``LEQ`` and declares them as canonical -values associated to the ``T`` key. All in all, the only new piece of +values associated with the ``T`` key. All in all, the only new piece of information we add in the ``LEQ`` class is the mixin, all the rest is already canonical for ``T`` and hence can be inferred by Coq. diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index fd9695e270..7206fb8581 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -5,6 +5,9 @@ Existential variables --------------------- +:gdef:`Existential variables <existential variable>` represent as yet unknown +values. + .. insertprodn term_evar term_evar .. prodn:: diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index 23ba5f703a..765d04ec88 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -66,7 +66,7 @@ would be a solution of the inference problem. **Contextual Implicit Arguments** An implicit argument can be *contextual* or not. An implicit argument -is said *contextual* if it can be inferred only from the knowledge of +is said to be *contextual* if it can be inferred only from the knowledge of the type of the context of the current expression. For instance, the only argument of:: @@ -384,7 +384,7 @@ Displaying implicit arguments when pretty-printing .. flag:: Printing Implicit - By default, the basic pretty-printing rules hide the inferrable implicit + By default, the basic pretty-printing rules hide the inferable implicit arguments of an application. Turn this flag on to force printing all implicit arguments. @@ -506,7 +506,7 @@ or :g:`m` to the type :g:`nat` of natural numbers). .. flag:: Printing Use Implicit Types By default, the type of bound variables is not printed when - the variable name is associated to an implicit type which matches the + the variable name is associated with an implicit type which matches the actual type of the variable. This feature can be deactivated by turning this flag off. diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 8e62c2af13..1c022448b0 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -252,7 +252,6 @@ If an inductive type has just one constructor, pattern matching can be written using the first destructuring let syntax. .. table:: Printing Let @qualid - :name: Printing Let Specifies a set of qualids for which pattern matching is displayed using a let expression. Note that this only applies to pattern matching instances entered with :g:`match`. @@ -269,7 +268,6 @@ can be written using ``if`` … ``then`` … ``else`` …. This table controls which types are written this way: .. table:: Printing If @qualid - :name: Printing If Specifies a set of qualids for which pattern matching is displayed using ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` @@ -720,7 +718,7 @@ Recall that a list of patterns is also a pattern. So, when we destructure several terms at the same time and the branches have different types we need to provide the elimination predicate for this multiple pattern. It is done using the same scheme: each term may be -associated to an ``as`` clause and an ``in`` clause in order to introduce +associated with an ``as`` clause and an ``in`` clause in order to introduce a dependent product. For example, an equivalent definition for :g:`concat` (even though the diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index d20a82e6c0..a10312972e 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -43,7 +43,7 @@ Batch compilation (coqc) ------------------------ The ``coqc`` command takes a name *file* as argument. Then it looks for a -vernacular file named *file*.v, and tries to compile it into a +file named *file*.v, and tries to compile it into a *file*.vo file (See :ref:`compiled-files`). .. caution:: @@ -219,6 +219,71 @@ and ``coqtop``, unless stated otherwise: :-batch: Exit just after argument parsing. Available for ``coqtop`` only. :-verbose: Output the content of the input file as it is compiled. This option is available for ``coqc`` only. +:-native-compiler (yes|no|ondemand): Enable the :tacn:`native_compute` + reduction machine and precompilation to ``.cmxs`` files for future use + by :tacn:`native_compute`. + Setting ``yes`` enables :tacn:`native_compute`; it also causes Coq + to precompile the native code for future use; all dependencies need + to have been precompiled beforehand. Setting ``no`` disables + :tacn:`native_compute` which defaults back to :tacn:`vm_compute`; no files are precompiled. + Setting ``ondemand`` enables :tacn:`native_compute` + but disables precompilation; all missing dependencies will be recompiled + every time :tacn:`native_compute` is called. + + .. _native-compiler-options: + + .. versionchanged:: 8.13 + + The default value is set at configure time, + ``-config`` can be used to retrieve it. + All this can be summarized in the following table: + + .. list-table:: + :header-rows: 1 + + * - ``configure`` + - ``coqc`` + - ``native_compute`` + - outcome + - requirements + * - yes + - yes (default) + - native_compute + - ``.cmxs`` + - ``.cmxs`` of deps + * - yes + - no + - vm_compute + - none + - none + * - yes + - ondemand + - native_compute + - none + - none + * - no + - yes, no, ondemand + - vm_compute + - none + - none + * - ondemand + - yes + - native_compute + - ``.cmxs`` + - ``.cmxs`` of deps + * - ondemand + - no + - vm_compute + - none + - none + * - ondemand + - ondemand (default) + - native_compute + - none + - none + +:-native-output-dir: Set the directory in which to put the aforementioned + ``.cmxs`` for :tacn:`native_compute`. Defaults to ``.coq-native``. :-vos: Indicate Coq to skip the processing of opaque proofs (i.e., proofs ending with :cmd:`Qed` or :cmd:`Admitted`), output a ``.vos`` files instead of a ``.vo`` file, and to load ``.vos`` files instead of ``.vo`` files @@ -434,7 +499,7 @@ wrong. In the current version, it does not modify the compiled libraries to mark them as successfully checked. Note that non-logical information is not checked. By logical -information, we mean the type and optional body associated to names. +information, we mean the type and optional body associated with names. It excludes for instance anything related to the concrete syntax of objects (customized syntax rules, association between short and long names), implicit arguments, etc. diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index c239797cc2..dcc60195ed 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -7,7 +7,7 @@ Coq Integrated Development Environment The Coq Integrated Development Environment is a graphical tool, to be used as a user-friendly replacement to `coqtop`. Its main purpose is to -allow the user to navigate forward and backward into a Coq vernacular +allow the user to navigate forward and backward into a Coq file, executing corresponding commands or undoing them respectively. CoqIDE is run by typing the command `coqide` on the command line. @@ -100,10 +100,10 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -Vernacular commands, templates ------------------------------------ +Commands and templates +---------------------- -The Templates menu allows using shortcuts to insert vernacular +The Templates menu allows using shortcuts to insert commands. This is a nice way to proceed if you are not sure of the syntax of the command you want. @@ -116,7 +116,7 @@ Queries .. image:: ../_static/coqide-queries.png :alt: CoqIDE queries -We call *query* any vernacular command that does not change the current state, +We call *query* any command that does not change the current state, such as ``Check``, ``Search``, etc. To run such commands interactively, without writing them in scripts, CoqIDE offers a *query pane*. The query pane can be displayed on demand by using the ``View`` menu, or using the shortcut ``F1``. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 2fc3c9f748..013ff0a83f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -284,6 +284,8 @@ A sequence is an expression of the following form: .. tacn:: @ltac_expr3__1 ; {| @ltac_expr3__2 | @binder_tactic } :name: ltac-seq + .. todo: can't use "… ; …" as the name because of the semicolon + The expression :n:`@ltac_expr3__1` is evaluated to :n:`v__1`, which must be a tactic value. The tactic :n:`v__1` is applied to the current goals, possibly producing more goals. Then the right-hand side is evaluated to @@ -481,7 +483,6 @@ Do loop ~~~~~~~ .. tacn:: do @nat_or_var @ltac_expr3 - :name: do The do loop repeats a tactic :token:`nat_or_var` times: @@ -497,7 +498,6 @@ Repeat loop ~~~~~~~~~~~ .. tacn:: repeat @ltac_expr3 - :name: repeat The repeat loop repeats a tactic until it fails. @@ -515,7 +515,6 @@ Catching errors: try We can catch the tactic errors with: .. tacn:: try @ltac_expr3 - :name: try :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused goal independently. If the application of @@ -531,7 +530,6 @@ Detecting progress We can check if a tactic made progress with: .. tacn:: progress @ltac_expr3 - :name: progress :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused subgoal independently. If the application of ``v`` @@ -641,7 +639,6 @@ First tactic to succeed In some cases backtracking may be too expensive. .. tacn:: first [ {*| @ltac_expr } ] - :name: first For each focused goal, independently apply the first :token:`ltac_expr` that succeeds. The :n:`@ltac_expr`\s must evaluate to tactic values. @@ -701,7 +698,6 @@ Selects and applies the first tactic that solves each goal (i.e. leaves no subgo in a series of alternative tactics: .. tacn:: solve [ {*| @ltac_expr__i } ] - :name: solve For each current subgoal: evaluates and applies each :n:`@ltac_expr` in order until one is found that solves the subgoal. @@ -743,7 +739,6 @@ Conditional branching: tryif ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: tryif @ltac_expr__test then @ltac_expr__then else @ltac_expr2__else - :name: tryif For each focused goal, independently: Evaluate and apply :n:`@ltac_expr__test`. If :n:`@ltac_expr__test` succeeds at least once, evaluate and apply :n:`@ltac_expr__then` @@ -772,7 +767,6 @@ Another way of restricting backtracking is to restrict a tactic to a single success: .. tacn:: once @ltac_expr3 - :name: once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied but only its first success is used. If ``v`` fails, @@ -788,7 +782,6 @@ Coq provides an experimental way to check that a tactic has *exactly one* success: .. tacn:: exactly_once @ltac_expr3 - :name: exactly_once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied if it has at most one success. If ``v`` fails, @@ -816,7 +809,6 @@ Checking for failure: assert_fails Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic *fails*: .. tacn:: assert_fails @ltac_expr3 - :name: assert_fails If :n:`@ltac_expr3` fails, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` unexpectedly has at least one success, the tactic performs @@ -863,7 +855,6 @@ Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic has *at le success: .. tacn:: assert_succeeds @ltac_expr3 - :name: assert_succeeds If :n:`@ltac_expr3` has at least one success, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` fails, the tactic performs @@ -877,7 +868,6 @@ Print/identity tactic: idtac .. tacn:: idtac {* {| @ident | @string | @natural } } - :name: idtac Leaves the proof unchanged and prints the given tokens. :token:`String<string>`\s and :token:`natural`\s are printed @@ -889,7 +879,7 @@ Print/identity tactic: idtac Failing ~~~~~~~ -.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @natural } } +.. tacn:: {| fail | gfail } {? @nat_or_var } {* {| @ident | @string | @natural } } :name: fail; gfail :tacn:`fail` is the always-failing tactic: it does not solve any @@ -910,7 +900,7 @@ Failing tactic into the goals, meaning that if there are no goals when it is evaluated, a tactic call like :tacn:`let` :n:`x := H in` :tacn:`fail` `0 x` will succeed. - :n:`@int_or_var` + :n:`@nat_or_var` The failure level. If no level is specified, it defaults to 0. The level is used by :tacn:`try`, :tacn:`repeat`, :tacn:`match goal` and the branching tacticals. If 0, it makes :tacn:`match goal` consider the next clause @@ -974,7 +964,6 @@ We can force a tactic to stop if it has not finished after a certain amount of time: .. 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:`@nat_or_var` seconds @@ -998,7 +987,6 @@ Timing a tactic A tactic execution can be timed: .. tacn:: time {? @string } @ltac_expr3 - :name: time evaluates :n:`@ltac_expr3` and displays the running time of the tactic expression, whether it fails or succeeds. In case of several successes, the time for each successive @@ -1015,7 +1003,6 @@ Tactic expressions that produce terms can be timed with the experimental tactic .. tacn:: time_constr @ltac_expr - :name: time_constr which evaluates :n:`@ltac_expr ()` and displays the time the tactic expression evaluated, assuming successful evaluation. Time is in seconds and is @@ -1026,12 +1013,10 @@ tactic implemented using the following internal tactics: .. tacn:: restart_timer {? @string } - :name: restart_timer Reset a timer .. tacn:: finish_timing {? ( @string ) } {? @string } - :name: finish_timing Display an optionally named timer. The parenthesized string argument is also optional, and determines the label associated with the timer @@ -1362,7 +1347,7 @@ Pattern matching on goals and hypotheses: match goal :tacn:`lazymatch goal`, :tacn:`match goal` and :tacn:`multimatch goal` are :token:`l1_tactic`\s. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@match_key @ltac_expr` construct (see :tacn:`match`). Each current goal is processed independently. @@ -1533,7 +1518,7 @@ expression returns an identifier: .. todo you can't have a :tacn: with the same name as a :gdef: for now, eg `fresh` can't be both - Returns a fresh identifier name (i.e. one that is not already used in the context + Returns a fresh identifier name (i.e. one that is not already used in the local context and not previously returned by :tacn:`fresh` in the current :token:`ltac_expr`). The fresh identifier is formed by concatenating the final :token:`ident` of each :token:`qualid` (dropping any qualified components) and each specified :token:`string`. @@ -1541,11 +1526,11 @@ expression returns an identifier: If no arguments are given, the name is a fresh derivative of the name ``H``. .. note:: We recommend generating the fresh identifier immediately before - adding it in the proof context. Using :tacn:`fresh` in a local function + adding it to the local context. Using :tacn:`fresh` in a local function may not work as you expect: - Successive :tacn:`fresh`\es give distinct names even if the names haven't - yet been added to the proof context: + Successive calls to :tacn:`fresh` give distinct names even if the names haven't + yet been added to the local context: .. coqtop:: reset none @@ -1635,11 +1620,11 @@ 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 ::= = | < | <= @@ -1733,7 +1718,6 @@ Defining |Ltac| symbols .. index:: ::= .. cmd:: Ltac @tacdef_body {* with @tacdef_body } - :name: Ltac .. insertprodn tacdef_body tacdef_body @@ -1761,7 +1745,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. @@ -2247,7 +2231,6 @@ Tracing execution not printed. .. opt:: Info Level @natural - :name: Info Level This option is an alternative to the :cmd:`Info` command. @@ -2268,17 +2251,17 @@ The debugger stops, prompting for a command which can be one of the following: +-----------------+-----------------------------------------------+ -| simple newline: | go to the next step | +| newline | go to the next step | +-----------------+-----------------------------------------------+ -| h: | get help | +| h | get help | +-----------------+-----------------------------------------------+ -| x: | exit current evaluation | +| r n | advance n steps further | +-----------------+-----------------------------------------------+ -| s: | continue current evaluation without stopping | +| r string | advance up to the next call to “idtac string” | +-----------------+-----------------------------------------------+ -| r n: | advance n steps further | +| s | continue current evaluation without stopping | +-----------------+-----------------------------------------------+ -| r string: | advance up to the next call to “idtac string” | +| x | exit current evaluation | +-----------------+-----------------------------------------------+ .. exn:: Debug mode not available in the IDE @@ -2365,25 +2348,21 @@ performance issue. Unset Ltac Profiling. .. tacn:: start ltac profiling - :name: start ltac profiling This tactic behaves like :tacn:`idtac` but enables the profiler. .. tacn:: stop ltac profiling - :name: stop ltac profiling Similarly to :tacn:`start ltac profiling`, this tactic behaves like :tacn:`idtac`. Together, they allow you to exclude parts of a proof script from profiling. .. tacn:: reset ltac profile - :name: reset ltac profile Equivalent to the :cmd:`Reset Ltac Profile` command, which allows resetting the profile from tactic scripts for benchmarking purposes. .. tacn:: show ltac profile {? {| cutoff @integer | @string } } - :name: show ltac profile Equivalent to the :cmd:`Show Ltac Profile` command, which allows displaying the profile from tactic scripts for @@ -2409,11 +2388,10 @@ Run-time optimization tactic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: optimize_heap - :name: optimize_heap This tactic behaves like :tacn:`idtac`, except that running it compacts the - heap in the OCaml run-time system. It is analogous to the Vernacular - command :cmd:`Optimize Heap`. + heap in the OCaml run-time system. It is analogous to the + :cmd:`Optimize Heap` command. .. tacn:: infoH @ltac_expr3 diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index a46f4fb894..1bb4216e4f 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -173,7 +173,6 @@ Type declarations One can define new types with the following commands. .. cmd:: Ltac2 Type {? rec } @tac2typ_def {* with @tac2typ_def } - :name: Ltac2 Type .. insertprodn tac2typ_def tac2rec_field @@ -301,7 +300,6 @@ Ltac2 Definitions ~~~~~~~~~~~~~~~~~ .. cmd:: Ltac2 {? mutable } {? rec } @tac2def_body {* with @tac2def_body } - :name: Ltac2 .. insertprodn tac2def_body tac2def_body @@ -322,7 +320,6 @@ Ltac2 Definitions If ``mutable`` is set, the definition can be redefined at a later stage (see below). .. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr - :name: Ltac2 Set This command redefines a previous ``mutable`` definition. Mutable definitions act like dynamic binding, i.e. at runtime, the last defined @@ -557,7 +554,7 @@ Built-in quotations ltac2_quotations ::= ident : ( @lident ) | constr : ( @term ) | open_constr : ( @term ) - | pattern : ( @cpattern ) + | pat : ( @cpattern ) | reference : ( {| & @ident | @qualid } ) | ltac1 : ( @ltac1_expr_in_env ) | ltac1val : ( @ltac1_expr_in_env ) @@ -571,7 +568,7 @@ The current implementation recognizes the following built-in quotations: (type ``Init.constr``). - ``open_constr``, which parses Coq terms and produces a term potentially with holes at runtime (type ``Init.constr`` as well). -- ``pattern``, which parses Coq patterns and produces a pattern used for term +- ``pat``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). - ``reference`` Qualified names are globalized at internalization into the corresponding global reference, @@ -598,7 +595,7 @@ modes, the *strict* and the *non-strict* mode. hypotheses. If this doesn't hold, internalization will fail. To work around this error, one has to specifically use the ``&`` notation. - In non-strict mode, any simple identifier appearing in a term quotation which - is not bound in the global context is turned into a dynamic reference to a + is not bound in the global environment is turned into a dynamic reference to a hypothesis. That is to say, internalization will succeed, but the evaluation of the term at runtime will fail if there is no such variable in the dynamic context. @@ -982,7 +979,7 @@ Match over goals gmatch_hyp_pattern ::= @name : @ltac2_match_pattern Matches over goals, similar to Ltac1 :tacn:`match goal`. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@ltac2_match_key @ltac2_expr` construct (see :tacn:`match!`). Each current goal is processed independently. @@ -1164,7 +1161,6 @@ Notations --------- .. cmd:: Ltac2 Notation {+ @ltac2_scope } {? : @natural } := @ltac2_expr - :name: Ltac2 Notation .. todo seems like name maybe should use lident rather than ident, considering: @@ -1475,7 +1471,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` @@ -1487,7 +1483,7 @@ Other nonterminals that have syntactic classes are listed here. * - :n:`conversion` - :token:`ltac2_conversion` - - :token:`conversion` + - * - :n:`rewriting` - :token:`ltac2_oriented_rewriter` @@ -1679,7 +1675,6 @@ Evaluation Ltac2 features a toplevel loop that can be used to evaluate expressions. .. cmd:: Ltac2 Eval @ltac2_expr - :name: Ltac2 Eval This command evaluates the term in the current proof if there is one, or in the global environment otherwise, and displays the resulting value to the user @@ -1877,9 +1872,9 @@ In Ltac expressions .. exn:: Unbound {| value | constructor } X - * if `X` is meant to be a term from the current stactic environment, replace + * if `X` is meant to be a term from the current static environment, replace the problematic use by `'X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. In quotations @@ -1889,7 +1884,7 @@ In quotations * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, replace the problematic use by `$X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. Exception catching diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 07c2d268c6..bab9d35099 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -116,8 +116,8 @@ compatible with the rest of Coq, up to a few discrepancies: + New keywords (``is``) might clash with variable, constant, tactic or - tactical names, or with quasi-keywords in tactic or vernacular - notations. + tactical names, or with quasi-keywords in tactic or + notation commands. + New tactic(al)s names (:tacn:`last`, :tacn:`done`, :tacn:`have`, :tacn:`suffices`, :tacn:`suff`, :tacn:`without loss`, :tacn:`wlog`, :tacn:`congr`, :tacn:`unlock`) might clash with user tactic names. @@ -799,8 +799,9 @@ An *occurrence switch* can be: set x := {+1 3}(f 2). Notice that some occurrences of a given term may be - hidden to the user, for example because of a notation. The vernacular - ``Set Printing All`` command displays all these hidden occurrences and + hidden to the user, for example because of a notation. Setting the + :flag:`Printing All` flag causes these hidden occurrences to + be shown when the term is displayed. This setting should be used to find the correct coding of the occurrences to be selected [#1]_. @@ -1023,7 +1024,7 @@ conversely in between deductive steps. In |SSR| these moves are performed by two *tacticals* ``=>`` and ``:``, so that the bookkeeping required by a deductive step can be -directly associated to that step, and that tactics in an |SSR| +directly associated with that step, and that tactics in an |SSR| script correspond to actual logical steps in the proof rather than merely shuffle facts. Still, some isolated bookkeeping is unavoidable, such as naming variables and assumptions at the beginning of a @@ -1189,7 +1190,7 @@ The move tactic. ```````````````` .. tacn:: move - :name: move + :name: move (ssreflect) This tactic, in its defective form, behaves like the :tacn:`hnf` tactic. @@ -5502,7 +5503,7 @@ equivalences are indeed taken into account, otherwise only single string that contains symbols or is followed by a scope key, is interpreted as the constant whose notation involves that string (e.g., :g:`+` for :g:`addn`), if this is unambiguous; otherwise the diagnostic - includes the output of the :cmd:`Locate` vernacular command. + includes the output of the :cmd:`Locate` command. + whose statement, including assumptions and types, contains a subterm matching the next patterns. If a pattern is prefixed by ``-``, the test is reversed; diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 4f01559cad..766f7ab44e 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3,35 +3,46 @@ Tactics ======== -A deduction rule is a link between some (unique) formula, that we call -the *conclusion* and (several) formulas that we call the *premises*. A -deduction rule can be read in two ways. The first one says: “if I know -this and this then I can deduce this”. For instance, if I have a proof -of A and a proof of B then I have a proof of A ∧ B. This is forward -reasoning from premises to conclusion. The other way says: “to prove -this I have to prove this and this”. For instance, to prove A ∧ B, I -have to prove A and I have to prove B. This is backward reasoning from -conclusion to premises. We say that the conclusion is the *goal* to -prove and premises are the *subgoals*. The tactics implement *backward -reasoning*. When applied to a goal, a tactic replaces this goal with -the subgoals it generates. We say that a tactic reduces a goal to its -subgoal(s). - -Each (sub)goal is denoted with a number. The current goal is numbered -1. By default, a tactic is applied to the current goal, but one can -address a particular goal in the list by writing n:tactic which means -“apply tactic tactic to goal number n”. We can show the list of -subgoals by typing Show (see Section :ref:`requestinginformation`). - -Since not every rule applies to a given statement, not every tactic can -be used to reduce a given goal. In other words, before applying a tactic -to a given goal, the system checks that some *preconditions* are -satisfied. If it is not the case, the tactic raises an error message. - -Tactics are built from atomic tactics and tactic expressions (which -extends the folklore notion of tactical) to combine those atomic -tactics. This chapter is devoted to atomic tactics. The tactic -language will be described in Chapter :ref:`ltac`. +Tactics specify how to transform the :term:`proof state` of an +incomplete proof to eventually generate a complete proof. + +Proofs can be developed in two basic ways: In :gdef:`forward reasoning`, +the proof begins by proving simple statements that are then combined to prove the +theorem statement as the last step of the proof. With forward reasoning, +for example, +the proof of `A /\\ B` would begin with proofs of `A` and `B`, which are +then used to prove `A /\\ B`. Forward reasoning is probably the most common +approach in human-generated proofs. + +In :gdef:`backward reasoning`, the proof begins with the theorem statement +as the goal, which is then gradually transformed until every subgoal generated +along the way has been proven. In this case, the proof of `A /\\ B` begins +with that formula as the goal. This can be transformed into two subgoals, +`A` and `B`, followed by the proofs of `A` and `B`. Coq and its tactics +use backward reasoning. + +A tactic may fully prove a goal, in which case the goal is removed +from the proof state. +More commonly, a tactic replaces a goal with one or more :term:`subgoals <subgoal>`. +(We say that a tactic reduces a goal to its subgoals.) + +Most tactics require specific elements or preconditions to reduce a goal; +they display error messages if they can't be applied to the goal. +A few tactics, such as :tacn:`auto`, don't fail even if the proof state +is unchanged. + +Goals are identified by number. The current goal is number +1. Tactics are applied to the current goal by default. (The +default can be changed with the :opt:`Default Goal Selector` +option.) They can +be applied to another goal or to multiple goals with a +:ref:`goal selector <goal-selectors>` such as :n:`2: @tactic`. + +This chapter describes many of the most common built-in tactics. +Built-in tactics can be combined to form tactic expressions, which are +described in the :ref:`Ltac` chapter. Since tactic expressions can +be used anywhere that a built-in tactic can be used, "tactic" may +refer to both built-in tactics and tactic expressions. Common elements of tactics -------------------------- @@ -264,17 +275,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 +466,95 @@ 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 select a specific hypothesis H to apply to other hypotheses, + such as :tacn:`rewrite` `H in * |-`, won't apply H to itself. + + If multiple + occurrences are given, such as in :tacn:`rewrite` `H at 1 2 3`, the tactic + must match at least one occurrence in order to succeed. The tactic will fail + if no occurrences match. Occurrence numbers that are out of range (e.g. + `at 1 3` when there are only 2 occurrences in the hypothesis or conclusion) + are ignored. + + .. todo: remove last sentence above and add "Invalid occurrence number @natural" exn for 8.14 + per #13568. + + Tactics that use occurrence clauses include :tacn:`set`, + :tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. .. seealso:: @@ -1611,17 +1654,21 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. .. tacv:: instantiate (@natural := @term) - This variant allows to refer to an existential variable which was not named - by the user. The :n:`@natural` argument is the position of the existential variable - from right to left in the goal. Because this variant is not robust to slight - changes in the goal, its use is strongly discouraged. + This variant selects an existential variable by its position. The + :n:`@natural` argument is the position of the existential variable + *from right to left* in the conclusion of the goal. (Use one of + the variants below to select an existential variable in a + hypothesis.) Counting starts at 1 and multiple occurrences of the + same existential variable are counted multiple times. Because this + variant is not robust to slight changes in the goal, its use is + strongly discouraged. .. tacv:: instantiate ( @natural := @term ) in @ident instantiate ( @natural := @term ) in ( value of @ident ) instantiate ( @natural := @term ) in ( type of @ident ) These allow to refer respectively to existential variables occurring in a - hypothesis or in the body or the type of a local definition. + hypothesis or in the body or the type of a local definition (named :n:`@ident`). .. tacv:: instantiate @@ -1960,7 +2007,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This is a more basic induction tactic. Again, the type of the argument :n:`@term` must be an inductive type. Then, according to the type of the goal, the tactic ``elim`` chooses the appropriate destructor and applies it - as the tactic :tacn:`apply` would do. For instance, if the proof context + as the tactic :tacn:`apply` would do. For instance, if the local context contains :g:`n:nat` and the current goal is :g:`T` of type :g:`Prop`, then :n:`elim n` is equivalent to :n:`apply nat_ind with (n:=n)`. The tactic ``elim`` does not modify the context of the goal, neither introduces the @@ -2632,7 +2679,7 @@ and an explanation of the underlying technique. Like in a fix expression, the induction hypotheses have to be used on structurally smaller arguments. The verification that inductive proof arguments are correct is done only at the time of registering the - lemma in the environment. To know if the use of induction hypotheses + lemma in the global environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2652,7 +2699,7 @@ and an explanation of the underlying technique. name given to the coinduction hypothesis. Like in a cofix expression, the use of induction hypotheses have to guarded by a constructor. The verification that the use of co-inductive hypotheses is correct is - done only at the time of registering the lemma in the environment. To + done only at the time of registering the lemma in the global environment. To know if the use of coinduction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2733,14 +2780,11 @@ succeeds, and results in an error otherwise. :name: is_var This tactic checks whether its argument is a variable or hypothesis in - the current goal context or in the opened sections. + the current local context. .. exn:: Not a variable or hypothesis. :undocumented: - -.. _equality: - Equality -------- @@ -2935,59 +2979,7 @@ references to automatically generated names. Performance-oriented tactic variants ------------------------------------ -.. tacn:: change_no_check @term - :name: change_no_check - - For advanced usage. Similar to :tacn:`change` :n:`@term`, but as an optimization, - it skips checking that :n:`@term` is convertible to the goal. - - Recall that the Coq kernel typechecks proofs again when they are concluded to - ensure safety. Hence, using :tacn:`change` checks convertibility twice - overall, while :tacn:`change_no_check` can produce ill-typed terms, - but checks convertibility only once. - Hence, :tacn:`change_no_check` can be useful to speed up certain proof - scripts, especially if one knows by construction that the argument is - indeed convertible to the goal. - - In the following example, :tacn:`change_no_check` replaces :g:`False` by - :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - - .. example:: - - .. coqtop:: all abort - - Goal False. - change_no_check True. - exact I. - Fail Qed. - - :tacn:`change_no_check` supports all of :tacn:`change`'s variants. - - .. tacv:: change_no_check @term with @term’ - :undocumented: - - .. tacv:: change_no_check @term at {+ @natural} with @term’ - :undocumented: - - .. tacv:: change_no_check @term {? {? at {+ @natural}} with @term} in @ident - - .. example:: - - .. coqtop:: all abort - - Goal True -> False. - intro H. - change_no_check False in H. - exact H. - Fail Qed. - - .. tacv:: convert_concl_no_check @term - :name: convert_concl_no_check - - .. deprecated:: 8.11 - - Deprecated old name for :tacn:`change_no_check`. Does not support any of its - variants. +.. todo: move the following adjacent to the `exact` tactic in the rewriting chapter? .. tacn:: exact_no_check @term :name: exact_no_check diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 86d1d25745..8e2f577f6b 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1,7 +1,7 @@ .. _vernacularcommands: -Vernacular commands -============================= +Commands +======== .. _displaying: @@ -60,7 +60,7 @@ Query commands -------------- Unlike other commands, :production:`query_command`\s may be prefixed with -a goal selector (:n:`@natural:`) to specify which goal context it applies to. +a goal selector (:n:`@natural:`) to specify which goals it applies to. If no selector is provided, the command applies to the current goal. If no proof is open, then the command only applies to accessible objects. (see Section :ref:`invocation-of-tactics`). @@ -382,7 +382,6 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). SearchRewrite (_ + _ + _). .. table:: Search Blacklist @string - :name: Search Blacklist Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose @@ -668,8 +667,8 @@ Loadpath ------------ Loadpaths are preferably managed using Coq command line options (see -Section :ref:`libraries-and-filesystem`) but there remain vernacular commands to manage them -for practical purposes. Such commands are only meant to be issued in +Section :ref:`libraries-and-filesystem`), but there are also commands +to manage them within Coq. These commands are only meant to be issued in the toplevel, and using them in source files is discouraged. @@ -740,7 +739,7 @@ Backtracking ------------ The backtracking commands described in this section can only be used -interactively, they cannot be part of a vernacular file loaded via +interactively, they cannot be part of a Coq file loaded via ``Load`` or compiled by ``coqc``. @@ -844,7 +843,6 @@ Quitting and debugging displayed. .. opt:: Default Timeout @natural - :name: Default Timeout If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@natural`, except for :cmd:`Timeout` commands themselves. If unset, @@ -883,7 +881,6 @@ Controlling display This flag controls the normal displaying. .. opt:: Warnings "{+, {? {| - | + } } @ident }" - :name: Warnings This option configures the display of warnings. It is experimental, and expects, between quotes, a comma-separated list of warning names or @@ -894,14 +891,12 @@ Controlling display right have higher priority, meaning that `A,-A` is equivalent to `-A`. .. opt:: Printing Width @natural - :name: Printing Width This command sets which left-aligned part of the width of the screen is used for display. At the time of writing this documentation, the default value is 78. .. opt:: Printing Depth @natural - :name: Printing Depth This option controls the nesting depth of the formatter used for pretty- printing. Beyond this depth, display of subterms is replaced by dots. At the @@ -1136,7 +1131,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 +1147,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 +1160,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 +1174,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..d7228a3907 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. +maps head symbols to a list of hints. Use the :cmd:`Print Hint` command to view +the database. -.. cmd:: Print Hint @ident - - 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 -``````````````````````` +----------------------- + +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. -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. +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. -.. cmd:: Create HintDb @ident {? discriminated} +.. cmd:: Create HintDb @ident {? discriminated } - This command creates a new database named :n:`@ident`. The database is + 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: - The general command to add a hint to some databases :n:`{+ @ident}`. +Creating Hints +-------------- - 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. + The various `Hint` commands share these elements: + + :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. + specifying an explicit locality will trigger a deprecation + warning. We recommend you use :attr:`export` whenever possible. - .. cmdv:: Hint @hint_definition + The `Hint` commands are: - No database name is given: the hint is registered in the ``core`` database. + .. cmd:: Hint Resolve {+ {| @qualid | @one_term } } {? @hint_info } {? : {+ @ident } } + Hint Resolve {| -> | <- } {+ @qualid } {? @natural } {? : {+ @ident } } + :name: Hint Resolve; _ - .. deprecated:: 8.10 + .. insertprodn hint_info one_pattern - .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident - :name: Hint Resolve - - 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 with 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: - - .. cmdv:: Hint Immediate {+ @qualid} : @ident + .. cmd:: Hint Constructors {+ @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. - - .. cmdv:: Hint Unfold @qualid : @ident - :name: Hint Unfold + .. cmd:: Hint Unfold {+ @qualid } {? : {+ @ident } } - 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/index.rst b/doc/sphinx/proofs/writing-proofs/index.rst index 7724d7433c..63ddbd0a3a 100644 --- a/doc/sphinx/proofs/writing-proofs/index.rst +++ b/doc/sphinx/proofs/writing-proofs/index.rst @@ -10,19 +10,16 @@ the user and the assistant. The building blocks for this dialog are tactics which the user will use to represent steps in the proof of a theorem. -Incomplete proofs have one or more open (unproven) sub-goals. Each -goal has its own context (a set of assumptions that can be used to -prove the goal). Tactics can transform goals and contexts. -Internally, the incomplete proof is represented as a partial proof -term, with holes for the unproven sub-goals. +The first section presents the proof mode (the core mechanism of the +dialog between the user and the proof assistant). Then, several +sections describe the available tactics. One section covers the +SSReflect proof language, which provides a consistent alternative set +of tactics to the standard basic tactics. The last section documents +the ``Scheme`` family of commands, which can be used to extend the +power of the :tacn:`induction` and :tacn:`inversion` tactics. -When a proof is complete, the user leaves the proof mode and defers -the verification of the resulting proof term to the :ref:`kernel -<core-language>`. - -This chapter is divided in several parts, describing the basic ideas -of the proof mode (during which tactics can be used), and several -flavors of tactics, including the SSReflect proof language. +Additional tactics are documented in the next chapter +:ref:`automatic-tactics`. .. toctree:: :maxdepth: 1 diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst index 40d032543f..931ac905f6 100644 --- a/doc/sphinx/proofs/writing-proofs/proof-mode.rst +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -1,74 +1,175 @@ .. _proofhandling: -------------------- - Proof handling -------------------- +---------- +Proof mode +---------- -In Coq’s proof editing mode all top-level commands documented in -Chapter :ref:`vernacularcommands` remain available and the user has access to specialized -commands dealing with proof development pragmas documented in this -section. They can also use some other specialized commands called -*tactics*. They are the very tools allowing the user to deal with -logical reasoning. They are documented in Chapter :ref:`tactics`. +:gdef:`Proof mode <proof mode>` is used to prove theorems. +Coq enters proof mode when you begin a proof, +such as with the :cmd:`Theorem` command. It exits proof mode when +you complete a proof, such as with the :cmd:`Qed` command. Tactics, +which are available only in proof mode, incrementally transform incomplete +proofs to eventually generate a complete proof. -Coq user interfaces usually have a way of marking whether the user has -switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into -:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. +When you run Coq interactively, such as through CoqIDE, Proof General or +coqtop, Coq shows the current proof state (the incomplete proof) as you +enter tactics. This information isn't shown when you run Coq in batch +mode with `coqc`. -At each stage of a proof development, one has a list of goals to -prove. Initially, the list consists only in the theorem itself. After -having applied some tactics, the list of goals contains the subgoals -generated by the tactics. +Proof State +----------- -To each subgoal is associated a number of hypotheses called the *local context* -of the goal. Initially, the local context contains the local variables and -hypotheses of the current section (see Section :ref:`gallina-assumptions`) and -the local variables and hypotheses of the theorem statement. It is enriched by -the use of certain tactics (see e.g. :tacn:`intro`). +The :gdef:`proof state` consists of one or more unproven goals. +Each goal has a :gdef:`conclusion` (the statement that is to be proven) +and a :gdef:`local context`, which contains named :term:`hypotheses <hypothesis>` +(which are propositions), variables and local definitions that can be used in +proving the conclusion. The proof may also use *constants* from the :term:`global environment` +such as definitions and proven theorems. -When a proof is completed, the message ``Proof completed`` is displayed. -One can then register this proof as a defined constant in the -environment. Because there exists a correspondence between proofs and -terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,H89`, Coq stores proofs as terms of |Cic|. Those -terms are called *proof terms*. +The term ":gdef:`goal`" may refer to an entire goal or to the conclusion +of a goal, depending on the context. +The conclusion appears below a line and the local context appears above the line. +The conclusion is a type. Each item in the local context begins with a name +and ends, after a colon, with an associated type. +Local definitions are shown in the form `n := 0 : nat`, for example, in which `nat` is the +type of `0`. -.. exn:: No focused proof. +The local context of a goal contains items specific to the goal as well +as section-local variables and hypotheses (see :ref:`gallina-assumptions`) defined +in the current :ref:`section <section-mechanism>`. The latter are included in the +initial proof state. +Items in the local context are ordered; an item can only refer to items that appear +before it. (A more mathematical description of the *local context* is +:ref:`here <Local-context>`.) - Coq raises this error message when one attempts to use a proof editing command - out of the proof editing mode. +The :gdef:`global environment` has definitions and proven theorems that are global in scope. +(A more mathematical description of the *global environment* is :ref:`here <Global-environment>`.) + +When you begin proving a theorem, the proof state shows +the statement of the theorem below the line and often nothing in the +local context: + +.. coqtop:: none + + Parameter P: nat -> Prop. + +.. coqtop:: out + + Goal forall n m: nat, n > m -> P 1 /\ P 2. + +After applying the :tacn:`intros` :term:`tactic`, we see hypotheses above the line. +The names of variables (`n` and `m`) and hypotheses (`H`) appear before a colon, followed by +the type they represent. + +.. coqtop:: all + + intros. + +Some tactics, such as :tacn:`split`, create new goals, which may +be referred to as :gdef:`subgoals <subgoal>` for clarity. +Goals are numbered from 1 to N at each step of the proof to permit applying a +tactic to specific goals. The local context is only shown for the first goal. + +.. coqtop:: all + + split. + +"Variables" may refer specifically to local context items for which the type of their type +is `Set` or `Type`, and :gdef:`"hypotheses" <hypothesis>` refers to items that are +:term:`propositions <proposition>`, +for which the type of their type is `Prop` or `SProp`, +but these terms are also used interchangeably. + +.. coqtop:: out + + let t_n := type of n in idtac "type of n :" t_n; + let tt_n := type of t_n in idtac "type of" t_n ":" tt_n. + let t_H := type of H in idtac "type of H :" t_H; + let tt_H := type of t_H in idtac "type of" t_H ":" tt_H. + +A proof script, consisting of the tactics that are applied to prove a +theorem, is often informally referred to as a "proof". +The real proof, whether complete or incomplete, is a term, the :gdef:`proof term`, +which users may occasionally want to examine. (This is based on the +*Curry-Howard isomorphism* :cite:`How80,Bar81,Gir89,H89`, which is +a correspondence between between proofs and terms and between +propositions and types of λ-calculus. The isomorphism is also +sometimes called the "propositions-as-types correspondence".) + +The :cmd:`Show Proof` command displays the incomplete proof term +before you've completed the proof. For example, here's the proof +term after using the :tacn:`split` tactic above: + +.. coqtop:: all + + Show Proof. + +The incomplete parts, the goals, are represented by +:term:`existential variables <existential variable>` +with names that begin with `?Goal`. The :cmd:`Show Existentials` command +shows each existential with the hypotheses and conclusion for the associated goal. + +.. coqtop:: all + + Show Existentials. + +Coq's kernel verifies the correctness of proof terms when it exits +proof mode by checking that the proof term is :term:`well-typed` and +that its type is the same as the theorem statement. + +After a proof is completed, :cmd:`Print` `<theorem_name>` +shows the proof term and its type. The type appears after +the colon (`forall ...`), as for this theorem from Coq's standard library: + +.. coqtop:: all + + Print proj1. .. _proof-editing-mode: -Entering and leaving proof editing mode ---------------------------------------- +Entering and exiting proof mode +------------------------------- + +Coq enters :term:`proof mode` when you begin a proof through +commands such as :cmd:`Theorem` or :cmd:`Goal`. Coq user interfaces +usually have a way to indicate that you're in proof mode. + +:term:`Tactics <tactic>` are available only in proof mode (currently they give syntax +errors outside of proof mode). Most :term:`commands <command>` can be used both in and out of +proof mode, but some commands only work in or outside of proof mode. -The proof editing mode is entered by asserting a statement, which typically is -the assertion of a theorem using an assertion command like :cmd:`Theorem`. The -list of assertion commands is given in :ref:`Assertions`. The command -:cmd:`Goal` can also be used. +When the proof is completed, you can exit proof mode with commands such as +:cmd:`Qed`, :cmd:`Defined` and :cmd:`Save`. .. cmd:: Goal @type - This is intended for quick assertion of statements, without knowing in - advance which name to give to the assertion, typically for quick - testing of the provability of a statement. If the proof of the - statement is eventually completed and validated, the statement is then - bound to the name ``Unnamed_thm`` (or a variant of this name not already - used for another statement). + Asserts an unnamed proposition. This is intended for quick tests that + a proposition is provable. If the proof is eventually completed and + validated, you can assign a name with the :cmd:`Save` or :cmd:`Defined` + commands. If no name is given, the name will be `Unnamed_thm` (or, + if that name is already defined, a variant of that). .. cmd:: Qed - This command is available in interactive editing proof mode when the - proof is completed. Then :cmd:`Qed` extracts a proof term from the proof - script, switches back to Coq top-level and attaches the extracted - proof term to the declared name of the original goal. The name is - added to the environment as an opaque constant. + Passes a completed :term:`proof term` to Coq's kernel + to check that the proof term is :term:`well-typed` and + to verify that its type matches the theorem statement. If it's verified, the + proof term is added to the global environment as an opaque constant + using the declared name from the original goal. + + It's very rare for a proof term to fail verification. Generally this + indicates a bug in a tactic you used or that you misused some + unsafe tactics. .. exn:: Attempt to save an incomplete proof. :undocumented: + .. exn:: No focused proof (No proof-editing in progress). + + You tried to use a proof mode command such as :cmd:`Qed` outside of proof + mode. + .. note:: Sometimes an error occurs when building the proof term, because @@ -81,9 +182,9 @@ list of assertion commands is given in :ref:`Assertions`. The command even incur a memory overflow. .. cmd:: Save @ident - :name: Save - Saves a completed proof with the name :token:`ident`, which + Similar to :cmd:`Qed`, except that the proof term is added to the global + context with the name :token:`ident`, which overrides any name provided by the :cmd:`Theorem` command or its variants. @@ -98,7 +199,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Admitted - This command is available in interactive editing mode to give up + This command is available in proof mode to give up the current proof and declare the initial goal as an axiom. .. cmd:: Abort {? {| All | @ident } } @@ -120,7 +221,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Proof @term :name: Proof `term` - This command applies in proof editing mode. It is equivalent to + This command applies in proof mode. It is equivalent to :n:`exact @term. Qed.` That is, you have to give the full proof in one gulp, as a proof term (see Section :ref:`applyingtheorems`). @@ -159,7 +260,7 @@ list of assertion commands is given in :ref:`Assertions`. The command | Type {? * } | All - Opens proof editing mode, declaring the set of + Opens proof mode, declaring the set of section variables (see :ref:`gallina-assumptions`) used by the proof. At :cmd:`Qed` time, the system verifies that the set of section variables used in @@ -210,7 +311,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. example:: - .. coqtop:: all + .. coqtop:: all reset Section Test. Variable n : nat. @@ -232,7 +333,6 @@ The following options modify the behavior of ``Proof using``. .. opt:: Default Proof Using "@section_var_expr" - :name: Default Proof Using Use :n:`@section_var_expr` as the default ``Proof using`` value. E.g. ``Set Default Proof Using "a b"`` will complete all ``Proof`` commands not followed by a @@ -301,7 +401,7 @@ Name a set of section hypotheses for ``Proof using`` Use :cmd:`Unshelve` instead. Proof modes -``````````` +----------- When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, Coq picks by default the |Ltac| mode. Nonetheless, there exist other proof modes @@ -312,8 +412,8 @@ be changed using the following option. .. opt:: Default Proof Mode @string Select the proof mode to use when starting a proof. Depending on the proof - mode, various syntactic constructs are allowed when writing an interactive - proof. All proof modes support vernacular commands; the proof mode determines + mode, various syntactic constructs are allowed when writing a + proof. All proof modes support commands; the proof mode determines which tactic language and set of tactic definitions are available. The possible option values are: @@ -349,16 +449,16 @@ Navigation in the proof tree .. cmd:: Restart - Restores the proof editing process to the original goal. + Restores the proof to the original goal. .. exn:: No focused proof to restart. :undocumented: .. cmd:: Focus {? @natural } - Focuses the attention on the first subgoal to prove or, if :token:`natural` is + Focuses the attention on the first goal to prove or, if :token:`natural` is specified, the :token:`natural`\-th. The - printing of the other subgoals is suspended until the focused subgoal + printing of the other goals is suspended until the focused goal is solved or unfocused. .. deprecated:: 8.8 @@ -379,14 +479,9 @@ Navigation in the proof tree .. _curly-braces: -.. index:: { - } - -.. todo: :name: "{"; "}" doesn't work, nor does :name: left curly bracket; right curly bracket, - hence the verbose names - .. tacn:: {? {| @natural | [ @ident ] } : } %{ - %} + %} + :name: {; } .. todo See https://github.com/coq/coq/issues/12004 and @@ -403,7 +498,7 @@ Navigation in the proof tree or focus the next one. :n:`@natural:` - Focuses on the :token:`natural`\-th subgoal to prove. + Focuses on the :token:`natural`\-th goal to prove. :n:`[ @ident ]: %{` Focuses on the named goal :token:`ident`. @@ -477,7 +572,7 @@ Navigation in the proof tree Brackets are used to focus on a single goal given either by its position or by its name if it has one. - .. seealso:: The error messages for bullets below. + .. seealso:: The error messages for bullets below. .. _bullets: @@ -567,7 +662,6 @@ Set Bullet Behavior ~~~~~~~~~~~~~~~~~~~ .. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } - :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -577,8 +671,7 @@ Set Bullet Behavior Modifying the order of goals ```````````````````````````` -.. tacn:: cycle @integer - :name: cycle +.. tacn:: cycle @int_or_var Reorders the selected goals so that the first :n:`@integer` goals appear after the other selected goals. @@ -601,8 +694,7 @@ Modifying the order of goals all: cycle 2. all: cycle -3. -.. tacn:: swap @integer @integer - :name: swap +.. tacn:: swap @int_or_var @int_or_var Exchanges the position of the specified goals. Negative values for :n:`@integer` indicate counting goals @@ -621,7 +713,6 @@ Modifying the order of goals all: swap 1 -1. .. tacn:: revgoals - :name: revgoals Reverses the order of the selected goals. The tactic is only useful with a goal selector, most commonly `all :`. Note that other selectors reorder goals; @@ -638,16 +729,17 @@ Modifying the order of goals Postponing the proof of some goals `````````````````````````````````` +Goals can be :gdef:`shelved` so they are no longer displayed in the proof state. +They can then be :gdef:`unshelved` to make them visible again. + .. tacn:: shelve - :name: shelve This tactic moves all goals under focus to a shelf. While on the shelf, goals will not be focused on. They can be solved by unification, or they can be called back into focus with the command :cmd:`Unshelve`. - .. tacv:: shelve_unifiable - :name: shelve_unifiable + .. tacn:: shelve_unifiable Shelves only the goals under focus that are mentioned in other goals. Goals that appear in the type of other goals can be solved by unification. @@ -667,14 +759,12 @@ Postponing the proof of some goals from the shelf into focus, by appending them to the end of the current list of focused goals. -.. tacn:: unshelve @tactic - :name: unshelve +.. tacn:: unshelve @ltac_expr1 Performs :n:`@tactic`, then unshelves existential variables added to the shelf by the execution of :n:`@tactic`, prepending them to the current goal. .. tacn:: give_up - :name: give_up This tactic removes the focused goals from the proof. They are not solved, and cannot be solved later in the proof. As the goals are not @@ -694,7 +784,7 @@ Requesting information Displays the current goals. :n:`@natural` - Display only the :token:`natural`\-th subgoal. + Display only the :token:`natural`\-th goal. :n:`@ident` Displays the named goal :token:`ident`. This is useful in @@ -791,7 +881,7 @@ Requesting information Some tactics (e.g. :tacn:`refine`) allow to build proofs using fixpoint or co-fixpoint constructions. Due to the incremental nature - of interactive proof construction, the check of the termination (or + of proof construction, the check of the termination (or guardedness) of the recursive calls in the fixpoint or cofixpoint constructions is postponed to the time of the completion of the proof. @@ -854,7 +944,6 @@ How to enable diffs ``````````````````` .. opt:: Diffs {| "on" | "off" | "removed" } - :name: Diffs The “on” setting highlights added tokens in green, while the “removed” setting additionally reprints items with removed tokens in red. Unchanged tokens in @@ -983,12 +1072,11 @@ To show differences in the proof term: .. image:: ../../_static/diffs-show-proof.png :alt: coqide with Set Diffs on with compacted hypotheses -Controlling the effect of proof editing commands ------------------------------------------------- +Controlling proof mode +---------------------- .. opt:: Hyps Limit @natural - :name: Hyps Limit This option controls the maximum number of hypotheses displayed in goals after the application of a tactic. All the hypotheses remain usable @@ -1009,7 +1097,7 @@ Controlling the effect of proof editing commands .. flag:: Printing Goal Names - When turned on, the name of the goal is printed in interactive + When turned on, the name of the goal is printed in proof mode, which can be useful in cases of cross references between goals. diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 9ec568c2c7..8873d02888 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -1,102 +1,123 @@ -================================= -Term rewriting and simplification -================================= +========================= +Reasoning with equalities +========================= -.. _rewritingexpressions: +There are multiple notions of :gdef:`equality` in Coq: -Rewriting expressions ---------------------- +- :gdef:`Leibniz equality` is the standard + way to define equality in Coq and the Calculus of Inductive Constructions, + which is in terms of a binary relation, i.e. a binary function that returns + a `Prop`. The standard library + defines `eq` similar to this: -These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in -file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is -simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. + .. coqdoc:: -.. tacn:: rewrite @term - :name: rewrite + Inductive eq {A : Type} (x : A) : A -> Prop := eq_refl : eq x x. - This tactic applies to any goal. The type of :token:`term` must have the form + The notation `x = y` represents the term `eq x y`. The notation `x = y :> A` + gives the type of x and y explicitly. - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` +- :gdef:`Setoid equality <setoid equality>` defines equality in terms of an equivalence + relation. A :gdef:`setoid` is a set that is equipped with an equivalence relation + (see https://en.wikipedia.org/wiki/Setoid). These are needed to form a :gdef:`quotient set` + or :gdef:`quotient` + (see https://en.wikipedia.org/wiki/Equivalence_Class). In Coq, users generally work + with setoids rather than constructing quotients, for which there is no specific support. - where :g:`eq` is the Leibniz equality or a registered setoid equality. +- :gdef:`Definitional equality <definitional equality>` is equality based on the + :ref:`conversion rules <Conversion-rules>`, which Coq can determine automatically. + When two terms are definitionally equal, Coq knows it can + replace one with the other, such as with :tacn:`change` `X with Y`, among many + other advantages. ":term:`Convertible <convertible>`" is another way of saying that + two terms are definitionally equal. - Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, - resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then - replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. - Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, - and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new - subgoals. +.. _rewritingexpressions: - .. exn:: The @term provided does not end with an equation. - :undocumented: +Rewriting with Leibniz and setoid equality +------------------------------------------ - .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. - :undocumented: +.. tacn:: rewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } - .. tacv:: rewrite -> @term + .. insertprodn oriented_rewriter one_term_with_bindings - Is equivalent to :n:`rewrite @term` + .. prodn:: + oriented_rewriter ::= {? {| -> | <- } } {? @natural } {? {| ? | ! } } @one_term_with_bindings + one_term_with_bindings ::= {? > } @one_term {? with @bindings } - .. tacv:: rewrite <- @term + Rewrites terms based on equalities. The type of :n:`@one_term` must have the form: - Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left + :n:`{? forall {+ (x__i: A__i) } , } EQ @term__1 @term__2` - .. tacv:: rewrite @term in @goal_occurrences + where :g:`EQ` is the Leibniz equality `eq` or a registered setoid equality. + Note that :n:`eq @term__1 @term__2` is typically written with the infix notation + :n:`@term__1 = @term__2`. You must `Require Setoid` to use the tactic + with a setoid equality or with :ref:`setoid rewriting <generalizedrewriting>`. + In the general form, any :n:`@binder` may be used, not just :n:`(x__i: A__i)`. - Analogous to :n:`rewrite @term` but rewriting is done following - the clause :token:`goal_occurrences`. For instance: + .. todo doublecheck the @binder comment is correct. - + :n:`rewrite H in H'` will rewrite `H` in the hypothesis - ``H'`` instead of the current goal. - + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means - :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` - In particular a failure will happen if any of these three simpler tactics - fails. - + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses - :g:`H'` different from :g:`H`. - A success will happen as soon as at least one of these simpler tactics succeeds. - + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` - that succeeds if at least one of these two tactics succeeds. + :n:`rewrite @one_term` finds subterms matching :n:`@term__1` in the goal, + and replaces them with :n:`@term__2` (or the reverse if `<-` is given). + Some of the variables :g:`x`\ :sub:`i` are solved by unification, + and some of the types :n:`A__1, ..., A__n` may become new + subgoals. :tacn:`rewrite` won't find occurrences inside `forall` that refer + to variables bound by the `forall`; use :tacn:`setoid_rewrite` + if you want to find such occurrences. - Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. + :n:`{+, @oriented_rewriter }` + The :n:`@oriented_rewriter`\s are applied sequentially + to the first goal generated by the previous :n:`@oriented_rewriter`. If any of them fail, + the tactic fails. - .. tacv:: rewrite @term at @occurrences + :n:`{? {| -> | <- } }` + For `->` (the default), :n:`@term__1` is rewritten + into :n:`@term__2`. For `<-`, :n:`@term__2` is rewritten into :n:`@term__1`. - Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are - specified from left to right as for pattern (:tacn:`pattern`). The rewrite is - always performed using setoid rewriting, even for Leibniz’s equality, so one - has to ``Import Setoid`` to use this variant. + :n:`{? @natural } {? {| ? | ! } }` + :n:`@natural` is the number of rewrites to perform. If `?` is given, :n:`@natural` + is the maximum number of rewrites to perform; otherwise :n:`@natural` is the exact number + of rewrites to perform. - .. tacv:: rewrite @term by @tactic + `?` (without :n:`@natural`) performs the rewrite as many times as possible + (possibly zero times). + This form never fails. `!` (without :n:`@natural`) performs the rewrite as many + times as possible + and at least once. The tactic fails if the requested number of rewrites can't + be performed. :n:`@natural !` is equivalent to :n:`@natural`. - Use tactic to completely solve the side-conditions arising from the - :tacn:`rewrite`. + :n:`@occurrences` + If :n:`@occurrences` specifies multiple occurrences, the tactic succeeds if + any of them can be rewritten. If not specified, only the first occurrence + in the conclusion is replaced. - .. tacv:: rewrite {+, @orientation @term} {? in @ident } + If :n:`at @occs_nums` is specified, rewriting is always done with + :ref:`setoid rewriting <generalizedrewriting>`, even for Leibniz’s equality. - Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one - working on the first subgoal generated by the previous one. An :production:`orientation` - ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One - unique clause can be added at the end after the keyword in; it will then - affect all rewrite operations. + :n:`by @ltac_expr3` + If specified, is used to resolve all side conditions generated by the tactic. - In all forms of rewrite described above, a :token:`term` to rewrite can be - immediately prefixed by one of the following modifiers: + .. exn:: Tactic failure: Setoid library not loaded. + :undocumented: - + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many - times as possible (perhaps zero time). This form never fails. - + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. - + `!` : works as `?`, except that at least one rewrite should succeed, otherwise - the tactic fails. - + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, - leading to failure if these :token:`natural` rewrites are not possible. + .. todo You can use Typeclasses Debug to tell whether rewrite used + setoid rewriting. Example here: https://github.com/coq/coq/pull/13470#discussion_r539230973 - .. tacv:: erewrite @term - :name: erewrite + .. exn:: Cannot find a relation to rewrite. + :undocumented: + + .. exn:: Tactic generated a subgoal identical to the original goal. + :undocumented: + + .. exn:: Found no subterm matching @term in @ident. + Found no subterm matching @term in the current goal. - This tactic works as :n:`rewrite @term` but turning - unresolved bindings into existential variables, if any, instead of - failing. It has the same variants as :tacn:`rewrite` has. + This happens if :n:`@term` does not occur in, respectively, the named hypothesis or the goal. + + .. tacn:: erewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } + + Works like :tacn:`rewrite`, but turns + unresolved bindings, if any, into existential variables instead of + failing. It has the same parameters as :tacn:`rewrite`. .. flag:: Keyed Unification @@ -105,211 +126,245 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments are then unified up to full reduction. -.. tacn:: replace @term with @term’ - :name: replace +.. tacn:: rewrite * {? {| -> | <- } } @one_term {? in @ident } {? at @rewrite_occs } {? by @ltac_expr3 } + rewrite * {? {| -> | <- } } @one_term at @rewrite_occs in @ident {? by @ltac_expr3 } + :name: rewrite *; _ + :undocumented: - This tactic applies to any goal. It replaces all free occurrences of :n:`@term` - in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` - as a subgoal. This equality is automatically solved if it occurs among - the assumptions, or if its symmetric form occurs. It is equivalent to - :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. +.. tacn:: rewrite_db @ident {? in @ident } + :undocumented: - .. exn:: Terms do not have convertible types. - :undocumented: +.. tacn:: replace @one_term__from with @one_term__to {? @occurrences } {? by @ltac_expr3 } + replace {? {| -> | <- } } @one_term__from {? @occurrences } + :name: replace; _ - .. tacv:: replace @term with @term’ by @tactic + The first form replaces all free occurrences of :n:`@one_term__from` + in the current goal with :n:`@one_term__to` and generates an equality + :n:`@one_term__to = @one_term__from` + as a subgoal. (Note the generated equality is reversed with respect + to the order of the two terms in the tactic syntax; see + issue `#13480 <https://github.com/coq/coq/issues/13480>`_.) + This equality is automatically solved if it occurs among + the hypotheses, or if its symmetric form occurs. - This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated - subgoal :n:`@term = @term’`. + The second form, with `->` or no arrow, replaces :n:`@one_term__from` + with :n:`@term__to` using + the first hypothesis whose type has the form :n:`@one_term__from = @term__to`. + If `<-` is given, the tactic uses the first hypothesis with the reverse form, + i.e. :n:`@term__to = @one_term__from`. - .. tacv:: replace @term + :n:`@occurrences` + The `type of` and `value of` forms are not supported. + Note you must `Require Setoid` to use the `at` clause in :n:`@occurrences`. - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` or :n:`@term’ = @term`. + :n:`by @ltac_expr3` + Applies the :n:`@ltac_expr3` to solve the generated equality. - .. tacv:: replace -> @term + .. exn:: Terms do not have convertible types. + :undocumented: - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` + .. tacn:: cutrewrite {? {| -> | <- } } @one_term {? in @ident } - .. tacv:: replace <- @term + Where :n:`@one_term` is an equality. - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term’ = @term` + .. deprecated:: 8.5 - .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} - replace -> @term in @goal_occurrences - replace <- @term in @goal_occurrences + Use :tacn:`replace` instead. - Acts as before but the replacements take place in the specified clauses - (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not - only in the conclusion of the goal. The clause argument must not contain - any ``type of`` nor ``value of``. +.. tacn:: substitute {? {| -> | <- } } @one_term {? with @bindings } + :undocumented: -.. tacn:: subst @ident - :name: subst +.. tacn:: subst {* @ident } - This tactic applies to a goal that has :n:`@ident` in its context and (at - least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` - with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by - :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and - clears :n:`@ident` and :g:`H` from the context. + For each :n:`@ident`, in order, for which there is a hypothesis in the form + :n:`@ident = @term` or :n:`@term = @ident`, replaces :n:`@ident` with :n:`@term` + everywhere in the hypotheses and the conclusion and clears :n:`@ident` and the hypothesis + from the context. If there are multiple hypotheses that match the :n:`@ident`, + the first one is used. If no :n:`@ident` is given, replacement is done for all + hypotheses in the appropriate form in top to bottom order. - If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also + If :n:`@ident` is a local definition of the form :n:`@ident := @term`, it is also unfolded and cleared. - If :n:`@ident` is a section variable it is expected to have no - indirect occurrences in the goal, i.e. that no global declarations - implicitly depending on the section variable must be present in the + If :n:`@ident` is a section variable it must have no + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the goal. .. note:: - + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the - first one is used. - - + If :g:`H` is itself dependent in the goal, it is replaced by the proof of - reflexivity of equality. - - .. tacv:: subst {+ @ident} - - This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. - - .. tacv:: subst - - This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the - context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` - or :n:`@ident := t` exists, with :n:`@ident` not occurring in - ``t`` and :n:`@ident` not a section variable with indirect - dependencies in the goal. + If the hypothesis is itself dependent in the goal, it is replaced by the proof of + reflexivity of equality. .. flag:: Regular Subst Tactic This flag controls the behavior of :tacn:`subst`. When it is activated (it is by default), :tacn:`subst` also deals with the following corner cases: - + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` - and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not - a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the flag, a second call to - subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or + + A context with ordered hypotheses :n:`@ident__1 = @ident__2` + and :n:`@ident__1 = t`, or :n:`t′ = @ident__1` with `t′` not + a variable, and no other hypotheses of the form :n:`@ident__2 = u` + or :n:`u = @ident__2`; without the flag, a second call to + subst would be necessary to replace :n:`@ident__2` by `t` or `t′` respectively. + The presence of a recursive equation which without the flag would be a cause of failure of :tacn:`subst`. - + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` - and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the + + A context with cyclic dependencies as with hypotheses :n:`@ident__1 = f @ident__2` + and :n:`@ident__2 = g @ident__1` which without the flag would be a cause of failure of :tacn:`subst`. - Additionally, it prevents a local definition such as :n:`@ident := t` to be + Additionally, it prevents a local definition such as :n:`@ident := t` from being unfolded which otherwise it would exceptionally unfold in configurations containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` with `u′` not a variable. Finally, it preserves the initial order of hypotheses, which without the flag it may break. - default. - .. exn:: Cannot find any non-recursive equality over :n:`@ident`. + .. exn:: Cannot find any non-recursive equality over @ident. :undocumented: - .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. - Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. + .. exn:: Section variable @ident occurs implicitly in global declaration @qualid present in hypothesis @ident. + Section variable @ident occurs implicitly in global declaration @qualid present in the conclusion. Raised when the variable is a section variable with indirect dependencies in the goal. + If :n:`@ident` is a section variable, it must not have any + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the + goal. +.. tacn:: simple subst + :undocumented: -.. tacn:: stepl @term - :name: stepl +.. tacn:: stepl @one_term {? by @ltac_expr } - This tactic is for chaining rewriting steps. It assumes a goal of the - form :n:`R @term @term` where ``R`` is a binary relation and relies on a + For chaining rewriting steps. It assumes a goal in the + form :n:`R @term__1 @term__2` where ``R`` is a binary relation and relies on a database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` - where `eq` is typically a setoid equality. The application of :n:`stepl @term` - then replaces the goal by :n:`R @term @term` and adds a new goal stating - :n:`eq @term @term`. + where `eq` is typically a setoid equality. The application of :n:`stepl @one_term` + then replaces the goal by :n:`R @one_term @term__2` and adds a new goal stating + :n:`eq @one_term @term__1`. + + If :n:`@ltac_expr` is specified, it is applied to the side condition. - .. cmd:: Declare Left Step @term + .. cmd:: Declare Left Step @one_term - Adds :n:`@term` to the database used by :tacn:`stepl`. + Adds :n:`@one_term` to the database used by :tacn:`stepl`. This tactic is especially useful for parametric setoids which are not accepted as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see :ref:`Generalizedrewriting`). - .. tacv:: stepl @term by @tactic + .. tacn:: stepr @one_term {? by @ltac_expr } - This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. - - .. tacv:: stepr @term by @tactic - :name: stepr - - This behaves as :tacn:`stepl` but on the right-hand-side of the binary - relation. Lemmas are expected to be of the form + This behaves like :tacn:`stepl` but on the right hand side of the binary + relation. Lemmas are expected to be in the form :g:`forall x y z, R x y -> eq y z -> R x z`. - .. cmd:: Declare Right Step @term + .. cmd:: Declare Right Step @one_term Adds :n:`@term` to the database used by :tacn:`stepr`. +Rewriting with definitional equality +------------------------------------ + +.. tacn:: change {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } + + Replaces terms with other :term:`convertible` terms. + If :n:`@one_term__from` is not specified, then :n:`@one_term__from` replaces the conclusion and/or + the specified hypotheses. If :n:`@one_term__from` is specified, the tactic replaces occurrences + of :n:`@one_term__to` within the conclusion and/or the specified hypotheses. -.. tacn:: change @term - :name: change + :n:`{? @one_term__from {? at @occs_nums } with }` + Replaces the occurrences of :n:`@one_term__from` specified by :n:`@occs_nums` + with :n:`@one_term__to`, provided that the two :n:`@one_term`\s are + convertible. :n:`@one_term__from` may contain pattern variables such as `?x`, + whose value which will substituted for `x` in :n:`@one_term__to`, such as in + `change (f ?x ?y) with (g (x, y))` or `change (fun x => ?f x) with f`. - This tactic applies to any goal. It implements the rule ``Conv`` given in - :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` - with `U` providing that `U` is well-formed and that `T` and `U` are - convertible. + The `at ... with ...` form is deprecated in 8.14; use `with ... at ...` instead. + For `at ... with ... in H |-`, use `with ... in H at ... |-`. + + :n:`@occurrences` + If `with` is not specified, :n:`@occurrences` must only specify + entire hypotheses and/or the goal; it must not include any + :n:`at @occs_nums` clauses. .. exn:: Not convertible. :undocumented: - .. tacv:: change @term with @term’ + .. exn:: Found an "at" clause without "with" clause + :undocumented: - This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. - The term :n:`@term` and :n:`@term’` must be convertible. + .. tacn:: now_show @one_term - .. tacv:: change @term at {+ @natural} with @term’ + A synonym for :n:`change @one_term`. It can be used to + make some proof steps explicit when refactoring a proof script + to make it readable. - This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` - in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. + .. seealso:: :ref:`Performing computations <performingcomputations>` - .. exn:: Too few occurrences. - :undocumented: +.. tacn:: change_no_check {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @goal_occurrences + For advanced usage. Similar to :tacn:`change`, but as an optimization, + it skips checking that :n:`@one_term__to` is convertible with the goal or + :n:`@one_term__from`. - In the presence of :n:`with`, this applies :tacn:`change` to the - occurrences specified by :n:`@goal_occurrences`. In the - absence of :n:`with`, :n:`@goal_occurrences` is expected to - only list hypotheses (and optionally the conclusion) without - specifying occurrences (i.e. no :n:`at` clause). + Recall that the Coq kernel typechecks proofs again when they are concluded to + ensure correctness. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`change_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`change_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. - .. tacv:: now_show @term + In the following example, :tacn:`change_no_check` replaces :g:`False` with + :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - This is a synonym of :n:`change @term`. It can be used to - make some proof steps explicit when refactoring a proof script - to make it readable. + .. example:: - .. seealso:: :ref:`Performing computations <performingcomputations>` + .. coqtop:: all abort fail + + Goal False. + change_no_check True. + exact I. + Qed. + + .. example:: + + .. coqtop:: all abort fail + + Goal True -> False. + intro H. + change_no_check False in H. + exact H. + Qed. + + .. tacn:: convert_concl_no_check @one_term + + .. deprecated:: 8.11 + + Deprecated old name for :tacn:`change_no_check`. Does not support any of its + variants. .. _performingcomputations: 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,16 +376,8 @@ Performing computations | cofix | zeta | delta {? @delta_flag } - ref_or_pattern_occ ::= @reference {? at @occs_nums } - | @one_term {? at @occs_nums } - occs_nums ::= {+ @nat_or_var } - | - {+ @nat_or_var } - int_or_var ::= @integer - | @ident - nat_or_var ::= @natural - | @ident - unfold_occ ::= @reference {? at @occs_nums } - pattern_occ ::= @one_term {? at @occs_nums } + 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`. @@ -348,17 +395,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}`. @@ -454,7 +490,10 @@ the conversion in hypotheses :n:`{+ @ident}`. in :cite:`FullReduction`. If Coq is running in native code, it can be typically two to five times faster than :tacn:`vm_compute`. Note however that the compilation cost is higher, so it is worth using only for intensive - computations. + computations. Depending on the configuration, this tactic can either default to + :tacn:`vm_compute`, recompile dependencies or fail due to some missing + precompiled dependencies, + see :ref:`the native-compiler option <native-compiler-options>` for details. .. flag:: NativeCompute Timing @@ -534,7 +573,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..609884ce1d 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 @@ -1053,7 +1073,7 @@ main grammar, or from another custom entry as is the case in Notation "[ e ]" := e (e custom expr at level 2). to indicate that ``e`` has to be parsed at level ``2`` of the grammar -associated to the custom entry ``expr``. The level can be omitted, as in +associated with the custom entry ``expr``. The level can be omitted, as in .. coqdoc:: @@ -1113,8 +1133,32 @@ 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 This displays the state of the grammar for terms associated with the custom entry :token:`ident`. @@ -1142,6 +1186,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 +1196,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 +1234,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 @@ -1483,7 +1550,6 @@ Displaying information about scopes Use the :cmd:`Print Visibility` command to display the current notation scope stack. .. cmd:: Print Scope @scope_name - :name: Print Scope Displays all notations defined in the notation scope :n:`@scope_name`. It also displays the delimiting key and the class to which the @@ -1617,7 +1683,6 @@ Number notations ~~~~~~~~~~~~~~~~ .. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name - :name: Number Notation .. insertprodn number_modifier number_string_via @@ -1642,6 +1707,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 +1721,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 +1738,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,16 +1828,23 @@ 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). The parsing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Number.int or (option Number.int). 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). The printing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a number notation. @@ -1797,7 +1874,6 @@ String notations ~~~~~~~~~~~~~~~~ .. cmd:: String Notation @qualid__type @qualid__parse @qualid__print {? ( @number_string_via ) } : @scope_name - :name: String Notation Allows the user to customize how strings are parsed and printed. @@ -1826,7 +1902,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>`. @@ -1840,12 +1917,12 @@ String notations .. exn:: @qualid__parse should go from Byte.byte or (list Byte.byte) to @type or (option @type). The parsing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). The printing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a string notation. diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 93571ecebb..0f0edc6bdd 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -170,7 +170,6 @@ Tactics ------- .. tacn:: functional induction @term {? using @one_term {? with @bindings } } {? as @simple_intropattern } - :name: functional induction Performs case analysis and induction following the definition of a function :token:`qualid`, which must be fully applied to its arguments as part of @@ -221,7 +220,6 @@ Tactics :undocumented: .. tacn:: functional inversion {| @ident | @natural } {? @qualid } - :name: functional inversion Performs inversion on hypothesis :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index b68b2ed2a7..78ac17bda1 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -34,9 +34,9 @@ Coq material inside documentation. Coq material is quoted between the delimiters ``[`` and ``]``. Square brackets may be nested, the inner ones being understood as being part of the -quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun -x => u]``). Inside quotations, the code is pretty-printed in the same -way as it is in code parts. +quoted code (thus you can quote a term like ``let id := fun [T : Type] (x : t) => x in id 0`` +by writing ``[let id := fun [T : Type] (x : t) => x in id 0]``). +Inside quotations, the code is pretty-printed the same way as in code parts. Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be followed by a newline and the latter must follow a newline. 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..fa739e97bc 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,13 @@ 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: + print("Duplicate", self.subdomain, "name: ", name) + # self._warn_if_duplicate_name(names_in_subdomain, name, signode) return targetid def _add_index_entry(self, name, target): @@ -322,7 +334,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): @@ -333,7 +345,7 @@ class VernacVariantObject(VernacObject): .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. @@ -505,7 +517,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 +545,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 +874,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 +1194,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 +1233,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 4080eaae08..8aeb2e564d 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 ] @@ -844,8 +864,8 @@ ltac_expr1: [ | EDIT match_key ADD_OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key ltac_expr5 "with" match_list "end" -| REPLACE failkw [ int_or_var | ] LIST0 message_token -| WITH failkw OPT int_or_var LIST0 message_token +| REPLACE failkw [ nat_or_var | ] LIST0 message_token +| WITH failkw OPT nat_or_var LIST0 message_token | REPLACE reference LIST0 tactic_arg | WITH reference LIST1 tactic_arg | l1_tactic @@ -905,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 @@ -966,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 @@ -976,7 +1003,7 @@ simple_tactic: [ | DELETE "replace" uconstr clause | "replace" orient uconstr clause | REPLACE "rewrite" "*" orient uconstr "in" hyp "at" occurrences by_arg_tac -| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences by_arg_tac ) +| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences ) by_arg_tac | DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac | DELETE "rewrite" "*" orient uconstr "at" occurrences by_arg_tac | DELETE "rewrite" "*" orient uconstr by_arg_tac @@ -994,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 ) @@ -1139,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" ] @@ -1163,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 ) @@ -1242,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 @@ -1441,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 *) @@ -1578,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: [ @@ -1772,6 +1814,7 @@ ltac_defined_tactics: [ | "lia" | "lra" | "nia" +| "now_show" constr | "nra" | "over" TAG SSR | "split_Rabs" @@ -1791,6 +1834,7 @@ 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 nat_or_var | "ring" OPT ( "[" LIST1 constr "]" ) @@ -1942,6 +1986,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 *) @@ -2010,7 +2066,7 @@ ltac2_tactic_atom: [ | MOVETO ltac2_quotations "constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "open_constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| MOVETO ltac2_quotations "pattern" ":" "(" cpattern ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "pat" ":" "(" cpattern ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "reference" ":" "(" globref ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) @@ -2318,7 +2374,7 @@ ssrapplyarg: [ ] constr_with_bindings_arg: [ -| EDIT ADD_OPT ">" constr_with_bindings TAG SSR +| EDIT ADD_OPT ">" constr_with_bindings ] destruction_arg: [ @@ -2387,6 +2443,42 @@ 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 +] + +conversion: [ +| DELETE constr +| DELETE constr "with" constr +| PRINT +| REPLACE constr "at" occs_nums "with" constr +| WITH OPT ( constr OPT ( "at" occs_nums ) "with" ) constr +| PRINT +] + SPLICE: [ | clause | noedit_mode @@ -2526,6 +2618,7 @@ SPLICE: [ | eliminator (* todo: splice or not? *) | quoted_attributes (* todo: splice or not? *) | printable +| hint | only_parsing | record_fields | constructor_type @@ -2606,9 +2699,20 @@ SPLICE: [ | syn_level | firstorder_rhs | firstorder_using +| hints_path_atom +| ref_or_pattern_occ +| cumul_ident_decl +| variance +| variance_identref +| rewriter +| conversion ] (* 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 *) @@ -2652,6 +2756,14 @@ 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 +| constr_with_bindings_arg one_term_with_bindings ] simple_tactic: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 92a745c863..a1c1d87763 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,15 +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"; ] in @@ -2101,7 +1905,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 cdee623850..ec23ffe83e 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" ] @@ -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 @@ -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: [ @@ -2056,7 +2095,7 @@ ltac_expr1: [ | "first" "[" LIST0 ltac_expr5 SEP "|" "]" | "solve" "[" LIST0 ltac_expr5 SEP "|" "]" | "idtac" LIST0 message_token -| failkw [ int_or_var | ] LIST0 message_token +| failkw [ nat_or_var | ] LIST0 message_token | simple_tactic | tactic_value | reference LIST0 tactic_arg @@ -2491,7 +2530,7 @@ in_hyp_list: [ ] in_hyp_as: [ -| "in" id_or_meta as_ipat +| "in" LIST1 [ id_or_meta as_ipat ] SEP "," | ] @@ -3331,7 +3370,7 @@ G_LTAC2_tactic_atom: [ | "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| "pattern" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) +| "pat" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) | "reference" ":" "(" globref ")" (* Ltac2 plugin *) | "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index c27169d432..75b32a5800 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,31 +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 nat_or_var -| "-" LIST1 nat_or_var -] - -int_or_var: [ -| integer -| ident -] - -nat_or_var: [ -| natural -| ident -] - -unfold_occ: [ +reference_occs: [ | reference OPT ( "at" occs_nums ) ] -pattern_occ: [ +pattern_occs: [ | one_term OPT ( "at" occs_nums ) ] @@ -705,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: [ @@ -717,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 "," ")" ] ] @@ -901,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 @@ -958,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 ] @@ -983,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 @@ -1030,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 *) @@ -1039,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 @@ -1142,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 @@ -1205,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 ] @@ -1268,35 +1247,40 @@ lident: [ destruction_arg: [ | natural -| constr_with_bindings_arg +| one_term_with_bindings ] -constr_with_bindings_arg: [ -| OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) +occurrences: [ +| "at" occs_nums +| "in" goal_occurrences ] -clause_dft_concl: [ -| "in" in_clause -| OPT ( "at" occs_nums ) +occs_nums: [ +| OPT "-" LIST1 nat_or_var ] -in_clause: [ -| "*" OPT ( "at" occs_nums ) -| "*" "|-" OPT concl_occ -| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +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 ) ] @@ -1545,15 +1529,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: [ @@ -1579,6 +1563,7 @@ syntax_modifier: [ explicit_subentry: [ | "ident" +| "name" | "global" | "bigint" | "strict" "pattern" OPT ( "at" "level" natural ) @@ -1591,6 +1576,7 @@ explicit_subentry: [ binder_interp: [ | "as" "ident" +| "as" "name" | "as" "pattern" | "as" "strict" "pattern" ] @@ -1628,7 +1614,7 @@ simple_tactic: [ | "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 "," ) @@ -1646,8 +1632,8 @@ 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 @@ -1667,7 +1653,7 @@ simple_tactic: [ | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" | "idtac" LIST0 [ ident | string | natural ] -| [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | natural ] +| [ "fail" | "gfail" ] OPT nat_or_var LIST0 [ ident | string | natural ] | ltac_expr ssrintros (* SSR plugin *) | "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term @@ -1695,13 +1681,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 @@ -1762,13 +1749,13 @@ simple_tactic: [ | "auto" OPT nat_or_var OPT auto_using OPT hintbases | "info_auto" OPT nat_or_var OPT auto_using OPT hintbases | "debug" "auto" OPT nat_or_var OPT auto_using OPT hintbases -| "eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "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 nat_or_var OPT auto_using OPT hintbases -| "info_eauto" OPT nat_or_var 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 clause_dft_concl +| "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 @@ -1782,8 +1769,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 @@ -1792,12 +1779,12 @@ simple_tactic: [ | "eintros" LIST0 intropattern | "decide" "equality" | "compare" one_term one_term -| "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "elim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) -| "eelim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) +| "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "elim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) +| "eelim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) | "case" induction_clause_list | "ecase" induction_clause_list | "fix" ident natural OPT ( "with" LIST1 fixdecl ) @@ -1806,10 +1793,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 ")" @@ -1827,32 +1814,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" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences +| "change_no_check" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences | "btauto" | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) @@ -1931,6 +1918,7 @@ simple_tactic: [ | "lia" | "lra" | "nia" +| "now_show" one_term | "nra" | "over" (* SSR plugin *) | "split_Rabs" @@ -1944,6 +1932,7 @@ 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 nat_or_var | "ring" OPT ( "[" LIST1 one_term "]" ) @@ -1985,30 +1974,35 @@ as_name: [ ] oriented_rewriter: [ -| OPT [ "->" | "<-" ] rewriter +| OPT [ "->" | "<-" ] OPT natural OPT [ "?" | "!" ] one_term_with_bindings ] -rewriter: [ -| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg +one_term_with_bindings: [ +| OPT ">" one_term OPT ( "with" bindings ) ] 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 "," ")" @@ -2053,6 +2047,10 @@ bindings: [ | LIST1 one_term ] +int_or_var: [ +| [ integer | ident ] +] + comparison: [ | "=" | "<" @@ -2061,11 +2059,6 @@ comparison: [ | ">=" ] -hintbases: [ -| "with" "*" -| "with" LIST1 ident -] - bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] @@ -2385,7 +2378,7 @@ ltac2_quotations: [ | "ident" ":" "(" lident ")" | "constr" ":" "(" term ")" | "open_constr" ":" "(" term ")" -| "pattern" ":" "(" cpattern ")" +| "pat" ":" "(" cpattern ")" | "reference" ":" "(" [ "&" ident | qualid ] ")" | "ltac1" ":" "(" ltac1_expr_in_env ")" | "ltac1val" ":" "(" ltac1_expr_in_env ")" @@ -2434,11 +2427,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: [ @@ -2458,17 +2451,11 @@ cofixdecl: [ | "(" ident LIST0 simple_binder ":" term ")" ] -conversion: [ -| one_term -| one_term "with" one_term -| one_term "at" occs_nums "with" one_term -] - 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/eConstr.ml b/engine/eConstr.ml index c29de27efb..157995a173 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -35,6 +35,10 @@ include (Evd.MiniEConstr : module type of Evd.MiniEConstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -69,7 +73,7 @@ let mkInd i = of_kind (Ind (in_punivs i)) let mkConstructU pc = of_kind (Construct pc) let mkConstruct c = of_kind (Construct (in_punivs c)) let mkConstructUi ((ind,u),i) = of_kind (Construct ((ind,i),u)) -let mkCase (ci, c, iv, r, p) = of_kind (Case (ci, c, iv, r, p)) +let mkCase (ci, u, pms, c, iv, r, p) = of_kind (Case (ci, u, pms, c, iv, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) @@ -195,7 +199,7 @@ let destCoFix sigma c = match kind sigma c with | _ -> raise DestKO let destCase sigma c = match kind sigma c with -| Case (ci, t, iv, c, p) -> (ci, t, iv, c, p) +| Case (ci, u, pms, t, iv, c, p) -> (ci, u, pms, t, iv, c, p) | _ -> raise DestKO let destProj sigma c = match kind sigma c with @@ -320,19 +324,28 @@ let existential_type = Evd.existential_type let lift n c = of_constr (Vars.lift n (unsafe_to_constr c)) -let map_under_context f n c = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_under_context f n (unsafe_to_constr c)) -let map_branches f ci br = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr_array (Constr.map_branches f ci (unsafe_to_constr_array br)) -let map_return_predicate f ci p = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) +let of_branches : Constr.case_branch array -> case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let unsafe_to_branches : case_branch array -> Constr.case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let of_return : Constr.case_return -> case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x -let map_user_view sigma f c = +let unsafe_to_return : case_return -> Constr.case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let map_branches f br = + let f c = unsafe_to_constr (f (of_constr c)) in + of_branches (Constr.map_branches f (unsafe_to_branches br)) +let map_return_predicate f p = let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_user_view f (unsafe_to_constr (whd_evar sigma c))) + of_return (Constr.map_return_predicate f (unsafe_to_return p)) let map sigma f c = let f c = unsafe_to_constr (f (of_constr c)) in @@ -346,7 +359,61 @@ let iter sigma f c = let f c = f (of_constr c) in Constr.iter f (unsafe_to_constr (whd_evar sigma c)) -let iter_with_full_binders sigma g f n c = +let expand_case env _sigma (ci, u, pms, p, iv, c, bl) = + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let p = unsafe_to_return p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_branches bl in + let (ci, p, iv, c, bl) = Inductive.expand_case env (ci, u, pms, p, iv, c, bl) in + let p = of_constr p in + let c = of_constr c in + let iv = of_case_invert iv in + let bl = of_constr_array bl in + (ci, p, iv, c, bl) + +let annotate_case env sigma (ci, u, pms, p, iv, c, bl as case) = + let (_, p, _, _, bl) = expand_case env sigma case in + let p = + (* Too bad we need to fetch this data in the environment, should be in the + case_info instead. *) + let (_, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + decompose_lam_n_decls sigma (mip.Declarations.mind_nrealdecls + 1) p + in + let mk_br c n = decompose_lam_n_decls sigma n c in + let bl = Array.map2 mk_br bl ci.ci_cstr_ndecls in + (ci, u, pms, p, iv, c, bl) + +let expand_branch env _sigma u pms (ind, i) (nas, _br) = + let open Declarations in + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ans = Inductive.instantiate_context u subst nas ctx in + let ans : rel_context = match Evd.MiniEConstr.unsafe_eq with Refl -> ans in + ans + +let contract_case env _sigma (ci, p, iv, c, bl) = + let p = unsafe_to_constr p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_constr_array bl in + let (ci, u, pms, p, iv, c, bl) = Inductive.contract_case env (ci, p, iv, c, bl) in + let u = EInstance.make u in + let pms = of_constr_array pms in + let p = of_return p in + let iv = of_case_invert iv in + let c = of_constr c in + let bl = of_branches bl in + (ci, u, pms, p, iv, c, bl) + +let iter_with_full_binders env sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -357,7 +424,10 @@ let iter_with_full_binders sigma g f n c = | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (ci,u,pms,p,iv,c,bl) -> + let (ci, _, pms, p, iv, c, bl) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (ctx, c) = f (List.fold_right g ctx n) c in + Array.Fun1.iter f n pms; f_ctx p; iter_invert (f n) iv; f n c; Array.iter f_ctx bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; @@ -566,8 +636,8 @@ let universes_of_constr sigma c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma univs)) s in + | Case (_,u,_,_,_,_,_) -> + let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c | _ -> fold sigma aux s c in aux LSet.empty c diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 882dfe2848..0d038e9a67 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -20,6 +20,8 @@ type t = Evd.econstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -58,6 +60,9 @@ sig val is_empty : t -> bool end +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase + type 'a puniverses = 'a * EInstance.t (** {5 Destructors} *) @@ -128,7 +133,7 @@ val mkIndU : inductive * EInstance.t -> t val mkConstruct : constructor -> t val mkConstructU : constructor * EInstance.t -> t val mkConstructUi : (inductive * EInstance.t) * int -> t -val mkCase : case_info * t * (t,EInstance.t) case_invert * t * t array -> t +val mkCase : case -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t val mkArrow : t -> Sorts.relevance -> t -> t @@ -199,7 +204,7 @@ val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential val destInd : Evd.evar_map -> t -> inductive * EInstance.t val destConstruct : Evd.evar_map -> t -> constructor * EInstance.t -val destCase : Evd.evar_map -> t -> case_info * t * (t,EInstance.t) case_invert * t * t array +val destCase : Evd.evar_map -> t -> case val destProj : Evd.evar_map -> t -> Projection.t * t val destFix : Evd.evar_map -> t -> (t, t) pfixpoint val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint @@ -250,14 +255,12 @@ val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) val map : Evd.evar_map -> (t -> t) -> t -> t -val map_user_view : Evd.evar_map -> (t -> t) -> t -> t val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t -val map_under_context : (t -> t) -> int -> t -> t -val map_branches : (t -> t) -> case_info -> t array -> t array -val map_return_predicate : (t -> t) -> case_info -> t -> t +val map_branches : (t -> t) -> case_branch array -> case_branch array +val map_return_predicate : (t -> t) -> case_return -> case_return val iter : Evd.evar_map -> (t -> unit) -> t -> unit val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit -val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit +val iter_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a (** Gather the universes transitively used in the term, including in the @@ -337,6 +340,21 @@ val fresh_global : val is_global : Evd.evar_map -> GlobRef.t -> t -> bool [@@ocaml.deprecated "Use [EConstr.isRefX] instead."] +val expand_case : Environ.env -> Evd.evar_map -> + case -> (case_info * t * case_invert * t * t array) + +val annotate_case : Environ.env -> Evd.evar_map -> case -> + case_info * EInstance.t * t array * (rel_context * t) * case_invert * t * (rel_context * t) array +(** Same as above, but doesn't turn contexts into binders *) + +val expand_branch : Environ.env -> Evd.evar_map -> + EInstance.t -> t array -> constructor -> case_branch -> rel_context +(** Given a universe instance and parameters for the inductive type, + constructs the typed context in which the branch lives. *) + +val contract_case : Environ.env -> Evd.evar_map -> + (case_info * t * case_invert * t * t array) -> case + (** {5 Extra} *) val of_existential : Constr.existential -> existential @@ -345,7 +363,7 @@ val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, typ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt -val of_case_invert : (Constr.t,Univ.Instance.t) case_invert -> (t,EInstance.t) case_invert +val of_case_invert : Constr.case_invert -> case_invert (** {5 Unsafe operations} *) @@ -371,7 +389,7 @@ sig val to_instance : EInstance.t -> Univ.Instance.t (** Physical identity. Does not care for normalization. *) - val to_case_invert : (t,EInstance.t) case_invert -> (Constr.t,Univ.Instance.t) case_invert + val to_case_invert : case_invert -> Constr.case_invert val eq : (t, Constr.t) eq (** Use for transparent cast between types. *) 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/evarutil.ml b/engine/evarutil.ml index ba6a9ea6d9..f9f8268507 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -144,7 +144,7 @@ let head_evar sigma c = let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_, _, _, _, _, c, _) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c diff --git a/engine/evd.ml b/engine/evd.ml index 498a9d9825..ed40b63d14 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -525,7 +525,7 @@ end = struct let principal = if principal then match fgl.principal with - | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") + | Some _ -> CErrors.user_err Pp.(str "Only one main goal per instantiation.") | None -> Some evk else fgl.principal in @@ -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..58f635b7bd 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 @@ -766,8 +772,8 @@ module MiniEConstr : sig (Constr.t, Constr.types) Context.Named.Declaration.pt val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt - val of_case_invert : (constr,Univ.Instance.t) case_invert -> (econstr,EInstance.t) case_invert - val unsafe_to_case_invert : (econstr,EInstance.t) case_invert -> (constr,Univ.Instance.t) case_invert + val of_case_invert : constr pcase_invert -> econstr pcase_invert + val unsafe_to_case_invert : econstr pcase_invert -> constr pcase_invert val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt val to_rel_decl : evar_map -> (t, t) Context.Rel.Declaration.pt -> diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 7784b38c80..5208469082 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 option t + val timeout : float -> '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 22863f451d..abc1a907d3 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 @@ -926,7 +927,7 @@ let _ = CErrors.register_handler begin function | _ -> None end -let tclTIMEOUT n t = +let tclTIMEOUTF n t = let open Proof in (* spiwack: as one of the monad is a continuation passing monad, it doesn't force the computation to be threaded inside the underlying @@ -951,6 +952,8 @@ let tclTIMEOUT n t = return res | Util.Inr (e, info) -> tclZERO ~info e +let tclTIMEOUT n t = tclTIMEOUTF (float_of_int n) t + let tclTIME s t = let pr_time t1 t2 n msg = let msg = diff --git a/engine/proofview.mli b/engine/proofview.mli index fe0d7ae51e..bf6021b1b6 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -418,7 +418,8 @@ val tclCHECKINTERRUPT : unit tactic (** [tclTIMEOUT n t] can have only one success. In case of timeout it fails with [tclZERO Tac_Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic +val tclTIMEOUTF : float -> 'a tactic -> 'a tactic +val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an identifying annotation if present *) diff --git a/engine/termops.ml b/engine/termops.ml index 693945d5ac..4dc584cfa8 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 @@ -599,7 +606,7 @@ let map_left2 f a g b = r, s end -let map_constr_with_binders_left_to_right sigma g f l c = +let map_constr_with_binders_left_to_right env sigma g f l c = let open RelDecl in let open EConstr in match EConstr.kind sigma c with @@ -643,14 +650,20 @@ let map_constr_with_binders_left_to_right sigma g f l c = let al' = List.map_left (f l) al in if List.for_all2 (==) al' al then c else mkEvar (e, al') - | Case (ci,p,iv,b,bl) -> + | Case (ci,u,pms,p,iv,b,bl) -> + let (ci, _, pms, p0, _, b, bl0) = annotate_case env sigma (ci, u, pms, p, iv, b, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in (* In v8 concrete syntax, predicate is after the term to match! *) let b' = f l b in + let pms' = Array.map_left (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in - let p' = f l p in - let bl' = Array.map_left (f l) bl in - if b' == b && p' == p && iv' == iv && bl' == bl then c - else mkCase (ci, p', iv', b', bl') + let bl' = Array.map_left (fun (c, c0) -> f_ctx c c0) (Array.map2 (fun x y -> (x, y)) bl bl0) in + if b' == b && pms' == pms && p' == p && iv' == iv && bl' == bl then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in @@ -670,25 +683,8 @@ 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 map_branches_with_full_binders sigma 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 sigma g f l) tags bl in - if Array.for_all2 (==) bl' bl then bl else bl' - -let map_return_predicate_with_full_binders sigma g f l ci p = - let n = List.length ci.ci_pp_info.ind_tags in - let p' = map_under_context_with_full_binders sigma g f l n p in - if p' == p then p else p' - (* strong *) -let map_constr_with_full_binders_gen userview sigma g f l cstr = +let map_constr_with_full_binders env sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -720,20 +716,19 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = | Evar (e,al) -> let al' = List.map (f l) al in if List.for_all2 (==) al al' then cstr else mkEvar (e, al') - | Case (ci,p,iv,c,bl) when userview -> - let p' = map_return_predicate_with_full_binders sigma g f l ci p in - let iv' = map_invert (f l) iv in - let c' = f l c in - let bl' = map_branches_with_full_binders sigma g f l ci bl in - if p==p' && iv'==iv && c==c' && bl'==bl then cstr else - mkCase (ci, p', iv', c', bl') - | Case (ci,p,iv,c,bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p0, _, c, bl0) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in + let pms' = Array.Smart.map (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.map (f l) bl in - if p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else - mkCase (ci, p', iv', c', bl') + let bl' = Array.map2 f_ctx bl bl0 in + if pms==pms' && p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in let l' = fold_rec_types g fx l in @@ -754,12 +749,6 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let ty' = f l ty in if def==def' && t == t' && ty==ty' then cstr else mkArray (u,t', def',ty') -let map_constr_with_full_binders sigma g f = - map_constr_with_full_binders_gen false sigma g f - -let map_constr_with_full_binders_user_view sigma g f = - map_constr_with_full_binders_gen true sigma g f - (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as @@ -767,12 +756,31 @@ let map_constr_with_full_binders_user_view sigma g f = index) which is processed by [g] (which typically add 1 to [n]) at 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 fold_constr_with_full_binders env sigma 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 (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p, _, c, bl) = EConstr.annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx acc (ctx, c) = f (List.fold_right g ctx n) acc c in + Array.fold_left f_ctx (f n (fold_invert (f n) (f_ctx (Array.fold_left (f n) acc pms) 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/termops.mli b/engine/termops.mli index 709fa361a9..12df61e4c8 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -50,16 +50,12 @@ val it_mkLambda_or_LetIn_from_no_LetIn : Constr.constr -> Constr.rel_context -> (** {6 Generic iterators on constr} *) val map_constr_with_binders_left_to_right : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : - Evd.evar_map -> - (rel_declaration -> 'a -> 'a) -> - ('a -> constr -> constr) -> 'a -> constr -> constr -val map_constr_with_full_binders_user_view : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr @@ -73,7 +69,7 @@ val map_constr_with_full_binders_user_view : val fold_constr_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -val fold_constr_with_full_binders : Evd.evar_map -> +val fold_constr_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b 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/engine/univSubst.ml b/engine/univSubst.ml index 335c2e5e68..330ed5d0ad 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -68,6 +68,10 @@ let subst_univs_fn_constr f c = let u' = fi u in if u' == u then t else (changed := true; mkConstructU (c, u')) + | Case (ci, u, pms, p, iv, c, br) -> + let u' = fi u in + if u' == u then map aux t + else (changed := true; map aux (mkCase (ci, u', pms, p, iv, c, br))) | _ -> map aux t in let c' = aux c in @@ -147,10 +151,10 @@ let nf_evars_and_universes_opt_subst f subst = | Sort (Type u) -> let u' = Univ.subst_univs_universe subst u in if u' == u then c else mkSort (sort_of_univ u') - | Case (ci,p,CaseInvert {univs;args},t,br) -> - let univs' = Instance.subst_fn lsubst univs in - if univs' == univs then Constr.map aux c - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},t,br)) + | Case (ci,u,pms,p,iv,t,br) -> + let u' = Instance.subst_fn lsubst u in + if u' == u then Constr.map aux c + else Constr.map aux (mkCase (ci,u',pms,p,iv,t,br)) | Array (u,elems,def,ty) -> let u' = Univ.Instance.subst_fn lsubst u in let elems' = CArray.Smart.map aux elems in diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 602acefa7c..528e2a756b 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -195,7 +195,7 @@ let concl_next_tac = let process_goal sigma g = let env = Goal.V82.env sigma g in let min_env = Environ.reset_context env in - let id = if Printer.print_goal_names () then Names.Id.to_string (Termops.evar_suggested_name g sigma) else "" in + let id = if Printer.print_goal_names () then Names.Id.to_string (Termops.evar_suggested_name g sigma) else Goal.uid g in let ccl = pr_letype_env ~goal_concl_style:true env sigma (Goal.V82.concl sigma g) in diff --git a/ide/coqide/wg_ProofView.ml b/ide/coqide/wg_ProofView.ml index 8e451c9917..fa37edd82b 100644 --- a/ide/coqide/wg_ProofView.ml +++ b/ide/coqide/wg_ProofView.ml @@ -66,11 +66,11 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat in let goals_cnt = List.length rem_goals + 1 in let head_str = Printf.sprintf - "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") + "%d goal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") in let goal_str ?(shownum=false) index total id = let annot = - if CString.is_empty id then if shownum then Printf.sprintf "(%d/%d)" index total else "" + if Option.has_some (int_of_string_opt id) (* some uid *) then if shownum then Printf.sprintf "(%d/%d)" index total else "" else Printf.sprintf "(?%s)" id in Printf.sprintf "______________________________________%s\n" annot in @@ -148,10 +148,10 @@ let display mode (view : #GText.view_skel) goals hints evars = let evars = match evars with None -> [] | Some evs -> evs in begin match (bg, shelved_goals,given_up_goals, evars) with | [], [], [], [] -> - view#buffer#insert "No more subgoals." + view#buffer#insert "No more goals." | [], [], [], _ :: _ -> (* A proof has been finished, but not concluded *) - view#buffer#insert "No more subgoals, but there are non-instantiated existential variables:\n\n"; + view#buffer#insert "No more goals, but there are non-instantiated existential variables:\n\n"; let iter evar = let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in view#buffer#insert msg @@ -160,7 +160,7 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "\nYou can use Grab Existential Variables." | [], [], _, _ -> (* The proof is finished, with the exception of given up goals. *) - view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; + view#buffer#insert "No more goals, but there are some goals you gave up:\n\n"; let iter goal = insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" @@ -180,7 +180,7 @@ let display mode (view : #GText.view_skel) goals hints evars = let total = List.length bg in let goal_str index id = let annot = - if CString.is_empty id then Printf.sprintf "(%d/%d)" index total + if Option.has_some (int_of_string_opt id) (* some uid *) then Printf.sprintf "(%d/%d)" index total else Printf.sprintf "(?%s)" id in Printf.sprintf "______________________________________%s\n" annot 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..8138b4c6d9 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 (******************************************************************) @@ -1428,23 +1463,33 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PIf (c,b1,b2) -> GIf (glob_of_pat avoid env sigma c, (Anonymous,None), glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) - | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> - let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in + | PCase ({cip_style=Constr.LetStyle},None,tm,[(0,n,b)]) -> + let n, b = glob_of_pat_under_context avoid env sigma (n, b) in + let nal = Array.to_list n in GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in - simple_cases_matrix_of_branches ind bl' + let map (i, n, c) = + let n, c = glob_of_pat_under_context avoid env sigma (n, c) in + let nal = Array.to_list n in + let mkPatVar na = DAst.make @@ PatVar na in + let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let ids = List.map_filter Nameops.Name.to_option nal in + CAst.make @@ (ids,[p],c) + in + List.map map bl | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in - let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with - | PMeta None, _, _ -> (Anonymous,None),None - | _, Some ind, Some nargs -> - return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) + let indnames,rtn = match p, info.cip_ind with + | None, _ -> (Anonymous,None),None + | Some p, Some ind -> + let nas, p = glob_of_pat_under_context avoid env sigma p in + let nas = Array.rev_to_list nas in + ((List.hd nas, Some (CAst.make (ind, List.tl nas))), Some p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) @@ -1488,11 +1533,26 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let glob_of = glob_of_pat avoid env sigma in GArray (None, Array.map glob_of t, glob_of def, glob_of ty) +and glob_of_pat_under_context avoid env sigma (nas, pat) = + let fold (avoid, env, nas, epat) na = + let na, avoid = compute_displayed_name_in_pattern sigma avoid na epat in + let env = Termops.add_name na env in + let epat = match epat with PLambda (_, _, p) -> p | _ -> assert false in + (avoid, env, na :: nas, epat) + in + let epat = Array.fold_right (fun na p -> PLambda (na, PMeta None, p)) nas pat in + let (avoid', env', nas, _) = Array.fold_left fold (avoid, env, [], epat) nas in + let pat = glob_of_pat avoid' env' sigma pat in + (Array.rev_of_list nas, pat) + 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..7c63ebda3a 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,14 @@ 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 } + +let empty_local_univs = { bound = Id.Map.empty; unb_univs = false } + 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 +267,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 +562,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 +577,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 +608,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 +652,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 +726,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 +768,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 +796,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 +849,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 +969,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 +987,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 +1053,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 +1093,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 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 find_appl_head_data c = +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 +1173,42 @@ 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 + +let try_interp_name_alias = function + | [], { CAst.v = CRef (ref,u) } -> + NRef (intern_reference ref,intern_instance ~local_univs:empty_local_univs u) + | _ -> raise Not_found + (* 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 +1250,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 +1305,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 = empty_local_univs;(* <- doesn't matter here *) tmp_scope = None; scopes = []; impls = empty_internalization_env; binder_block_names = None} Environ.empty_named_context_val @@ -1259,17 +1347,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 +1371,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 +1426,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 +1449,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 +1459,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 +1479,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 +1496,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 +1515,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 +1575,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 +1602,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 +1636,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 +1685,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 +1716,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 +1739,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 @@ -1787,24 +1791,17 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end - | NRef g -> + | 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 +1834,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 +1853,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 +1875,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 +1950,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 +2064,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 +2073,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 +2091,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 +2255,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 +2400,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 +2433,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 +2457,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 +2548,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 +2560,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 = empty_local_univs; + 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 +2591,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 +2602,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 +2639,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..65b63962d0 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) } *) @@ -149,6 +150,10 @@ val interp_constr_pattern : (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) val intern_reference : qualid -> GlobRef.t +(** For syntactic definitions: check if abbreviation to a name + and avoid early insertion of maximal implicit arguments *) +val try_interp_name_alias : 'a list * constr_expr -> notation_constr + (** Expands abbreviations (syndef); raise an error if not existing *) val interp_reference : ltac_sign -> qualid -> glob_constr @@ -198,6 +203,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/impargs.ml b/interp/impargs.ml index 7742f985de..1e85fadce5 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -209,16 +209,16 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Proj (p, _) when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Case _ when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Evar _ -> () | _ -> - iter_with_full_binders sigma push_lift (frec rig) ed c + iter_with_full_binders env sigma push_lift (frec rig) ed c in let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in acc @@ -228,7 +228,7 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc let rec is_rigid_head sigma t = match kind sigma t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true - | Case (_,_,_,f,_) -> is_rigid_head sigma f + | Case (_,_,_,_,_,f,_) -> is_rigid_head sigma f | Proj (p,c) -> true | App (f,args) -> (match kind sigma f with diff --git a/interp/notation.ml b/interp/notation.ml index b5951a9c59..33d96f0439 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 @@ -399,12 +400,12 @@ let cases_pattern_key c = match DAst.get c with | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args) - | NRef ref -> RefKey(canonical_gr ref), NotAppNotation - | NApp (NList (_,_,NApp (NRef ref,args),_,_), args') -> + | NRef (ref,_) -> RefKey(canonical_gr ref), NotAppNotation + | NApp (NList (_,_,NApp (NRef (ref,_),args),_,_), args') -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args + List.length args') | NApp (NList (_,_,NApp (_,args),_,_), args') -> Oth, AppBoundedNotation (List.length args + List.length args') @@ -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 = @@ -2345,8 +2353,8 @@ let browse_notation strict ntn map = let global_reference_of_notation ~head test (ntn,sc,(on_parsing,on_printing,{not_interp = (_,c)})) = match c with - | NRef ref when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) - | NApp (NRef ref, l) when head || List.for_all isNVar_or_NHole l && test ref -> + | NRef (ref,_) when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) + | NApp (NRef (ref,_), l) when head || List.for_all isNVar_or_NHole l && test ref -> Some (on_parsing,on_printing,ntn,sc,ref) | _ -> None diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index f51d3bfdfb..ea5e2a1ad4 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -43,6 +43,28 @@ let cast_type_iter2 f t1 t2 = match t1, t2 with in NList and NBinderList, since the iterator has its own variable *) let replace_var i j var = j :: List.remove Id.equal i var +(* compare_glob_universe_instances true strictly_lt us1 us2 computes us1 <= us2, + compare_glob_universe_instances false strictly_lt us1 us2 computes us1 = us2. + strictly_lt will be set to true if any part is strictly less. *) +let compare_glob_universe_instances lt strictly_lt us1 us2 = + match us1, us2 with + | None, None -> true + | Some _, None -> strictly_lt := true; lt + | None, Some _ -> false + | Some l1, Some l2 -> + CList.for_all2eq (fun u1 u2 -> + match u1, u2 with + | UAnonymous {rigid=true}, UAnonymous {rigid=true} -> true + | UAnonymous {rigid=false}, UAnonymous {rigid=false} -> true + | UAnonymous _, UAnonymous _ -> false + | UNamed _, UAnonymous _ -> strictly_lt := true; lt + | UAnonymous _, UNamed _ -> false + | UNamed _, UNamed _ -> glob_level_eq u1 u2) l1 l2 + +(* Compute us1 <= us2, as a boolean *) +let compare_glob_universe_instances_le us1 us2 = + compare_glob_universe_instances true (ref false) us1 us2 + (* When [lt] is [true], tell if [t1] is a strict refinement of [t2] (this is a partial order, so returning [false] does not mean that [t2] is finer than [t1]); when [lt] is false, tell if [t1] is the @@ -93,7 +115,7 @@ let compare_notation_constr lt (vars1,vars2) t1 t2 = | NHole _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> () | NVar id1, NHole (_, _, _) when lt && List.mem_f Id.equal id1 vars1 -> () | _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> strictly_lt := true - | NRef gr1, NRef gr2 when GlobRef.equal gr1 gr2 -> () + | NRef (gr1,u1), NRef (gr2,u2) when GlobRef.equal gr1 gr2 && compare_glob_universe_instances lt strictly_lt u1 u2 -> () | NHole (_, _, _), NHole (_, _, _) -> () (* FIXME? *) | _, NHole (_, _, _) when lt -> strictly_lt := true | NList (i1, j1, iter1, tail1, b1), NList (i2, j2, iter2, tail2, b2) @@ -377,7 +399,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NCast (c,k) -> GCast (f e c,map_cast_type (f (h.slide e)) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) - | NRef x -> GRef (x,None) + | NRef (x,u) -> GRef (x,u) | NInt i -> GInt i | NFloat f -> GFloat f | NArray (t,def,ty) -> GArray(None, Array.map (f e) t, f e def, f e ty) @@ -612,7 +634,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) - | GRef (r,_) -> NRef r + | GRef (r,u) -> NRef (r,u) | GArray (_u,t,def,ty) -> NArray (Array.map aux t, aux def, aux ty) | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") @@ -706,10 +728,10 @@ let rec subst_pat subst pat = let rec subst_notation_constr subst bound raw = match raw with - | NRef ref -> + | NRef (ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else (match t with - | None -> NRef ref' + | None -> NRef (ref',u) | Some t -> fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) @@ -863,7 +885,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 +903,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 +1036,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 +1083,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 +1271,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 @@ -1344,7 +1366,7 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching compositionally *) | GVar id1, NVar id2 when alpha_var id1 id2 (fst (snd alp)) -> sigma - | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma + | GRef (r1,u1), NRef (r2,u2) when (GlobRef.equal r1 r2) && compare_glob_universe_instances_le u1 u2 -> sigma | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = @@ -1533,7 +1555,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') @@ -1570,10 +1592,10 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(false,0,[]) | PatVar Anonymous, NHole _ -> sigma,(false,0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when Construct.CanOrd.equal r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2,None) when Construct.CanOrd.equal r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(false,0,l) - | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2,None),l2) when Construct.CanOrd.equal r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in @@ -1597,9 +1619,9 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (GlobRef.IndRef r2) when Ind.CanOrd.equal ind r2 -> + | NRef (GlobRef.IndRef r2,None) when Ind.CanOrd.equal ind r2 -> sigma,(false,0,pats) - | NApp (NRef (GlobRef.IndRef r2),l2) + | NApp (NRef (GlobRef.IndRef r2,None),l2) when Ind.CanOrd.equal ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 29db23cc54..2979447cf8 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -21,7 +21,7 @@ open Glob_term type notation_constr = (* Part common to [glob_constr] and [cases_pattern] *) - | NRef of GlobRef.t + | NRef of GlobRef.t * glob_level list option | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option @@ -67,7 +67,8 @@ type extended_subscopes = Constrexpr.notation_entry_level * subscopes type constr_as_binder_kind = | AsIdent - | AsIdentOrPattern + | AsName + | AsNameOrPattern | AsStrictPattern type notation_binder_source = @@ -76,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/reserve.ml b/interp/reserve.ml index 274d3655d3..07160dcf6f 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -71,10 +71,10 @@ let reserve_table = Summary.ref Id.Map.empty ~name:"reserved-type" let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev" let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) - | NRef ref -> RefKey(canonical_gr ref), None + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), Some (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) + | NRef (ref,_) -> RefKey(canonical_gr ref), None | _ -> Oth, None let cache_reserved_type (_,(id,t)) = diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 46baa00c74..91d05f7317 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -26,7 +26,7 @@ let global_of_extended_global_head = function | SynDef kn -> let _, syn_def = search_syntactic_definition kn in let rec head_of = function - | NRef ref -> ref + | NRef (ref,None) -> ref | NApp (rc, _) -> head_of rc | NCast (rc, _) -> head_of rc | NLetIn (_, _, _, rc) -> head_of rc @@ -37,8 +37,8 @@ let global_of_extended_global = function | TrueGlobal ref -> ref | SynDef kn -> match search_syntactic_definition kn with - | [],NRef ref -> ref - | [],NApp (NRef ref,[]) -> ref + | [],NRef (ref,None) -> ref + | [],NApp (NRef (ref,None),[]) -> ref | _ -> raise Not_found let locate_global_with_alias ?(head=false) qid = diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index f3ad3546ff..39e628883a 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -40,7 +40,7 @@ let load_syntax_constant i ((sp,kn),(_local,syndef)) = Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function - | _,NRef ref -> + | _,NRef (ref,_) -> let (dir,id) = repr_qualid (Nametab.shortest_qualid_of_global Id.Set.empty ref) in DirPath.is_empty dir && Id.equal id (basename sp) | _ -> diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 1ba6a8c8fe..4bc6848ba7 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -31,7 +31,8 @@ int arity[STOP+1]; void init_arity () { /* instruction with zero operand */ arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= - arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= + arity[ACC6]=arity[ACC7]= + arity[PUSH]=arity[PUSHACC1]= arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= arity[PUSHACC6]=arity[PUSHACC7]= arity[ENVACC0]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]= @@ -39,10 +40,10 @@ void init_arity () { arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[APPLY4]=arity[RESTART]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE1]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE1]= - arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= + arity[GETFIELD0]=arity[GETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= + arity[ACCUMULATE]=arity[STOP]= 0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= @@ -60,7 +61,6 @@ void init_arity () { arity[CHECKDIV21INT63]= arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= - arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 6255250218..a9ea6d9f46 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -338,10 +338,6 @@ value coq_interprete print_instr("PUSH"); *--sp = accu; Next; } - Instruct(PUSHACC0) { - print_instr("PUSHACC0"); - *--sp = accu; Next; - } Instruct(PUSHACC1){ print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; @@ -1015,20 +1011,6 @@ value coq_interprete Next; } - Instruct(SETFIELD0){ - print_instr("SETFIELD0"); - caml_modify(&Field(accu, 0),*sp); - sp++; - Next; - } - - Instruct(SETFIELD1){ - print_instr("SETFIELD1"); - caml_modify(&Field(accu, 1),*sp); - sp++; - Next; - } - Instruct(SETFIELD){ print_instr("SETFIELD"); caml_modify(&Field(accu, *pc),*sp); @@ -1288,16 +1270,6 @@ value coq_interprete Next; } - Instruct(MAKEPROD) { - print_instr("MAKEPROD"); - *--sp=accu; - Alloc_small(accu,2,0); - Field(accu, 0) = sp[0]; - Field(accu, 1) = sp[1]; - sp += 2; - Next; - } - Instruct(BRANCH) { /* unconditional branching */ print_instr("BRANCH"); @@ -1501,34 +1473,6 @@ value coq_interprete Next; } - Instruct(CHECKLSLINT63CONST1) { - print_instr("CHECKLSLINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsl1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - - Instruct(CHECKLSRINT63CONST1) { - print_instr("CHECKLSRINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsr1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d92bbe87eb..dd9b9e55be 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)); \ @@ -119,12 +119,8 @@ DECLARE_BINOP(lor) #define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) #define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) -DECLARE_UNOP(lsl1) -#define Uint63_lsl1(x) CALL_UNOP(lsl1, x) DECLARE_BINOP(lsr) #define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) -DECLARE_UNOP(lsr1) -#define Uint63_lsr1(x) CALL_UNOP(lsr1, x) DECLARE_BINOP(lt) #define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) DECLARE_BINOP(lxor) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 27696e8856..731ae8f46e 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -55,8 +55,6 @@ else \ accu = uint63_zero; \ }while(0) -#define Uint63_lsl1(x) (accu = (value)((((uint64_t)(x)-1) << 1) +1)) -#define Uint63_lsr1(x) (accu = (value)(((uint64_t)(x) >> 1) |1)) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ /* (modulo 2^63) for p <= 63 */ diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index e7cab24aa7..8edf916a7a 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -34,6 +34,8 @@ open Environ open Vars open Esubst +module RelDecl = Context.Rel.Declaration + let stats = ref false (* Profiling *) @@ -263,7 +265,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 +273,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 +295,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 +317,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 @@ -342,8 +344,8 @@ and fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -355,13 +357,13 @@ and fterm = | FCLOS of constr * fconstr subs | FLOCKED -and finvert = Univ.Instance.t * fconstr array +and finvert = 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 @@ -410,7 +412,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args @@ -448,7 +450,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 +468,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 +490,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 +516,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} @@ -578,10 +580,11 @@ let rec to_constr lfts v = | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op - | FCaseT (ci,p,c,ve,env) -> to_constr_case lfts ci p NoInvert c ve env - | FCaseInvert (ci,p,(univs,args),c,ve,env) -> - let iv = CaseInvert {univs;args=Array.map (to_constr lfts) args} in - to_constr_case lfts ci p iv c ve env + | FCaseT (ci, u, pms, p, c, ve, env) -> + to_constr_case lfts ci u pms p NoInvert c ve env + | FCaseInvert (ci, u, pms, p, indices, c, ve, env) -> + let iv = CaseInvert {indices=Array.map (to_constr lfts) indices} in + to_constr_case lfts ci u pms p iv c ve env | FFix ((op,(lna,tys,bds)) as fx, e) -> if is_subs_id e && is_lift_id lfts then mkFix fx @@ -649,14 +652,20 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) -and to_constr_case lfts ci p iv c ve env = +and to_constr_case lfts ci u pms p iv c ve env = if is_subs_id env && is_lift_id lfts then - mkCase (ci, p, iv, to_constr lfts c, ve) + mkCase (ci, u, pms, p, iv, to_constr lfts c, ve) else let subs = comp_subs lfts env in - mkCase (ci, subst_constr subs p, iv, - to_constr lfts c, - Array.map (fun b -> subst_constr subs b) ve) + let f_ctx (nas, c) = + let c = subst_constr (Esubst.subs_liftn (Array.length nas) subs) c in + (nas, c) + in + mkCase (ci, u, Array.map (fun c -> subst_constr subs c) pms, + f_ctx p, + iv, + to_constr lfts c, + Array.map f_ctx ve) and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> @@ -687,8 +696,8 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s - | ZcaseT(ci,p,br,e)::s -> - let t = FCaseT(ci, p, m, br, e) in + | ZcaseT(ci, u, pms, p, br, e)::s -> + let t = FCaseT(ci, u, pms, p, m, br, e) in let mark = mark (neutr (Mark.red_state m.mark)) Unknown in zip {mark; term=t} s | Zproj p :: s -> @@ -734,11 +743,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 +768,13 @@ 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) + +let subs_consv v s = + subs_consn v 0 (Array.length v) 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 +786,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 +802,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 = @@ -867,6 +882,74 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor.") +let inductive_subst (ind, _) mib u pms e = + let rec self i accu = + if Int.equal i mib.mind_ntypes then accu + else + let c = inject (mkIndU ((ind, i), u)) in + self (i + 1) (subs_cons c accu) + in + let self = self 0 (subs_id 0) in + let rec mk_pms i ctx = match ctx with + | [] -> self + | RelDecl.LocalAssum _ :: ctx -> + let c = mk_clos e pms.(i) in + let subs = mk_pms (i - 1) ctx in + subs_cons c subs + | RelDecl.LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms i ctx in + subs_cons (mk_clos subs c) subs + in + mk_pms (Array.length pms - 1) mib.mind_params_ctxt + +(* Iota-reduction: feed the arguments of the constructor to the branch *) +let get_branch infos depth ci u pms (ind, c) br e args = + let i = c - 1 in + let args = drop_parameters depth ci.ci_npar args in + let (_nas, br) = br.(i) in + if Int.equal ci.ci_cstr_ndecls.(i) ci.ci_cstr_nargs.(i) then + (* No let-bindings in the constructor, we don't have to fetch the + environment to know the value of the branch. *) + let rec push e stk = match stk with + | [] -> e + | Zapp v :: stk -> push (subs_consv v e) stk + | (Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> + assert false + in + let e = push e args in + (br, e) + else + (* The constructor contains let-bindings, but they are not physically + present in the match, so we fetch them in the environment. *) + let env = info_env infos in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let (ctx, _) = mip.mind_nf_lc.(i) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let map = function + | Zapp args -> args + | Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _ -> + assert false + in + let ind_subst = inductive_subst ind mib u pms e in + let args = Array.concat (List.map map args) in + let rec push i e = function + | [] -> [] + | RelDecl.LocalAssum _ :: ctx -> + let ans = push (pred i) e ctx in + args.(i) :: ans + | RelDecl.LocalDef (_, b, _) :: ctx -> + let ans = push i e ctx in + let b = subst_instance_constr u b in + let s = Array.rev_of_list ans in + let e = subs_consv s ind_subst in + let v = mk_clos e b in + v :: ans + in + let ext = push (Array.length args - 1) [] ctx in + (br, subs_consv (Array.rev_of_list ext) e) + (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments @@ -906,7 +989,6 @@ let rec project_nth_arg n = function | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) - (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -931,7 +1013,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 +1054,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 +1064,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 +1074,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 +1125,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 @@ -1251,7 +1337,7 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate info m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) - | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) + | FCaseT(ci,u,pms,p,t,br,e) -> knh info t (ZcaseT(ci,u,pms,p,br,e)::zupdate info m stk) | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') @@ -1271,10 +1357,10 @@ and knht info e t stk = match kind t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) - | Case(ci,p,NoInvert,t,br) -> - knht info e t (ZcaseT(ci, p, br, e)::stk) - | Case(ci,p,CaseInvert{univs;args},t,br) -> - let term = FCaseInvert (ci, p, (univs,Array.map (mk_clos e) args), mk_clos e t, br, e) in + | Case(ci,u,pms,p,NoInvert,t,br) -> + knht info e t (ZcaseT(ci, u, pms, p, br, e)::stk) + | Case(ci,u,pms,p,CaseInvert{indices},t,br) -> + let term = FCaseInvert (ci, u, pms, p, (Array.map (mk_clos e) indices), mk_clos e t, br, e) in { mark = mark Red Unknown; term }, stk | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk @@ -1316,28 +1402,28 @@ 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))) - | FConstruct((_ind,c),_u) -> + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) + | FConstruct(c,_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then (match [@ocaml.warning "-4"] strip_update_shift_app m stk with - | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> + | (depth, args, ZcaseT(ci,u,pms,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - knit info tab e br.(c-1) (rargs@s) + let (br, e) = get_branch info depth ci u pms c br e args in + knit info tab e br s | (_, cargs, Zfix(fx,par)::s) when use_fix -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in @@ -1356,7 +1442,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 @@ -1381,8 +1467,9 @@ let rec knr info tab m stk = kni info tab a (Zprimitive(op,c,rargs,nargs)::s) end | (_, _, s) -> (m, s)) - | FCaseInvert (ci,_p,iv,_c,v,env) when red_set info.i_flags fMATCH -> - begin match case_inversion info tab ci iv v with + | FCaseInvert (ci, u, pms, _p,iv,_c,v,env) when red_set info.i_flags fMATCH -> + let pms = mk_clos_vect env pms in + begin match case_inversion info tab ci u pms iv v with | Some c -> knit info tab env c stk | None -> (m, stk) end @@ -1399,14 +1486,18 @@ and knit info tab e t stk = let (ht,s) = knht info e t stk in knr info tab ht s -and case_inversion info tab ci (univs,args) v = +and case_inversion info tab ci u params indices v = let open Declarations in - if Array.is_empty args then Some v.(0) + (* No binders / lets at all in the unique branch *) + let v = match v with + | [| [||], v |] -> v + | _ -> assert false + in + if Array.is_empty indices then Some v else 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 *) @@ -1414,12 +1505,12 @@ and case_inversion info tab ci (univs,args) v = let _ind, expect_args = destApp expect in let check_index i index = let expected = expect_args.(ci.ci_npar + i) in - let expected = Vars.subst_instance_constr univs expected in + let expected = Vars.subst_instance_constr u expected in let expected = mk_clos psubst expected in !conv {info with i_flags=all} tab expected index in if Array.for_all_i check_index 0 indices - then Some v.(0) else None + then Some v else None let kh info tab v stk = fapp_stack(kni info tab v stk) @@ -1430,9 +1521,13 @@ let rec zip_term zfun m stk = | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s - | ZcaseT(ci,p,br,e)::s -> - let t = mkCase(ci, zfun (mk_clos e p), NoInvert, m, - Array.map (fun b -> zfun (mk_clos e b)) br) in + | ZcaseT(ci, u, pms, p, br, e) :: s -> + let zip_ctx (nas, c) = + let e = Esubst.subs_liftn (Array.length nas) e in + (nas, zfun (mk_clos e c)) + in + let t = mkCase(ci, u, Array.map (fun c -> zfun (mk_clos e c)) pms, zip_ctx p, + NoInvert, m, Array.map zip_ctx br) in zip_term zfun t s | Zproj p::s -> let t = mkProj (Projection.make p true, m) in @@ -1512,9 +1607,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/cClosure.mli b/kernel/cClosure.mli index 3e8916673d..bccbddb0fc 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -110,8 +110,8 @@ type fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -130,7 +130,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args diff --git a/kernel/constr.ml b/kernel/constr.ml index 3157ec9f57..30542597c5 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -83,9 +83,15 @@ type pconstant = Constant.t puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert - | CaseInvert of { univs : 'univs; args : 'constr array } + | CaseInvert of { indices : 'constr array } + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +type 'types pcase_return = Name.t Context.binder_annot array * 'types + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -103,7 +109,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) | Construct of (constructor * 'univs) - | Case of case_info * 'constr * ('constr, 'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -119,6 +125,10 @@ type existential = existential_key * constr list type types = constr +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Instance.t) pcase type rec_declaration = (constr, types) prec_declaration type fixpoint = (constr, types) pfixpoint type cofixpoint = (constr, types) pcofixpoint @@ -194,7 +204,7 @@ let mkConstructU c = Construct c let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkCase (ci, p, iv, c, ac) = Case (ci, p, iv, c, ac) +let mkCase (ci, u, params, p, iv, c, ac) = Case (ci, u, params, p, iv, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] @@ -425,7 +435,7 @@ let destConstruct c = match kind c with (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind c with - | Case (ci,p,iv,c,v) -> (ci,p,iv,c,v) + | Case (ci,u,params,p,iv,c,v) -> (ci,u,params,p,iv,c,v) | _ -> raise DestKO let destProj c = match kind c with @@ -471,8 +481,8 @@ let decompose_appvect c = let fold_invert f acc = function | NoInvert -> acc - | CaseInvert {univs=_;args} -> - Array.fold_left f acc args + | CaseInvert {indices} -> + Array.fold_left f acc indices let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -484,7 +494,8 @@ let fold f acc c = match kind c with | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c | Evar (_,l) -> List.fold_left f acc l - | Case (_,p,iv,c,bl) -> Array.fold_left f (f (fold_invert f (f acc p) iv) c) bl + | Case (_,_,pms,(_,p),iv,c,bl) -> + Array.fold_left (fun acc (_, b) -> f acc b) (f (fold_invert f (f (Array.fold_left f acc pms) p) iv) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl | CoFix (_,(_lna,tl,bl)) -> @@ -498,8 +509,8 @@ let fold f acc c = match kind c with let iter_invert f = function | NoInvert -> () - | CaseInvert {univs=_; args;} -> - Array.iter f args + | CaseInvert {indices;} -> + Array.iter f indices let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -511,7 +522,8 @@ let iter f c = match kind c with | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c | Evar (_,l) -> List.iter f l - | Case (_,p,iv,c,bl) -> f p; iter_invert f iv; f c; Array.iter f bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.iter f pms; f (snd p); iter_invert f iv; f c; Array.iter (fun (_, b) -> f b) bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty @@ -531,7 +543,12 @@ let iter_with_binders g f n c = match kind c with | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.Fun1.iter f n pms; + f (iterate g (Array.length (fst p)) n) (snd p); + iter_invert (f n) iv; + f n c; + Array.Fun1.iter (fun n (ctx, b) -> f (iterate g (Array.length ctx) n) b) n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; @@ -560,7 +577,11 @@ let fold_constr_with_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,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 + | Case (_,_,pms,p,iv,c,bl) -> + let fold_ctx n accu (nas, c) = + f (iterate g (Array.length nas) n) accu c + in + Array.fold_left (fold_ctx n) (f n (fold_invert (f n) (fold_ctx n (Array.fold_left (f n) acc pms) p) iv) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -576,86 +597,39 @@ let fold_constr_with_binders g f n acc c = not recursive and the order with which subterms are processed is not specified *) -let rec map_under_context f n d = - if n = 0 then f d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f b in - let t' = f t in - let c' = map_under_context f (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 t in - let b' = map_under_context f (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 f ci bl = - let nl = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context f) nl bl in - if Array.for_all2 (==) bl' bl then bl else bl' +let map_under_context f d = + let (nas, p) = d in + let p' = f p in + if p' == p then d else (nas, p') -let map_return_predicate f ci p = - map_under_context f (List.length ci.ci_pp_info.ind_tags) p - -let rec map_under_context_with_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_binders g f (g 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_binders g f (g 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_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_binders g f l) tags bl in +let map_branches f bl = + let bl' = Array.map (map_under_context f) bl in if Array.for_all2 (==) bl' bl then bl else 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 +let map_return_predicate f p = + map_under_context f p + +let map_under_context_with_binders g f l d = + let (nas, p) = d in + let l = iterate g (Array.length nas) l in + let p' = f l p in + if p' == p then d else (nas, p') + +let map_branches_with_binders g f l bl = + let bl' = Array.map (map_under_context_with_binders g f l) 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_return_predicate_with_binders g f l p = + map_under_context_with_binders g f l p let map_invert f = function | NoInvert -> NoInvert - | CaseInvert {univs;args;} as orig -> - let args' = Array.Smart.map f args in - if args == args' then orig - else CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let indices' = Array.Smart.map f indices in + if indices == indices' then orig + else CaseInvert {indices=indices';} -let map_gen userview f c = match kind c with +let map f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> c | Cast (b,k,t) -> @@ -692,20 +666,14 @@ let map_gen userview f c = match kind c with let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') - | Case (ci,p,iv,b,bl) when userview -> - let b' = f b in - let iv' = map_invert f iv in - let p' = map_return_predicate f ci p in - let bl' = map_branches f ci bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') - | Case (ci,p,iv,b,bl) -> + | Case (ci,u,pms,p,iv,b,bl) -> + let pms' = Array.Smart.map f pms in let b' = f b in let iv' = map_invert f iv in - let p' = f p in - let bl' = Array.Smart.map f bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') + let p' = map_return_predicate f p in + let bl' = map_branches f bl in + if b'==b && iv'==iv && p'==p && bl'==bl && pms'==pms then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.Smart.map f tl in let bl' = Array.Smart.map f bl in @@ -723,17 +691,26 @@ let map_gen userview f c = match kind c with if def'==def && t==t' && ty==ty' then c else mkArray(u,t',def',ty') -let map_user_view = map_gen true -let map = map_gen false - (* Like {!map} but with an accumulator. *) let fold_map_invert f acc = function | NoInvert -> acc, NoInvert - | CaseInvert {univs;args;} as orig -> - let acc, args' = Array.fold_left_map f acc args in - if args==args' then acc, orig - else acc, CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let acc, indices' = Array.fold_left_map f acc indices in + if indices==indices' then acc, orig + else acc, CaseInvert {indices=indices';} + +let fold_map_under_context f accu d = + let (nas, p) = d in + let accu, p' = f accu p in + if p' == p then accu, d else accu, (nas, p') + +let fold_map_branches f accu bl = + let accu, bl' = Array.Smart.fold_left_map (fold_map_under_context f) accu bl in + if Array.for_all2 (==) bl' bl then accu, bl else accu, bl' + +let fold_map_return_predicate f accu p = + fold_map_under_context f accu p let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -773,13 +750,14 @@ let fold_map f accu c = match kind c with let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') - | Case (ci,p,iv,b,bl) -> - let accu, b' = f accu b in + | Case (ci,u,pms,p,iv,b,bl) -> + let accu, pms' = Array.Smart.fold_left_map f accu pms in + let accu, p' = fold_map_return_predicate f accu p in let accu, iv' = fold_map_invert f accu iv in - let accu, p' = f accu p in - let accu, bl' = Array.Smart.fold_left_map f accu bl in - if b'==b && iv'==iv && p'==p && bl'==bl then accu, c - else accu, mkCase (ci, p', iv', b', bl') + let accu, b' = f accu b in + let accu, bl' = fold_map_branches f accu bl in + if pms'==pms && p'==p && iv'==iv && b'==b && bl'==bl then accu, c + else accu, mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let accu, tl' = Array.Smart.fold_left_map f accu tl in let accu, bl' = Array.Smart.fold_left_map f accu bl in @@ -840,13 +818,14 @@ let map_with_binders g f l c0 = match kind c0 with let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') - | Case (ci, p, iv, c, bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let pms' = Array.Fun1.Smart.map f l pms in + let p' = map_return_predicate_with_binders g f l p in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && iv' == iv && c' == c && bl' == bl then c0 - else mkCase (ci, p', iv', c', bl') + let bl' = map_branches_with_binders g f l bl in + if pms' == pms && p' == p && iv' == iv && c' == c && bl' == bl then c0 + else mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln, (lna, tl, bl)) -> let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in @@ -886,29 +865,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 @@ -925,13 +881,15 @@ type 'constr constr_compare_fn = int -> 'constr -> 'constr -> bool optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) -let eq_invert eq leq_universes iv1 iv2 = +let eq_invert eq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert {univs;args}, CaseInvert iv2 -> - leq_universes univs iv2.univs - && Array.equal eq args iv2.args + | CaseInvert {indices}, CaseInvert iv2 -> + Array.equal eq indices iv2.indices + +let eq_under_context eq (_nas1, p1) (_nas2, p2) = + eq p1 p2 let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t1 t2 = match kind_nocast_gen kind1 t1, kind_nocast_gen kind2 t2 with @@ -958,8 +916,12 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Ind (c1,u1), Ind (c2,u2) -> Ind.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> Construct.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: what are we doing with u1 = u2 ? *) + Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind && leq_universes (Some (GlobRef.IndRef ci1.ci_ind, 0)) u1 u2 && + Array.equal (eq 0) pms1 pms2 && eq_under_context (eq 0) p1 p2 && + eq_invert (eq 0) iv1 iv2 && + eq 0 c1 c2 && Array.equal (eq_under_context (eq 0)) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 @@ -1097,8 +1059,7 @@ let compare_invert f iv1 iv2 = | NoInvert, CaseInvert _ -> -1 | CaseInvert _, NoInvert -> 1 | CaseInvert iv1, CaseInvert iv2 -> - (* univs ignored deliberately *) - Array.compare f iv1.args iv2.args + Array.compare f iv1.indices iv2.indices let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= @@ -1110,6 +1071,9 @@ let constr_ord_int f t1 t2 = let fix_cmp (a1, i1) (a2, i2) = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in + let ctx_cmp f (_n1, p1) (_n2, p2) = + f p1 p2 + in match kind t1, kind t2 with | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 @@ -1143,12 +1107,13 @@ let constr_ord_int f t1 t2 = | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,_u1), Construct (ct2,_u2) -> Construct.CanOrd.compare ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - let c = f p1 p2 in + | Case (_,_u1,pms1,p1,iv1,c1,bl1), Case (_,_u2,pms2,p2,iv2,c2,bl2) -> + let c = Array.compare f pms1 pms2 in + if Int.equal c 0 then let c = ctx_cmp f p1 p2 in if Int.equal c 0 then let c = compare_invert f iv1 iv2 in if Int.equal c 0 then let c = f c1 c2 in - if Int.equal c 0 then Array.compare f bl1 bl2 - else c else c else c + if Int.equal c 0 then Array.compare (ctx_cmp f) bl1 bl2 + else c else c else c else c | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) @@ -1223,9 +1188,11 @@ let invert_eqeq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert iv1, CaseInvert iv2 -> - iv1.univs == iv2.univs - && iv1.args == iv2.args + | CaseInvert {indices=i1}, CaseInvert {indices=i2} -> + i1 == i2 + +let hasheq_ctx (nas1, c1) (nas2, c2) = + array_eqeq nas1 nas2 && c1 == c2 let hasheq t1 t2 = match t1, t2 with @@ -1244,8 +1211,11 @@ let hasheq t1 t2 = | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 - | Case (ci1,p1,iv1,c1,bl1), Case (ci2,p2,iv2,c2,bl2) -> - ci1 == ci2 && p1 == p2 && invert_eqeq iv1 iv2 && c1 == c2 && array_eqeq bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: use deeper equality for contexts *) + u1 == u2 && array_eqeq pms1 pms2 && + ci1 == ci2 && hasheq_ctx p1 p2 && + invert_eqeq iv1 iv2 && c1 == c2 && Array.equal hasheq_ctx bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 @@ -1294,7 +1264,7 @@ let sh_instance = Univ.Instance.share representation for [constr] using [hash_consing_functions] on leaves. *) let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = - let rec hash_term t = + let rec hash_term (t : t) = match t with | Var i -> (Var (sh_id i), combinesmall 1 (Id.hash i)) @@ -1336,13 +1306,27 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let u', hu = sh_instance u in (Construct (sh_construct c, u'), combinesmall 11 (combine (Construct.SyntacticOrd.hash c) hu)) - | Case (ci,p,iv,c,bl) -> - let p, hp = sh_rec p - and iv, hiv = sh_invert iv - and c, hc = sh_rec c in - let bl,hbl = hash_term_array bl in - let hbl = combine4 hc hp hiv hbl in - (Case (sh_ci ci, p, iv, c, bl), combinesmall 12 hbl) + | Case (ci,u,pms,p,iv,c,bl) -> + (** FIXME: use a dedicated hashconsing structure *) + let hcons_ctx (lna, c) = + let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in + let fold accu na = combine (hash_annot Name.hash na) accu in + let hna = Array.fold_left fold 0 lna in + let c, hc = sh_rec c in + (lna, c), combine hna hc + in + let u, hu = sh_instance u in + let pms,hpms = hash_term_array pms in + let p, hp = hcons_ctx p in + let iv, hiv = sh_invert iv in + let c, hc = sh_rec c in + let fold accu c = + let c, h = hcons_ctx c in + combine accu h, c + in + let hbl, bl = Array.fold_left_map fold 0 bl in + let hbl = combine (combine hc (combine hiv (combine hpms (combine hu hp)))) hbl in + (Case (sh_ci ci, u, pms, p, iv, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in @@ -1381,10 +1365,9 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = and sh_invert = function | NoInvert -> NoInvert, 0 - | CaseInvert {univs;args;} -> - let univs, hu = sh_instance univs in - let args, ha = hash_term_array args in - CaseInvert {univs;args;}, combinesmall 1 (combine hu ha) + | CaseInvert {indices;} -> + let indices, ha = hash_term_array indices in + CaseInvert {indices;}, combinesmall 1 ha and sh_rec t = let (y, h) = hash_term t in @@ -1447,8 +1430,8 @@ let rec hash t = combinesmall 10 (combine (Ind.CanOrd.hash ind) (Instance.hash u)) | Construct (c,u) -> combinesmall 11 (combine (Construct.CanOrd.hash c) (Instance.hash u)) - | Case (_ , p, iv, c, bl) -> - combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) + | Case (_ , u, pms, p, iv, c, bl) -> + combinesmall 12 (combine (combine (hash c) (combine (hash_invert iv) (combine (hash_term_array pms) (combine (Instance.hash u) (hash_under_context p))))) (hash_branches bl)) | Fix (_ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(_ln, (_, tl, bl)) -> @@ -1464,8 +1447,8 @@ let rec hash t = and hash_invert = function | NoInvert -> 0 - | CaseInvert {univs;args;} -> - combinesmall 1 (combine (Instance.hash univs) (hash_term_array args)) + | CaseInvert {indices;} -> + combinesmall 1 (hash_term_array indices) and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t @@ -1473,6 +1456,11 @@ and hash_term_array t = and hash_term_list t = List.fold_left (fun acc t -> combine (hash t) acc) 0 t +and hash_under_context (_, t) = hash t + +and hash_branches bl = + Array.fold_left (fun acc t -> combine acc (hash_under_context t)) 0 bl + module CaseinfoHash = struct type t = case_info @@ -1598,10 +1586,15 @@ let rec debug_print c = | Construct (((sp,i),j),u) -> str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")" - | Case (_ci,p,iv,c,bl) -> v 0 - (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++ - debug_print c ++ debug_invert iv ++ str"of") ++ cut() ++ - prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++ + | Case (_ci,_u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + prvect_with_sep spc (fun na -> Name.print na.binder_name) nas ++ spc () ++ str "|-" ++ spc () ++ + debug_print c + in + v 0 (hv 0 (str"Case " ++ + debug_print c ++ cut () ++ str "as" ++ cut () ++ prlist_with_sep cut debug_print (Array.to_list pms) ++ + cut () ++ str"return"++ cut () ++ pr_ctx p ++ debug_invert iv ++ cut () ++ str"with") ++ cut() ++ + prlist_with_sep (fun _ -> brk(1,2)) pr_ctx (Array.to_list bl) ++ cut() ++ str"end") | Fix f -> debug_print_fix debug_print f | CoFix(i,(lna,tl,bl)) -> @@ -1620,6 +1613,6 @@ let rec debug_print c = and debug_invert = let open Pp in function | NoInvert -> mt() - | CaseInvert {univs;args;} -> - spc() ++ str"Invert {univs=" ++ Instance.pr Level.pr univs ++ - str "; args=" ++ prlist_with_sep spc debug_print (Array.to_list args) ++ str "} " + | CaseInvert {indices;} -> + spc() ++ str"Invert {indices=" ++ + prlist_with_sep spc debug_print (Array.to_list indices) ++ str "} " diff --git a/kernel/constr.mli b/kernel/constr.mli index 62f2555a7e..57dd850ee7 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -49,11 +49,11 @@ type case_info = ci_pp_info : case_printing (* not interpreted by the kernel *) } -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert (** Normal reduction: match when the scrutinee is a constructor. *) - | CaseInvert of { univs : 'univs; args : 'constr array; } + | CaseInvert of { indices : 'constr array; } (** Reduce when the indices match those of the unique constructor. (SProp to non SProp only) *) @@ -152,14 +152,30 @@ val mkRef : GlobRef.t Univ.puniverses -> constr (** Constructs a destructor of inductive type. - [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] + [mkCase ci params p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. - [p] structure is [fun args x -> "return clause"] + + [p] structure is [args x |- "return clause"] [ac]{^ ith} element is ith constructor case presented as - {e lambda construct_args (without params). case_term } *) -val mkCase : case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array -> constr + {e construct_args |- case_term } *) + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +(** Names of the indices + name of self *) + +type 'types pcase_return = Name.t Context.binder_annot array * 'types +(** Names of the branches *) + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array + +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Univ.Instance.t) pcase + +val mkCase : case -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] @@ -243,7 +259,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Ind of (inductive * 'univs) (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) | Construct of (constructor * 'univs) (** A constructor of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) - | Case of case_info * 'constr * ('constr,'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -351,7 +367,7 @@ Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) -val destCase : constr -> case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array +val destCase : constr -> case (** Destructs a projection *) val destProj : constr -> Projection.t * constr @@ -421,12 +437,6 @@ val lift : int -> constr -> constr (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) -(** [map_under_context f l c] maps [f] on the immediate subterms of a - term abstracted over a context of length [n] (local definitions - are counted) *) - -val map_under_context : (constr -> constr) -> int -> constr -> constr - (** [map_branches f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical eta-let-expanded form; it is not recursive and the order with which subterms are processed is @@ -434,7 +444,7 @@ val map_under_context : (constr -> constr) -> int -> constr -> constr types and possibly terms occurring in the context of each branch as well as the body of each branch *) -val map_branches : (constr -> constr) -> case_info -> constr array -> constr array +val map_branches : (constr -> constr) -> case_branch array -> case_branch array (** [map_return_predicate f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical eta-let-expanded form; @@ -443,16 +453,7 @@ val map_branches : (constr -> constr) -> case_info -> constr array -> constr arr the types and possibly terms occurring in the context of each branch as well as the body of the predicate *) -val map_return_predicate : (constr -> constr) -> case_info -> constr -> constr - -(** [map_under_context_with_binders g f n l c] maps [f] on the - immediate subterms of a term abstracted over a context of length - [n] (local definitions are counted); it preserves sharing; it - carries an extra data [n] (typically a lift index) which is - processed by [g] (which typically add 1 to [n]) at each binder - traversal *) - -val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr +val map_return_predicate : (constr -> constr) -> case_return -> case_return (** [map_branches_with_binders f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical @@ -464,7 +465,7 @@ val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> ' occurring in the context of the branch as well as the body of the branch *) -val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array +val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_branch array -> case_branch array (** [map_return_predicate_with_binders f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical @@ -476,26 +477,7 @@ val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> occurring in the context of each branch as well as the body of the predicate *) -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 +val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_return -> case_return (** {6 Functionals working on the immediate subterm of a construction } *) @@ -505,11 +487,7 @@ 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 +val fold_invert : ('a -> 'b -> 'a) -> 'a -> 'b pcase_invert -> 'a (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -517,21 +495,14 @@ val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a val map : (constr -> constr) -> constr -> constr -val map_invert : ('a -> 'a) -> ('a, 'b) case_invert -> ('a, 'b) case_invert - -(** [map_user_view f c] maps [f] on the immediate subterms of [c]; it - differs from [map f c] in that the typing context and body of the - return predicate and of the branches of a [match] are considered as - immediate subterm of a [match] *) - -val map_user_view : (constr -> constr) -> constr -> constr +val map_invert : ('a -> 'a) -> 'a pcase_invert -> 'a pcase_invert (** Like {!map}, but also has an additional accumulator. *) val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr val fold_map_invert : ('a -> 'b -> 'a * 'b) -> - 'a -> ('b, 'c) case_invert -> 'a * ('b, 'c) case_invert + 'a -> 'b pcase_invert -> 'a * 'b pcase_invert (** [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -548,7 +519,7 @@ val map_with_binders : val iter : (constr -> unit) -> constr -> unit -val iter_invert : ('a -> unit) -> ('a, 'b) case_invert -> unit +val iter_invert : ('a -> unit) -> 'a pcase_invert -> unit (** [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -626,8 +597,8 @@ val compare_head_gen_leq : Univ.Instance.t instance_compare_fn -> constr constr_compare_fn -> constr constr_compare_fn -val eq_invert : ('a -> 'a -> bool) -> ('b -> 'b -> bool) - -> ('a, 'b) case_invert -> ('a, 'b) case_invert -> bool +val eq_invert : ('a -> 'a -> bool) + -> 'a pcase_invert -> 'a pcase_invert -> bool (** {6 Hashconsing} *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 3707a75157..f82b754c59 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -75,30 +75,23 @@ let share_univs cache r u l = let (u', args) = share cache r l in mkApp (instantiate_my_gr r (Instance.append u' u), args) -let update_case cache ci iv modlist = - match share cache (IndRef ci.ci_ind) modlist with - | exception Not_found -> ci, iv - | u, l -> - let iv = match iv with - | NoInvert -> NoInvert - | CaseInvert {univs; args;} -> - let univs = Instance.append u univs in - let args = Array.append l args in - CaseInvert {univs; args;} - in - { ci with ci_npar = ci.ci_npar + Array.length l }, iv - let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = let share_univs = share_univs cache in - let update_case = update_case cache in let rec substrec c = match kind c with - | Case (ci,p,iv,t,br) -> - let ci,iv = update_case ci iv modlist in - Constr.map substrec (mkCase (ci,p,iv,t,br)) + | Case (ci, u, pms, p, iv, t, br) -> + begin match share cache (IndRef ci.ci_ind) modlist with + | (u', prefix) -> + let u = Instance.append u' u in + let pms = Array.append prefix pms in + let ci = { ci with ci_npar = ci.ci_npar + Array.length prefix } in + Constr.map substrec (mkCase (ci,u,pms,p,iv,t,br)) + | exception Not_found -> + Constr.map substrec c + end | Ind (ind,u) -> (try 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..1c8575ef05 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -60,127 +60,223 @@ 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) + +module Internal = +struct + +type 'a or_rel = REL of int | VAL of int * 'a + +let to_rel shift = function +| Var i -> REL (i + shift) +| Arg v -> VAL (shift, v) + +let rec get_tree_subst shift accu = function +| Leaf (w, x) -> + to_rel (shift + w) x :: accu +| Node (w, x, l, r, _) -> + let accu = get_tree_subst (shift + w + eval l) accu r in + let accu = get_tree_subst (shift + w) accu l in + to_rel (shift + w) x :: accu + +let rec get_subst shift accu = function +| Nil (w, n) -> + List.init n (fun i -> REL (w + i + shift + 1)) +| Cons (_, t, s) -> + let accu = get_subst (shift + eval t) accu s in + get_tree_subst shift accu t + +let rec get_shift accu = function +| Nil (w, n) -> accu + w + n +| Cons (_, t, s) -> get_shift (eval t + accu) s + +let repr (s : 'a subs) = + let shift = get_shift 0 s in + let subs = get_subst 0 [] s in + subs, shift + +end diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 4239e42adc..b0fbe680c3 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,19 @@ 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 + +(** Debugging utilities *) +module Internal : +sig +type 'a or_rel = REL of int | VAL of int * 'a + +(** High-level representation of a substitution. The first component is a list + that associates a value to an index, and the second component is the + relocation shift that must be applied to any variable pointing outside of + the substitution. *) +val repr : 'a subs -> 'a or_rel list * int +end diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index dc2cd349ce..0e1cd0c56a 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -28,7 +28,6 @@ let opcodes = "ACC7"; "ACC"; "PUSH"; - "PUSHACC0"; "PUSHACC1"; "PUSHACC2"; "PUSHACC3"; @@ -83,8 +82,6 @@ let opcodes = "GETFIELD0"; "GETFIELD1"; "GETFIELD"; - "SETFIELD0"; - "SETFIELD1"; "SETFIELD"; "PROJ"; "ENSURESTACKCAPACITY"; @@ -101,7 +98,6 @@ let opcodes = "ACCUMULATE"; "MAKESWITCHBLOCK"; "MAKEACCU"; - "MAKEPROD"; "BRANCH"; "CHECKADDINT63"; "CHECKADDCINT63"; @@ -121,8 +117,6 @@ let opcodes = "CHECKLSLINT63"; "CHECKLSRINT63"; "CHECKADDMULDIVINT63"; - "CHECKLSLINT63CONST1"; - "CHECKLSRINT63CONST1"; "CHECKEQINT63"; "CHECKLTINT63"; "CHECKLEINT63"; diff --git a/kernel/inductive.ml b/kernel/inductive.ml index e34b3c0b47..eb18d4b90e 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -72,7 +72,7 @@ let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) -let instantiate_params full t u args sign = +let instantiate_params t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch.") in let (rem_args, subs, ty) = @@ -81,8 +81,7 @@ let instantiate_params full t u args sign = match (decl, largs, kind ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> - (largs, (substl subs (subst_instance_constr u b))::subs, t) - | (_,[],_) -> if full then fail() else ([], subs, ty) + (largs, (substl subs (subst_instance_constr u b))::subs, t) | _ -> fail ()) sign ~init:(args,[],t) @@ -93,11 +92,11 @@ let instantiate_params full t u args sign = let full_inductive_instantiate mib u params sign = let dummy = Sorts.prop in let t = Term.mkArity (Vars.subst_instance_context u sign,dummy) in - fst (Term.destArity (instantiate_params true t u params mib.mind_params_ctxt)) + fst (Term.destArity (instantiate_params t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in - instantiate_params true inst_ind u params mib.mind_params_ctxt + instantiate_params inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) @@ -330,36 +329,133 @@ 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 +(** {6 Changes of representation of Case nodes} *) + +(** Provided: + - a universe instance [u] + - a term substitution [subst] + - name replacements [nas] + [instantiate_context u subst nas ctx] applies both [u] and [subst] to [ctx] + while replacing names using [nas] (order reversed) +*) +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> assert (Int.equal i (-1)); [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + instantiate (Array.length nas - 1) ctx + +let expand_case_specif mib (ci, u, params, p, iv, c, br) = + (* Γ ⊢ c : I@{u} params args *) + (* Γ, indices, self : I@{u} params indices ⊢ p : Type *) + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + (* Expand the return clause *) + let ep = + let (nas, p) = p in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ci.ci_ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + Term.it_mkLambda_or_LetIn p realdecls + in + (* Expand the branches *) + let subst = paramsubst @ ind_subst (fst ci.ci_ind) mib u in + let ebr = + let build_one_branch i (nas, br) (ctx, _) = + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let ctx = instantiate_context u subst nas ctx in + Term.it_mkLambda_or_LetIn br ctx + in + Array.map2_i build_one_branch br mip.mind_nf_lc + in + (ci, ep, iv, c, ebr) + +let expand_case env (ci, _, _, _, _, _, _ as case) = + let specif = Environ.lookup_mind (fst ci.ci_ind) env in + expand_case_specif specif case + +let contract_case env (ci, p, iv, c, br) = + let (mib, mip) = lookup_mind_specif env ci.ci_ind in + let (arity, p) = Term.decompose_lam_n_decls (mip.mind_nrealdecls + 1) p in + let (u, pms) = match arity with + | LocalAssum (_, ty) :: _ -> + (** Last binder is the self binder for the term being eliminated *) + let (ind, args) = decompose_appvect ty in + let (ind, u) = destInd ind in + let () = assert (Ind.CanOrd.equal ind ci.ci_ind) in + let pms = Array.sub args 0 mib.mind_nparams in + (** Unlift the parameters from under the index binders *) + let dummy = List.make mip.mind_nrealdecls mkProp in + let pms = Array.map (fun c -> Vars.substl dummy c) pms in + (u, pms) + | _ -> assert false + in + let p = + let nas = Array.of_list (List.rev_map get_annot arity) in + (nas, p) + in + let map i br = + let (ctx, br) = Term.decompose_lam_n_decls mip.mind_consnrealdecls.(i) br in + let nas = Array.of_list (List.rev_map get_annot ctx) in + (nas, br) + in + (ci, u, pms, p, iv, c, Array.mapi map br) (************************************************************************) (* Type of case branches *) @@ -387,17 +483,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 *) @@ -782,7 +877,8 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv - | Case (ci,p,_iv,c,lbr) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, p, iv, c, lbr) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c, lbr) = expand_case renv.env (ci, u, pms, p, iv, c, lbr) in let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci @@ -1007,7 +1103,8 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(lift p c,l)) end - | Case (ci,p,iv,c_0,lrest) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, ret, iv, c_0, br) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c_0, lrest) = expand_case renv.env (ci, u, pms, ret, iv, c_0, br) in begin try List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg info for the arguments of each branch *) @@ -1029,7 +1126,7 @@ let check_one_fix renv recpos trees def = (* the call to whd_betaiotazeta will reduce the apparent iota redex away *) check_rec_call renv [] - (Term.applist (mkCase (ci,p,iv,c_0,lrest), l)) + (Term.applist (mkCase (ci, u, pms, ret, iv, c_0, br), l)) | _ -> Exninfo.iraise exn end @@ -1313,13 +1410,14 @@ let check_one_cofix env nbfix def deftype = else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) - | Case (_,p,_,tm,vrest) -> (* iv ignored: just a cache *) - begin - let tree = match restrict_spec env (Subterm (Strict, tree)) p with - | Dead_code -> assert false - | Subterm (_, tree') -> tree' - | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) - in + | Case (ci, u, pms, p, iv, tm, br) -> (* iv ignored: just a cache *) + begin + let (_, p, _iv, tm, vrest) = expand_case env (ci, u, pms, p, iv, tm, br) in + let tree = match restrict_spec env (Subterm (Strict, tree)) p with + | Dead_code -> assert false + | Subterm (_, tree') -> tree' + | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 78658dc4de..5808a3fa65 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -79,6 +79,23 @@ val arities_of_specif : MutInd.t puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int +(** Given a pattern-matching represented compactly, expands it so as to produce + lambda and let abstractions in front of the return clause and the pattern + branches. *) +val expand_case : env -> case -> (case_info * constr * case_invert * constr * constr array) + +val expand_case_specif : mutual_inductive_body -> case -> (case_info * constr * case_invert * constr * constr array) + +(** Dual operation of the above. Fails if the return clause or branch has not + the expected form. *) +val contract_case : env -> (case_info * constr * case_invert * constr * constr array) -> case + +(** [instantiate_context u subst nas ctx] applies both [u] and [subst] + to [ctx] while replacing names using [nas] (order reversed). In particular, + assumes that [ctx] and [nas] have the same length. *) +val instantiate_context : Instance.t -> Vars.substl -> Name.t Context.binder_annot array -> + rel_context -> rel_context + (** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression: <p>Cases (c :: (I args)) of b1..bn end diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index d02f92ef26..50c3ba1cc6 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -198,7 +198,9 @@ let rec infer_fterm cv_pb infos variances hd stk = let variances = infer_vect infos variances elems in infer_stack infos variances stk - | FCaseInvert (_,p,_,_,br,e) -> + | FCaseInvert (ci, u, pms, p, _, _, br, e) -> + let mib = Environ.lookup_mind (fst ci.ci_ind) (info_env (fst infos)) in + let (_, p, _, _, br) = Inductive.expand_case_specif mib (ci, u, pms, p, NoInvert, mkProp, br) in let infer c variances = infer_fterm CONV infos variances (mk_clos e c) [] in let variances = infer p variances in Array.fold_right infer br variances @@ -217,7 +219,10 @@ and infer_stack infos variances (stk:CClosure.stack) = | Zfix (fx,a) -> let variances = infer_fterm CONV infos variances fx [] in infer_stack infos variances a - | ZcaseT (_, p, br, e) -> + | ZcaseT (ci,u,pms,p,br,e) -> + let dummy = mkProp in + let case = (ci, u, pms, p, NoInvert, dummy, br) in + let (_, p, _, _, br) = Inductive.expand_case (info_env (fst infos)) case in let variances = infer_fterm CONV infos variances (mk_clos e p) [] in infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 5b2a7bd9c2..75fd70d923 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -31,6 +31,8 @@ Primred CClosure Relevanceops Reduction +Type_errors +Inductive Vmlambda Nativelambda Vmbytegen @@ -40,9 +42,7 @@ Vmsymtable Vm Vconv Nativeconv -Type_errors Modops -Inductive Typeops InferCumulativity IndTyping diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2aeb1ea202..c5ac57a2cd 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -340,15 +340,6 @@ let subst_retro_action subst action = let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') -(* Here the semantics is completely unclear. - What does "Hint Unfold t" means when "t" is a parameter? - Does the user mean "Unfold X.t" or does she mean "Unfold y" - where X.t is later on instantiated with y? I choose the first - interpretation (i.e. an evaluable reference is never expanded). *) -let subst_evaluable_reference subst = function - | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) - let rec map_kn f f' c = let func = map_kn f f' in match kind c with @@ -364,21 +355,26 @@ let rec map_kn f f' c = | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else mkConstructU (((kn',i),j),u) - | Case (ci,p,iv,ct,l) -> + | Case (ci,u,pms,p,iv,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in - let p' = func p in + let f_ctx (nas, c as d) = + let c' = func c in + if c' == c then d else (nas, c') + in + let pms' = Array.Smart.map func pms in + let p' = f_ctx p in let iv' = map_invert func iv in let ct' = func ct in - let l' = Array.Smart.map func l in - if (ci.ci_ind==ci_ind && p'==p && iv'==iv + let l' = Array.Smart.map f_ctx l in + if (ci.ci_ind==ci_ind && pms'==pms && p'==p && iv'==iv && l'==l && ct'==ct)then c else - mkCase ({ci with ci_ind = ci_ind}, - p',iv',ct', l') + mkCase ({ci with ci_ind = ci_ind}, u, + pms',p',iv',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index bc5816dafb..9cf270cff7 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -146,14 +146,6 @@ val subst_proj : substitution -> Projection.t -> Projection.t val subst_retro_action : substitution -> Retroknowledge.action -> Retroknowledge.action -(** Here the semantics is completely unclear. - What does "Hint Unfold t" means when "t" is a parameter? - Does the user mean "Unfold X.t" or does she mean "Unfold y" - where X.t is later on instantiated with y? I choose the first - interpretation (i.e. an evaluable reference is never expanded). *) -val subst_evaluable_reference : - substitution -> evaluable_global_reference -> evaluable_global_reference - (** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) val replace_mp_in_kn : ModPath.t -> ModPath.t -> KerName.t -> KerName.t diff --git a/kernel/names.ml b/kernel/names.ml index 13761ca245..60c6c7bd67 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1100,18 +1100,10 @@ module GlobRef = struct end -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -(* Better to have it here that in closure, since used in grammar.cma *) -let eq_egr e1 e2 = match e1, e2 with - EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 - | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 - | _, _ -> false - (** Located identifiers and objects with syntax. *) 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..09885396c0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -714,16 +714,10 @@ module GlobRef : sig end -(** Better to have it here that in Closure, since required in grammar.cma *) -(* XXX: Move to a module *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool - (** Located identifiers and objects with syntax. *) 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/nativecode.ml b/kernel/nativecode.ml index 09db29d222..c19b883e3d 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -2101,7 +2101,7 @@ let compile_deps env sigma prefix init t = | Proj (p,c) -> let init = compile_mind_deps env prefix init (Projection.mind p) in aux env lvl init c - | Case (ci, _p, _iv, _c, _ac) -> + | Case (ci, _u, _pms, _p, _iv, _c, _ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix init mind in fold_constr_with_binders succ (aux env) lvl init t diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 18f16f427d..f3b483467d 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 *) @@ -535,7 +535,8 @@ let rec lambda_of_constr cache env sigma c = let prefix = get_mind_prefix env (fst ind) in mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env (ci, u, pms, t, iv, a, br) in let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index cf40263f61..1e39756d47 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -56,7 +56,7 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj _p1::s1, Zproj _p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | (ZcaseT(_c1,_,_,_)::s1, ZcaseT(_c2,_,_,_)::s2) -> + | (ZcaseT(_c1,_,_,_,_,_)::s1, ZcaseT(_c2,_,_,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -74,7 +74,7 @@ type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack - | Zlcase of case_info * lift * constr * constr array * fconstr subs + | Zlcase of case_info * lift * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zlprimitive of CPrimitives.t * pconstant * lft_fconstr list * lft_fconstr next_native_args and lft_constr_stack = lft_constr_stack_elt list @@ -109,8 +109,8 @@ let pure_stack lfts stk = | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) - | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,p,br,e)::pstk) + | (ZcaseT(ci,u,pms,p,br,e),(l,pstk)) -> + (l,Zlcase(ci,l,u,pms,p,br,e)::pstk) | (Zprimitive(op,c,rargs,kargs),(l,pstk)) -> (l,Zlprimitive(op,c,List.map (fun t -> (l,t)) rargs, List.map (fun (k,t) -> (k,(l,t))) kargs)::pstk)) @@ -233,6 +233,9 @@ let convert_instances ~flex u u' (s, check) = exception MustExpand +let convert_instances_cumul pb var u u' (s, check) = + (check.compare_cumul_instances pb var u u' s, check) + let get_cumulativity_constraints cv_pb variance u u' = match cv_pb with | CONV -> @@ -294,8 +297,6 @@ let conv_table_key infos ~nargs k1 k2 cuniv = | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible -exception IrregularPatternShape - let unfold_ref_with_args infos tab fl v = match unfold_reference infos tab fl with | Def def -> Some (def, v) @@ -327,17 +328,6 @@ let push_relevance infos r = let push_relevances infos nas = { infos with cnv_inf = CClosure.push_relevances infos.cnv_inf nas } -let rec skip_pattern infos relevances n c1 c2 = - if Int.equal n 0 then {infos with cnv_inf = CClosure.set_info_relevances infos.cnv_inf relevances}, c1, c2 - else match kind c1, kind c2 with - | Lambda (x, _, c1), Lambda (_, _, c2) -> - skip_pattern infos (Range.cons x.Context.binder_relevance relevances) (pred n) c1 c2 - | _ -> raise IrregularPatternShape - -let skip_pattern infos n c1 c2 = - if Int.equal n 0 then infos, c1, c2 - else skip_pattern infos (info_relevances infos.cnv_inf) n c1 c2 - let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false @@ -364,6 +354,39 @@ let eta_expand_constructor env ((ind,ctor),u as pctor) = let c = Term.it_mkLambda_or_LetIn c ctx in inject c +let inductive_subst (mind, _) mib u pms = + let open Context.Rel.Declaration in + let ntypes = mib.mind_ntypes in + let rec self i accu = + if Int.equal i ntypes then accu + else self (i + 1) (subs_cons (inject (mkIndU ((mind, i), u))) accu) + in + let accu = self 0 (subs_id 0) in + let rec mk_pms pms ctx = match ctx, pms with + | [], [] -> accu + | LocalAssum _ :: ctx, c :: pms -> + let subs = mk_pms pms ctx in + subs_cons c subs + | LocalDef (_, c, _) :: ctx, pms -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms pms ctx in + subs_cons (mk_clos subs c) subs + | LocalAssum _ :: _, [] | [], _ :: _ -> assert false + in + mk_pms (List.rev pms) mib.mind_params_ctxt + +let esubst_of_rel_context_instance ctx u args e = + let open Context.Rel.Declaration in + let rec aux lft e args ctx = match ctx with + | [] -> lft, e + | LocalAssum _ :: ctx -> aux (lft + 1) (subs_lift e) (subs_lift args) ctx + | LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let c = mk_clos args c in + aux lft (subs_cons c e) (subs_cons c args) ctx + in + aux 0 e args (List.rev ctx) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -672,13 +695,23 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if Float64.equal f1 f2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> + | FCaseInvert (ci1,u1,pms1,p1,_,_,br1,e1), FCaseInvert (ci2,u2,pms2,p2,_,_,br2,e2) -> (if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible); let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in - let ccnv = ccnv CONV l2r infos el1 el2 in - let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in - Array.fold_right2 (fun b1 b2 cuniv -> ccnv (mk_clos e1 b1) (mk_clos e2 b2) cuniv) - br1 br2 cuniv + let fold c1 c2 cuniv = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cuniv = + let ind = (mind,snd ci1.ci_ind) in + let nargs = inductive_cumulativity_arguments ind in + convert_inductives CONV ind nargs u1 u2 cuniv + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let cuniv = List.fold_right2 fold pms1 pms2 cuniv in + let cuniv = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 p1 p2 cuniv in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 br1 br2 cuniv | FArray (u1,t1,ty1), FArray (u2,t2,ty2) -> let len = Parray.length_int t1 in @@ -714,11 +747,27 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 - | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> + | (Zlcase(ci1,l1,u1,pms1,p1,br1,e1),Zlcase(ci2,l2,u2,pms2,p2,br2,e2)) -> if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible; - let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in - convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 + let cu = cu1 in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cu = + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + convert_instances ~flex:false u1 u2 cu + else + match mind.Declarations.mind_variance with + | None -> convert_instances ~flex:false u1 u2 cu + | Some variances -> convert_instances_cumul CONV variances u1 u2 cu + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let fold_params c1 c2 accu = f (l1, c1) (l2, c2) accu in + let cu = List.fold_right2 fold_params pms1 pms2 cu in + let cu = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 br1 br2 cu | (Zlprimitive(op1,_,rargs1,kargs1),Zlprimitive(op2,_,rargs2,kargs2)) -> if not (CPrimitives.equal op1 op2) then raise NotConvertible else let cu2 = List.fold_right2 f rargs1 rargs2 cu1 in @@ -743,21 +792,55 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible -and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = - (** Skip comparison of the pattern types. We know that the two terms are - living in a common type, thus this check is useless. *) - let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with - | (infos, c1, c2) -> - let lft1 = el_liftn n lft1 in - let lft2 = el_liftn n lft2 in +and convert_under_context l2r infos e1 e2 lft1 lft2 ctx (nas1, c1) (nas2, c2) cu = + let n = Array.length nas1 in + let () = assert (Int.equal n (Array.length nas2)) in + let n, e1, e2 = match ctx with + | None -> (* nolet *) let e1 = subs_liftn n e1 in let e2 = subs_liftn n e2 in - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv - | exception IrregularPatternShape -> - (** Might happen due to a shape invariant that is not enforced *) - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + (n, e1, e2) + | Some (ctx, u1, u2, args1, args2) -> + let n1, e1 = esubst_of_rel_context_instance ctx u1 args1 e1 in + let n2, e2 = esubst_of_rel_context_instance ctx u2 args2 e2 in + let () = assert (Int.equal n1 n2) in + n1, e1, e2 + in + let lft1 = el_liftn n lft1 in + let lft2 = el_liftn n lft2 in + let infos = push_relevances infos nas1 in + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cu + +and convert_return_clause ind mib mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu = + let ctx = + if Int.equal mip.mind_nrealargs mip.mind_nrealdecls then None + else + let ctx, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u1 pms2 in + let open Context.Rel.Declaration in + (* Add the inductive binder *) + let dummy = mkProp in + let ctx = LocalAssum (Context.anonR, dummy) :: ctx in + Some (ctx, u1, u2, pms1, pms2) + in + convert_under_context l2r infos e1 e2 l1 l2 ctx p1 p2 cu + +and convert_branches ind mib mip l2r infos e1 e2 lft1 lft2 u1 u2 pms1 pms2 br1 br2 cuniv = + let fold i (ctx, _) cuniv = + let ctx = + if Int.equal mip.mind_consnrealdecls.(i) mip.mind_consnrealargs.(i) then None + else + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u2 pms2 in + Some (ctx, u1, u2, pms1, pms2) + in + let c1 = br1.(i) in + let c2 = br2.(i) in + convert_under_context l2r infos e1 e2 lft1 lft2 ctx c1 c2 cuniv in - Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv + Array.fold_right_i fold mip.mind_nf_lc cuniv and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with | [], [] -> cuniv diff --git a/kernel/relevanceops.ml b/kernel/relevanceops.ml index f12b8cba37..986fc685d1 100644 --- a/kernel/relevanceops.ml +++ b/kernel/relevanceops.ml @@ -61,7 +61,7 @@ let rec relevance_of_fterm env extra lft f = | FProj (p, _) -> relevance_of_projection env p | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance - | FCaseT (ci, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _) -> ci.ci_relevance + | FCaseT (ci, _, _, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _, _, _) -> ci.ci_relevance | FLambda (len, tys, bdy, e) -> let extra = List.fold_left (fun accu (x, _) -> Range.cons (binder_relevance x) accu) extra tys in let lft = Esubst.el_liftn len lft in @@ -97,7 +97,7 @@ and relevance_of_term_extra env extra lft subs c = | App (c, _) -> relevance_of_term_extra env extra lft subs c | Const (c,_) -> relevance_of_constant env c | Construct (c,_) -> relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> relevance_of_projection env p 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..741491c917 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) @@ -548,22 +548,26 @@ let rec execute env cstr = | Construct c -> cstr, type_of_constructor env c - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + (** FIXME: change type_of_case to handle the compact form *) + let (ci, p, iv, c, lf) = expand_case env (ci, u, pms, p, iv, c, lf) in let c', ct = execute env c in let iv' = match iv with | NoInvert -> NoInvert - | CaseInvert {univs;args} -> - let ct' = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let ct' = mkApp (mkIndU (ci.ci_ind,u), args) in let (ct', _) : constr * Sorts.t = execute_is_type env ct' in let () = conv_leq false env ct ct' in let _, args' = decompose_appvect ct' in - if args == args' then iv else CaseInvert {univs;args=args'} + if args == args' then iv + else CaseInvert {indices=Array.sub args' (Array.length pms) (Array.length indices)} in let p', pt = execute env p in let lf', lft = execute_array env lf in let ci', t = type_of_case env ci p' pt iv' c' ct lf' lft in let cstr = if ci == ci' && c == c' && p == p' && iv == iv' && lf == lf' then cstr - else mkCase(ci',p',iv',c',lf') + else mkCase (Inductive.contract_case env (ci',p',iv',c',lf')) in cstr, t @@ -720,11 +724,6 @@ let judge_of_inductive env indu = let judge_of_constructor env cu = make_judge (mkConstructU cu) (type_of_constructor env cu) -let judge_of_case env ci pj iv cj lfj = - let lf, lft = dest_judgev lfj in - let ci, t = type_of_case env ci pj.uj_val pj.uj_type iv cj.uj_val cj.uj_type lf lft in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, iv, cj.uj_val, lft)) t - (* Building type of primitive operators and type *) let type_of_prim_const env _u c = diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d381e55dd6..5ea7163f72 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -92,12 +92,6 @@ val judge_of_cast : val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment -(** {6 Type of Cases. } *) -val judge_of_case : env -> case_info - -> unsafe_judgment -> (constr,Instance.t) case_invert -> unsafe_judgment - -> unsafe_judgment array - -> unsafe_judgment - (** {6 Type of global references. } *) val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 096e458ec4..b988ec40a7 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -222,15 +222,35 @@ let choose p g u = if Level.is_sprop u then if p u then Some u else None else G.choose p g.graph u -let dump_universes f g = G.dump f g.graph - let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph -let pr_universes prl g = G.pr prl g.graph - -let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] -let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) -let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g +(** Pretty-printing *) + +let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Level.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (LMap.bindings map)) + +let pr_arc prl = let open Pp in + function + | u, G.Node ltle -> + if LMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, G.Alias v -> + prl u ++ str " = " ++ prl v ++ fnl () + +type node = G.node = +| Alias of Level.t +| Node of bool LMap.t + +let repr g = G.repr g.graph + +let pr_universes prl g = pr_pmap Pp.mt (pr_arc prl) g (** Profiling *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 87b3634e28..9ac29f5139 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -77,15 +77,9 @@ exception UndeclaredLevel of Univ.Level.t val check_declared_universes : t -> Univ.LSet.t -> unit -(** {6 Pretty-printing of universes. } *) - -val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t - (** The empty graph of universes *) val empty_universes : t -val sort_universes : t -> t - (** [constraints_of_universes g] returns [csts] and [partition] where [csts] are the non-Eq constraints and [partition] is the partition of the universes into equivalence classes. *) @@ -108,10 +102,17 @@ val check_subtype : lbound:Bound.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) -(** {6 Dumping to a file } *) +(** {6 Dumping} *) + +type node = +| Alias of Level.t +| Node of bool LMap.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + +val repr : t -> node LMap.t + +(** {6 Pretty-printing of universes. } *) -val dump_universes : - (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit +val pr_universes : (Level.t -> Pp.t) -> node LMap.t -> Pp.t (** {6 Debugging} *) val check_universes_invariants : t -> unit 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..4f2cbc4262 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) @@ -212,9 +206,7 @@ let () = Callback.register "uint63 leq" le; Callback.register "uint63 lor" l_or; Callback.register "uint63 lsl" l_sl; - Callback.register "uint63 lsl1" (fun x -> l_sl x Int64.one); Callback.register "uint63 lsr" l_sr; - Callback.register "uint63 lsr1" (fun x -> l_sr x Int64.one); Callback.register "uint63 lt" lt; Callback.register "uint63 lxor" l_xor; Callback.register "uint63 mod" rem; 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/vars.ml b/kernel/vars.ml index a446fa413c..b09577d4db 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -253,12 +253,20 @@ let subst_univs_level_constr subst c = if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - if Univ.Instance.is_empty univs then Constr.map aux t + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t else - let univs' = f univs in - if univs' == univs then Constr.map aux t - else (changed:=true; Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br))) + let u' = f u in + if u' == u then Constr.map aux t + else (changed:=true; Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br))) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + (changed := true; Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br))) | Array (u,elems,def,ty) -> let u' = f u in @@ -305,10 +313,18 @@ let subst_instance_constr subst c = if u' == u then t else (mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - let univs' = f univs in - if univs' == univs then Constr.map aux t - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br)) + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + let u' = f u in + if u' == u then Constr.map aux t + else Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br)) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br)) | Array (u,elems,def,ty) -> let u' = f u in @@ -348,8 +364,8 @@ let universes_of_constr c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels univs) s in + | Case (_, u, _, _, _,_ ,_) -> + let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index 4977aec00a..c2b087f061 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -49,7 +49,6 @@ type instruction = | Kgetglobal of Constant.t | Kconst of structured_constant | Kmakeblock of int * tag - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array | Kpushfields of int @@ -123,7 +122,6 @@ let rec pp_instr i = str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> str "makeblock " ++ int n ++ str ", " ++ int m - | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index 003a77ab78..eeca0d2ad1 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -47,7 +47,6 @@ type instruction = | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from ** the top of the stack *) - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 70c92fd8f0..20de4bc81b 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -569,7 +569,7 @@ let rec compile_lam env cenv lam sz cont = | Lprod (dom,codom) -> let cont1 = - Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in + Kpush :: compile_lam env cenv dom (sz+1) (Kmakeblock (2,0) :: cont) in compile_lam env cenv codom sz cont1 | Llam (ids,body) -> diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index c1d8fcb855..d3af8bf09b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -135,6 +135,16 @@ let out env opcode = let is_immed i = Uint63.le (Uint63.of_int i) Uint63.maxuint31 +(* Detect whether the current value of the accu register is no longer + needed (i.e., the register is written before being read). If so, the + register can be used freely; no need to save and restore it. *) +let is_accu_dead = function + | [] -> false + | c :: _ -> + match c with + | Kacc _ | Kenvacc _ | Kconst _ | Koffsetclosure _ | Kgetglobal _ -> true + | _ -> false + let out_int env n = out_word env n (n asr 8) (n asr 16) (n asr 24) @@ -327,8 +337,6 @@ let emit_instr env = function if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" else if n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) else (out env opMAKEBLOCK; out_int env n; out_int env t) - | Kmakeprod -> - out env opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out env opMAKESWITCHBLOCK; out_label env typlbl; out_label env swlbl; @@ -349,8 +357,7 @@ let emit_instr env = function if n <= 1 then out env (opGETFIELD0+n) else (out env opGETFIELD;out_int env n) | Ksetfield n -> - if n <= 1 then out env (opSETFIELD0+n) - else (out env opSETFIELD;out_int env n) + out env opSETFIELD; out_int env n | Ksequence _ -> invalid_arg "Vmemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size @@ -375,7 +382,9 @@ let rec emit env insns remaining = match insns with | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> - if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); + if n = 0 then out env opPUSH + else if n < 8 then out env (opPUSHACC1 + n - 1) + else (out env opPUSHACC; out_int env n); emit env c remaining | Kpush :: Kenvacc n :: c -> if n >= 0 && n <= 3 @@ -397,6 +406,9 @@ let rec emit env insns remaining = match insns with | Kpush :: Kconst const :: c -> out env opPUSHGETGLOBAL; slot_for_const env const; emit env c remaining + | Kpushfields 1 :: c when is_accu_dead c -> + out env opGETFIELD0; + emit env (Kpush :: c) remaining | Kpop n :: Kjump :: c -> out env opRETURN; out_int env n; emit env c remaining | Ksequence c1 :: c -> diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 9cca204e8c..91de58b0e6 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 *) @@ -674,7 +674,8 @@ let rec lambda_of_constr env c = | Construct _ -> lambda_of_app env c empty_args - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env.global_env (ci, u, pms, t, iv, a, br) in let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.global_env in let oib = mib.mind_packets.(snd ind) in diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index 8da09dc98a..17299c72eb 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -58,15 +58,59 @@ module Make (Point:Point) = struct *) - module PMap = Point.Map - module PSet = Point.Set + module Index : + sig + type t + val equal : t -> t -> bool + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + type table + val empty : table + val fresh : Point.t -> table -> t * table + val mem : Point.t -> table -> bool + val find : Point.t -> table -> t + val repr : t -> table -> Point.t + end = + struct + type t = int + let equal = Int.equal + module Set = Int.Set + module Map = Int.Map + + type table = { + tab_len : int; + tab_fwd : Point.t Int.Map.t; + tab_bwd : int Point.Map.t + } + + let empty = { + tab_len = 0; + tab_fwd = Int.Map.empty; + tab_bwd = Point.Map.empty; + } + let mem x t = Point.Map.mem x t.tab_bwd + let find x t = Point.Map.find x t.tab_bwd + let repr n t = Int.Map.find n t.tab_fwd + + let fresh x t = + let () = assert (not @@ mem x t) in + let n = t.tab_len in + n, { + tab_len = n + 1; + tab_fwd = Int.Map.add n x t.tab_fwd; + tab_bwd = Point.Map.add x n t.tab_bwd; + } + end + + module PMap = Index.Map + module PSet = Index.Set module Constraint = Point.Constraint type status = NoMark | Visited | WeakVisited | ToMerge (* Comparison on this type is pointer equality *) type canonical_node = - { canon: Point.t; + { canon: Index.t; ltle: bool PMap.t; (* true: strict (lt) constraint. false: weak (le) constraint. *) gtge: PSet.t; @@ -76,19 +120,18 @@ module Make (Point:Point) = struct mutable status: status } - let big_rank = 1000000 - (* A Point.t is either an alias for another one, or a canonical one, for which we know the points that are above *) type entry = | Canonical of canonical_node - | Equiv of Point.t + | Equiv of Index.t type t = { entries : entry PMap.t; index : int; - n_nodes : int; n_edges : int } + n_nodes : int; n_edges : int; + table : Index.table } (** Used to cleanup mutable marks if a traversal function is interrupted before it has the opportunity to do it itself. *) @@ -123,7 +166,8 @@ module Make (Point:Point) = struct | _ -> assert false) g.entries; index = g.index; n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } + n_edges = g.n_edges; + table = g.table } (* Low-level function : changes data associated with a canonical node. Resets the mutable fields in the old record, in order to avoid breaking @@ -147,7 +191,10 @@ module Make (Point:Point) = struct | Canonical arc -> arc | exception Not_found -> CErrors.anomaly ~label:"Univ.repr" - Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + Pp.(str"Universe " ++ Point.pr (Index.repr u g.table) ++ str" undefined.") + + let repr_node g u = + repr g (Index.find u g.table) exception AlreadyDeclared @@ -158,30 +205,6 @@ module Make (Point:Point) = struct assert (g.index > min_int); { g with index = g.index - 1 } - (* [safe_repr] is like [repr] but if the graph doesn't contain the - searched point, we add it. *) - let safe_repr g u = - let rec safe_repr_rec entries u = - match PMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { canon = u; - ltle = PMap.empty; gtge = PSet.empty; - rank = 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = PMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - (* Returns 1 if u is higher than v in topological order. -1 lower 0 if u = v *) @@ -194,6 +217,7 @@ module Make (Point:Point) = struct (* Checks most of the invariants of the graph. For debugging purposes. *) let check_invariants ~required_canonical g = + let required_canonical u = required_canonical (Index.repr u g.table) in let n_edges = ref 0 in let n_nodes = ref 0 in PMap.iter (fun l u -> @@ -214,7 +238,7 @@ module Make (Point:Point) = struct PMap.exists (fun l _ -> u == repr g l) v.ltle)) ) u.gtge; assert (u.status = NoMark); - assert (Point.equal l u.canon); + assert (Index.equal l u.canon); assert (u.ilvl > g.index); assert (not (PMap.mem u.canon u.ltle)); incr n_nodes @@ -226,7 +250,7 @@ module Make (Point:Point) = struct let clean_ltle g ltle = PMap.fold (fun u strict acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else ( let acc = PMap.remove u (fst acc) in if not strict && PMap.mem uu acc then (acc, true) @@ -236,7 +260,7 @@ module Make (Point:Point) = struct let clean_gtge g gtge = PSet.fold (fun u acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else PSet.add uu (PSet.remove u (fst acc)), true) gtge (gtge, false) @@ -340,7 +364,7 @@ module Make (Point:Point) = struct | Visited -> false, to_revert | ToMerge -> true, to_revert | NoMark -> let to_revert = x::to_revert in - if Point.equal x.canon v then + if Index.equal x.canon v then begin x.status <- ToMerge; true, to_revert end else begin @@ -451,7 +475,7 @@ module Make (Point:Point) = struct (* Inserting shortcuts for old nodes. *) let g = List.fold_left (fun g n -> - if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + if Index.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) g to_merge in @@ -507,11 +531,10 @@ module Make (Point:Point) = struct raise e let add ?(rank=0) v g = - try - let _arcv = PMap.find v g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); + if Index.mem v g.table then raise AlreadyDeclared + else + let () = assert (g.index > min_int) in + let v, table = Index.fresh v g.table in let node = { canon = v; ltle = PMap.empty; @@ -523,17 +546,18 @@ module Make (Point:Point) = struct } in let entries = PMap.add v (Canonical node) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges; table } exception Undeclared of Point.t let check_declared g us = - let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in - PSet.iter check us + let check l = if not (Index.mem l g.table) then raise (Undeclared l) in + Point.Set.iter check us exception Found_explanation of (constraint_type * Point.t) list let get_explanation strict u v g = - let v = repr g v in + let u = Index.find u g.table in + let v = repr_node g v in let visited_strict = ref PMap.empty in let rec traverse strict u = if u == v then @@ -553,6 +577,7 @@ module Make (Point:Point) = struct | None -> () | Some exp -> let typ = if strictu' then Lt else Le in + let u' = Index.repr u' g.table in raise (Found_explanation ((typ, u') :: exp))) u.ltle; None @@ -560,7 +585,7 @@ module Make (Point:Point) = struct end in let u = repr g u in - if u == v then [(Eq, v.canon)] + if u == v then [(Eq, Index.repr v.canon g.table)] else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = @@ -634,21 +659,27 @@ module Make (Point:Point) = struct let check_eq g u v = u == v || - let arcu = repr g u and arcv = repr g v in + let arcu = repr_node g u and arcv = repr_node g v in arcu == arcv let check_smaller g strict u v = - search_path strict (repr g u) (repr g v) g + search_path strict (repr_node g u) (repr_node g v) g let check_leq g u v = check_smaller g false u v let check_lt g u v = check_smaller g true u v (* enforce_eq g u v will force u=v if possible, will fail otherwise *) - let rec enforce_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_eq v u g + let enforce_eq u v g = + let ucan = repr_node g u in + let vcan = repr_node g v in + if ucan == vcan then g + else if topo_compare ucan vcan = 1 then + let ucan = vcan and vcan = ucan in + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true v u g) else let g = insert_edge false ucan vcan g in (* Cannot fail *) try insert_edge false vcan ucan g @@ -657,58 +688,40 @@ module Make (Point:Point) = struct (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_leq u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge false ucan vcan g with CycleDetected -> Point.error_inconsistency Le u v (get_explanation true v u g) (* enforce_lt u v will force u<v if possible, will fail otherwise *) let enforce_lt u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge true ucan vcan g with CycleDetected -> Point.error_inconsistency Lt u v (get_explanation false v u g) let empty = - { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0; table = Index.empty } (* Normalization *) - (** [normalize g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) - let normalize g = - let g = - { g with - entries = PMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).canon) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - PMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - let constraints_of g = - let module UF = Unionfind.Make (PSet) (PMap) in + let module UF = Unionfind.Make (Point.Set) (Point.Map) in let uf = UF.create () in let constraints_of u v acc = match v with | Canonical {canon=u; ltle; _} -> PMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in + let u = Index.repr u g.table in + let v = Index.repr v g.table in Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc + | Equiv v -> + let u = Index.repr u g.table in + let v = Index.repr v g.table in + UF.union u v uf; acc in let csts = PMap.fold constraints_of g.entries Constraint.empty in csts, UF.partition uf @@ -716,16 +729,20 @@ module Make (Point:Point) = struct (* domain g.entries = kept + removed *) let constraints_for ~kept g = (* rmap: partial map from canonical points to kept points *) + let add_cst u knd v cst = + Constraint.add (Index.repr u g.table, knd, Index.repr v g.table) cst + in + let kept = Point.Set.fold (fun u accu -> PSet.add (Index.find u g.table) accu) kept PSet.empty in let rmap, csts = PSet.fold (fun u (rmap,csts) -> let arcu = repr g u in if PSet.mem arcu.canon kept then - let csts = if Point.equal u arcu.canon then csts - else Constraint.add (u,Eq,arcu.canon) csts + let csts = if Index.equal u arcu.canon then csts + else add_cst u Eq arcu.canon csts in PMap.add arcu.canon arcu.canon rmap, csts else match PMap.find arcu.canon rmap with - | v -> rmap, Constraint.add (u,Eq,v) csts + | v -> rmap, add_cst u Eq v csts | exception Not_found -> PMap.add arcu.canon u rmap, csts) kept (PMap.empty,Constraint.empty) in @@ -736,7 +753,7 @@ module Make (Point:Point) = struct (match PMap.find v.canon rmap with | v -> let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in + let csts = add_cst u d v csts in add_from u csts todo | exception Not_found -> (* v is not equal to any kept point *) @@ -752,102 +769,42 @@ module Make (Point:Point) = struct arc.ltle csts) kept csts - let domain g = PMap.domain g.entries + let domain g = + let fold u _ accu = Point.Set.add (Index.repr u g.table) accu in + PMap.fold fold g.entries Point.Set.empty let choose p g u = let exception Found of Point.t in - let ru = (repr g u).canon in - if p ru then Some ru + let ru = (repr_node g u).canon in + let ruv = Index.repr ru g.table in + if p ruv then Some ruv else try PMap.iter (fun v -> function | Canonical _ -> () (* we already tried [p ru] *) | Equiv v' -> let rv = (repr g v').canon in - if rv == ru && p v then raise (Found v) + if rv == ru then + let v = Index.repr v g.table in + if p v then raise (Found v) (* NB: we could also try [p v'] but it will come up in the rest of the iteration regardless. *) ) g.entries; None with Found v -> Some v - let sort make_dummy first g = - let cans = - PMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest = - PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) - (PMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest = - List.fold_left (fun lowest can -> - let lvl = PMap.find can.canon lowest in - PMap.fold (fun u' strict lowest -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').canon in - PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) - can.ltle lowest) - lowest cans - in - let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in - let types = Array.init (max_lvl + 1) (fun i -> - match List.nth_opt first i with - | Some u -> u - | None -> make_dummy (i-2)) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl > List.length first && not (CList.is_empty first) then - enforce_lt (CList.last first) types.(List.length first) g - else g - in - let g = - PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) - lowest g - in - normalize g - - (** Pretty-printing *) - - let pr_pmap sep pr map = - let cmp (u,_) (v,_) = Point.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) - - let pr_arc prl = let open Pp in - function - | _, Canonical {canon=u; ltle; _} -> - if PMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_pmap spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - - let pr prl g = - pr_pmap Pp.mt (pr_arc prl) g.entries - - (* Dumping constraints to a file *) - - let dump output g = - let dump_arc u = function - | Canonical {canon=u; ltle; _} -> - PMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v + type node = Alias of Point.t | Node of bool Point.Map.t + type repr = node Point.Map.t + + let repr g = + let fold u n accu = + let n = match n with + | Canonical n -> + let fold u lt accu = Point.Map.add (Index.repr u g.table) lt accu in + let ltle = PMap.fold fold n.ltle Point.Map.empty in + Node ltle + | Equiv u -> Alias (Index.repr u g.table) + in + Point.Map.add (Index.repr u g.table) n accu in - PMap.iter dump_arc g.entries + PMap.fold fold g.entries Point.Map.empty end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli index e9f05ed74d..8c9d2e6461 100644 --- a/lib/acyclicGraph.mli +++ b/lib/acyclicGraph.mli @@ -65,18 +65,12 @@ module Make (Point:Point) : sig val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option - val sort : (int -> Point.t) -> Point.t list -> t -> t - (** [sort mk first g] builds a totally ordered graph. The output - graph should imply the input graph (and the implication will be - strict most of the time), but is not necessarily minimal. The - lowest points in the result are identified with [first]. - Moreover, it adds levels [Type.n] to identify the points (not in - [first]) at level n. An artificial constraint (last first < mk - (length first)) is added to ensure that they are not merged. - Note: the result is unspecified if the input graph already - contains [mk n] nodes. *) - - val pr : (Point.t -> Pp.t) -> t -> Pp.t - - val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit + (** {5 High-level representation} *) + + type node = + | Alias of Point.t + | Node of bool Point.Map.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + type repr = node Point.Map.t + val repr : t -> repr + end 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/control.ml b/lib/control.ml index 7da95ff3dd..ea94bda064 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -30,11 +30,12 @@ let check_for_interrupt () = (** This function does not work on windows, sigh... *) let unix_timeout n f x = + let open Unix in let timeout_handler _ = raise Timeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in - let _ = Unix.alarm n in + let _ = setitimer ITIMER_REAL {it_interval = 0.; it_value = n} in let restore_timeout () = - let _ = Unix.alarm 0 in + let _ = setitimer ITIMER_REAL { it_interval = 0.; it_value = 0. } in Sys.set_signal Sys.sigalrm psh in try @@ -52,7 +53,7 @@ let windows_timeout n f x = let thread init = while not !killed do let cur = Unix.gettimeofday () in - if float_of_int n <= cur -. init then begin + if n <= cur -. init then begin interrupt := true; exited := true; Thread.exit () @@ -68,7 +69,7 @@ let windows_timeout n f x = let cur = Unix.gettimeofday () in (* The thread did not interrupt, but the computation took longer than expected. *) - let () = if float_of_int n <= cur -. init then begin + let () = if n <= cur -. init then begin exited := true; raise Sys.Break end in @@ -83,7 +84,7 @@ let windows_timeout n f x = let () = killed := true in Exninfo.iraise e -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('a -> 'b) -> 'a -> 'b option } let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } diff --git a/lib/control.mli b/lib/control.mli index 9465d8f0d5..f992d8e8d0 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -24,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 -> 'b option +val timeout : float -> ('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 -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('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/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index ac2058ba1b..343fb0b1fe 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -112,13 +112,13 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Case (info, r, _iv, arg, pats) -> + | Case (info, _, _, _, _, arg, pats) -> let is_bool = let i = info.ci_ind in Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then - Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) + Ifb ((aux arg), (aux (snd pats.(0))), (aux (snd pats.(1)))) else Var (Env.add env c) | _ -> diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index c485c38009..72f77508d8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,7 +420,7 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading subgoal ...") in + let _ = debug (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in @@ -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/extraction.ml b/plugins/extraction/extraction.ml index 6869f9c47e..0cad192332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -672,9 +672,11 @@ let rec extract_term env sg mle mlt c args = (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args - | Case ({ci_ind=ip},_,iv,c0,br) -> - (* If invert_case then this is a match that will get erased later, but right now we don't care. *) - extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args + | Case (ci, u, pms, r, iv, c0, br) -> + (* If invert_case then this is a match that will get erased later, but right now we don't care. *) + let (ip, r, iv, c0, br) = EConstr.expand_case env sg (ci, u, pms, r, iv, c0, br) in + let ip = ci.ci_ind in + extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env sg mle mlt (extract_fix env sg mle i recd) args | CoFix (i,recd) -> @@ -1078,9 +1080,13 @@ let fake_match_projection env p = let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else - let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in - let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in - let body = mkCase (ci, p, NoInvert, mkRel 1, [|branch|]) in + let p = ([|x|], liftn 1 2 ty) in + let branch = + let nas = Array.of_list (List.rev_map Context.Rel.Declaration.get_annot ctx) in + (nas, mkRel (List.length ctx - (j - 1))) + in + let params = Context.Rel.to_extended_vect mkRel 1 paramslet in + let body = mkCase (ci, u, params, p, NoInvert, mkRel 1, [|branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt | LocalDef (_,c,t) :: rem -> let c = liftn 1 j c in 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/firstorder/unify.ml b/plugins/firstorder/unify.ml index c62bc73e41..e208ba9a5c 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -67,10 +67,13 @@ let unif env evd t1 t2= | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,_,ca,va),Case (_,pb,_,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + | Case (cia,ua,pmsa,pa,iva,ca,va),Case (cib,ub,pmsb,pb,ivb,cb,vb)-> + let env = Global.env () in + let (cia,pa,iva,ca,va) = EConstr.expand_case env evd (cia,ua,pmsa,pa,iva,ca,va) in + let (cib,pb,iva,cb,vb) = EConstr.expand_case env evd (cib,ub,pmsb,pb,ivb,cb,vb) in + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 73eb943418..3234d40f73 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -598,12 +598,12 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos let sigma = Proofview.Goal.sigma g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> + | Case (ci, u, pms, ct, iv, t, cb) -> let do_finalize_t dyn_info' = Proofview.Goal.enter (fun g -> let t = dyn_info'.info in let dyn_infos = - {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + {dyn_info' with info = mkCase (ci, u, pms, ct, iv, t, cb)} in let g_nb_prod = nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) @@ -1260,7 +1260,7 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst fname) ) ] + , Tacred.EvalConstRef (fst fname) ) ] ; (let do_prove = build_proof interactive_proof (Array.to_list fnames) diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 314c8abcaf..cbdebb7bbc 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -917,13 +917,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] (destVar sigma args.(1), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -936,13 +936,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] (destVar sigma args.(2), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -972,7 +972,7 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = ( UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type" )) -> tauto - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [simplest_case v; intros_with_rewrite ()] | LetIn _ -> tclTHENLIST @@ -1005,7 +1005,7 @@ let rec reflexivity_with_destruct_cases () = (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( 2) with - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [ simplest_case v ; intros @@ -1158,7 +1158,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : else unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef + , Tacred.EvalConstRef (fst (destConst (Proofview.Goal.sigma g) f)) ) ] in (* The proof of each branche itself *) 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/indfun_common.ml b/plugins/funind/indfun_common.ml index 6464556e4e..266345a324 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -418,6 +418,7 @@ let make_eq () = with _ -> assert false let evaluable_of_global_reference r = + let open Tacred in (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with | GlobRef.ConstRef sp -> EvalConstRef sp diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 7b7044fdaf..e25f413fe4 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -100,7 +100,7 @@ val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : - GlobRef.t -> Names.evaluable_global_reference + GlobRef.t -> Tacred.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 33076a876b..9e9444951f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -301,10 +301,11 @@ let check_not_nested env sigma forbidden e = | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case (_, t, _, e, a) -> + | Case (_, _, pms, (_, t), _, e, a) -> + Array.iter check_not_nested pms; check_not_nested t; check_not_nested e; - Array.iter check_not_nested a + Array.iter (fun (_, c) -> check_not_nested c) a | Fix _ -> user_err Pp.(str "check_not_nested : Fix") | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in @@ -367,7 +368,7 @@ type journey_info = -> unit Proofview.tactic) -> ( case_info * constr - * (constr, EInstance.t) case_invert + * case_invert * constr * constr array , constr ) @@ -472,7 +473,8 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> + | Case (ci, u, pms, t, iv, a, l) -> + let (ci, t, iv, a, l) = EConstr.expand_case env sigma (ci, u, pms, t, iv, a, l) in let continuation_tac_a = jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in @@ -776,7 +778,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 (EConstr.contract_case env sigma (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/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 6ab82b1253..90c366ed63 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 @@ -768,7 +774,7 @@ let rec find_a_destructable_match sigma t = let cl = [cl, (None, None), None], None in let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with - | Case (_,_,_,x,_) when closed0 sigma x -> + | Case (_,_,_,_,_,x,_) when closed0 sigma x -> if isVar sigma x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index eed9419946..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 diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index b1b96ea9a7..3da5b2bfc4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -147,7 +147,7 @@ GRAMMAR EXTEND Gram | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } - | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + | g=failkw; n = [ n = nat_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } | a = tactic_value -> { TacArg(CAst.make ~loc a) } 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 43957bbde5..cb430efb40 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,6 +182,11 @@ let merge_occurrences loc cl = function in (Some p, ans) +let deprecated_conversion_at_with = + CWarnings.create + ~name:"conversion_at_with" ~category:"deprecated" + (fun () -> Pp.str "The syntax [at ... with ...] is deprecated. Use [with ... at ...] instead.") + (* Auxiliary grammar rules *) open Pvernac.Vernac_ @@ -230,7 +235,8 @@ GRAMMAR EXTEND Gram [ [ c = constr -> { (None, c) } | c1 = constr; "with"; c2 = constr -> { (Some (AllOccurrences,c1),c2) } | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - { (Some (occs,c1), c2) } ] ] + { deprecated_conversion_at_with (); (* 8.14 *) + (Some (occs,c1), c2) } ] ] ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index cd7b1f7f28..6ebb01703f 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -191,8 +191,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c let pr_evaluable_reference = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n @@ -381,8 +381,8 @@ let string_of_genarg_arg (ArgumentType arg) = str "<" ++ KerName.print kn ++ str ">" let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (GlobRef.ConstRef sp) let pr_as_disjunctive_ipat prc ipatl = @@ -458,7 +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 - | (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 } -> @@ -755,7 +756,7 @@ let pr_goal_selector ~toplevel s = (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - prlist_with_sep spc (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp + pr_non_empty_arg (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( @@ -1130,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; @@ -1166,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; @@ -1189,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 @@ -1212,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 = @@ -1242,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 = @@ -1301,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) @@ -1317,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..4f58eceb59 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -106,7 +106,7 @@ val pr_may_eval : val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t -val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t +val pr_evaluable_reference_env : env -> Tacred.evaluable_global_reference -> Pp.t val pr_quantified_hypothesis : quantified_hypothesis -> Pp.t @@ -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..6d0e0c36b3 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 } @@ -923,7 +918,8 @@ let reset_env env = Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = - let (ci, p, iv, c, brs) = destCase sigma c in + let case = destCase sigma c in + let (ci, p, iv, c, brs) = EConstr.expand_case env sigma case in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = @@ -991,7 +987,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let argty = Retyping.get_type_of env (goalevars evars) arg in let state, res = s.strategy { state ; env ; unfresh ; - term1 = arg ; ty1 = argty ; + term1 = arg ; ty1 = argty ; cstr = (prop,None) ; evars } in let res' = @@ -1158,7 +1154,8 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> b' in state, res - | Case (ci, p, iv, c, brs) -> + | Case (ci, u, pms, p, iv, c, brs) -> + let (ci, p, iv, c, brs) = EConstr.expand_case env (goalevars evars) (ci, u, pms, p, iv, c, brs) in let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in @@ -1168,7 +1165,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let state, res = match c' with | Success r -> - let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in + let case = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs)) in let res = make_leibniz_proof env case ty r in state, Success (coerce env (prop,cstr) res) | Fail | Identity -> @@ -1190,7 +1187,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in match found with | Some r -> - let ctxc = mkCase (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c'))) in + let ctxc = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c')))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else @@ -1391,7 +1388,7 @@ module Strategies = let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = try Tacred.try_red_product env sigma c @@ -1423,12 +1420,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 +2074,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..5e88bf7c79 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -276,6 +276,7 @@ let coerce_to_closed_constr env v = c let coerce_to_evaluable_ref env sigma v = + let open Tacred in let fail () = raise (CannotCoerceTo "an evaluable reference") in let ev = match is_intro_pattern v with @@ -429,7 +430,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/taccoerce.mli b/plugins/ltac/taccoerce.mli index b8592c5c76..8ca2510459 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -69,7 +69,7 @@ val coerce_to_uconstr : Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr val coerce_to_evaluable_ref : - Environ.env -> Evd.evar_map -> Value.t -> evaluable_global_reference + Environ.env -> Evd.evar_map -> Value.t -> Tacred.evaluable_global_reference val coerce_to_constr_list : Environ.env -> Value.t -> constr list diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 7b2c8e1d04..a880a3305e 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -270,7 +270,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -324,7 +324,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 2382dcfbb9..3bb20b9d19 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -269,7 +269,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -323,7 +323,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 8bee7afa2c..ae7a10ce52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -308,8 +308,8 @@ let short_name qid = else None let evalref_of_globref ?loc ?short = function - | GlobRef.ConstRef cst -> ArgArg (EvalConstRef cst, short) - | GlobRef.VarRef id -> ArgArg (EvalVarRef id, short) + | GlobRef.ConstRef cst -> ArgArg (Tacred.EvalConstRef cst, short) + | GlobRef.VarRef id -> ArgArg (Tacred.EvalVarRef id, short) | r -> let tpe = match r with | GlobRef.IndRef _ -> "inductive" diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 00ac155f0e..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 *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 90546ea939..6148f0d23f 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -89,7 +89,7 @@ let subst_global_reference subst = Locusops.or_var_map (subst_located (subst_global_reference subst)) let subst_evaluable subst = - let subst_eval_ref = subst_evaluable_reference subst in + let subst_eval_ref = Tacred.subst_evaluable_reference subst in Locusops.or_var_map (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) 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/ltac/tauto.ml b/plugins/ltac/tauto.ml index a7b571d3db..7d959aa788 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -189,6 +189,7 @@ let flatten_contravariant_disj _ ist = | _ -> fail let evalglobref_of_globref = + let open Tacred in function | GlobRef.VarRef v -> EvalVarRef v | GlobRef.ConstRef c -> EvalConstRef c 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..5e138fa3d1 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") @@ -929,7 +930,8 @@ let is_prop env sigma term = Sorts.is_prop sort type formula_op = - { op_and : EConstr.t + { op_impl : EConstr.t option (* only for booleans *) + ; op_and : EConstr.t ; op_or : EConstr.t ; op_iff : EConstr.t ; op_not : EConstr.t @@ -938,7 +940,8 @@ type formula_op = let prop_op = lazy - { op_and = Lazy.force coq_and + { op_impl = None (* implication is Prod *) + ; op_and = Lazy.force coq_and ; op_or = Lazy.force coq_or ; op_iff = Lazy.force coq_iff ; op_not = Lazy.force coq_not @@ -947,13 +950,17 @@ let prop_op = let bool_op = lazy - { op_and = Lazy.force coq_andb + { op_impl = Some (Lazy.force coq_implb) + ; op_and = Lazy.force coq_andb ; op_or = Lazy.force coq_orb ; op_iff = Lazy.force coq_eqb ; op_not = Lazy.force coq_negb ; op_tt = Lazy.force coq_true ; op_ff = Lazy.force coq_false } +let is_implb sigma l o = + match o with None -> false | Some c -> EConstr.eq_constr sigma l c + let parse_formula (genv, sigma) parse_atom env tg term = let parse_atom b env tg t = try @@ -969,6 +976,10 @@ let parse_formula (genv, sigma) parse_atom env tg term = match EConstr.kind sigma term with | App (l, rst) -> ( match rst with + | [|a; b|] when is_implb sigma l op.op_impl -> + let f, env, tg = xparse_formula op k env tg a in + let g, env, tg = xparse_formula op k env tg b in + (mkformula_binary k (mkIMPL k) term f g, env, tg) | [|a; b|] when EConstr.eq_constr sigma l op.op_and -> let f, env, tg = xparse_formula op k env tg a in let g, env, tg = xparse_formula op k env tg b in @@ -1341,6 +1352,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 +1381,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 +1400,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,8 +2085,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) = -struct +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 +2220,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 +2237,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/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/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4f7b3fbe74..9d92ffde74 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -354,8 +354,9 @@ let coq_True = gen_constant "core.True.type" let evaluable_ref_of_constr s c = let env = Global.env () in let evd = Evd.from_env env in + let open Tacred in match EConstr.kind evd (Lazy.force c) with - | Const (kn,u) when Tacred.is_evaluable env (EvalConstRef kn) -> + | Const (kn,u) when is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index f6a741f468..5fbabd7ca1 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -46,7 +46,11 @@ type ssrclear = ssrhyps type ssrdocc = ssrclear option * ssrocc (* OLD ssr terms *) -type ssrtermkind = char (* FIXME, make algebraic *) +(* terms are pre constr, the kind is a parsing/printing flag to distinguish + * between x, @x and (x). It affects automatic clear and let-in preservation. *) +(* FIXME *) +(* Cpattern is a temporary flag that becomes InParens ASAP. *) +type ssrtermkind = Ssrmatching_plugin.Ssrmatching.ssrtermkind type ssrterm = ssrtermkind * Genintern.glob_constr_and_expr (* NEW ssr term *) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 42b9248979..37eba7d399 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -19,30 +19,21 @@ open Ssrmatching_plugin open Ssrmatching open Ssrast -open Ssrprinters open Ssrcommon -let char_to_kind = function - | '(' -> xInParens - | '@' -> xWithAt - | ' ' -> xNoFlag - | 'x' -> xCpattern - | _ -> assert false - (** Backward chaining tactics: apply, exact, congr. *) (** The "apply" tactic *) let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = (* ppdebug(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) - let k = char_to_kind k in let rc = pf_intern_term ist gl c in let rcs' = rc :: rcs in match goclr with | None -> clr, rcs' | Some ghyps -> let clr' = snd (interp_hyps ist gl ghyps) @ clr in - if k <> xNoFlag then clr', rcs' else + if k <> NoFlag then clr', rcs' else let loc = rc.CAst.loc in match DAst.get rc with | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' @@ -50,7 +41,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 @@ -132,7 +123,7 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in let ggenl, tclGENTAC = if gviews <> [] && ggenl <> [] then - let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in + let ggenl= List.map (fun (x,(k,p)) -> x, {kind=k; pattern=p; interpretation= Some ist}) (List.hd ggenl) in [], Tacticals.tclTHEN (Proofview.V82.of_tactic (genstac (ggenl,[]))) else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in tclGENTAC (fun gl -> diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cb58b9bcb8..4d57abb465 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -290,7 +290,7 @@ let interp_hyps ist gl ghyps = (* Old terms *) let mk_term k c = k, (mkRHole, Some c) -let mk_lterm c = mk_term xNoFlag c +let mk_lterm c = mk_term NoFlag c (* New terms *) @@ -318,9 +318,9 @@ let interp_ast_closure_term (ist : Geninterp.interp_sign) (gl : 'goal Evd.sigma) let ssrterm_of_ast_closure_term { body; annotation } = let c = match annotation with - | `Parens -> xInParens - | `At -> xWithAt - | _ -> xNoFlag in + | `Parens -> InParens + | `At -> WithAt + | _ -> NoFlag in mk_term c body let ssrdgens_of_parsed_dgens = function @@ -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 = @@ -926,7 +926,7 @@ let pf_interp_ty ?(resolve_typeclasses=false) env sigma0 ist ty = CProdN (abs, force_type t) | CLetIn (n, v, oty, t) -> incr n_binders; CLetIn (n, v, oty, force_type t) | _ -> (mkCCast ty (mkCType None)).v)) ty in - mk_term ' ' (force_type ty) in + mk_term NoFlag (force_type ty) in let strip_cast (sigma, t) = let open EConstr in let rec aux t = match kind_of_type sigma t with @@ -1099,7 +1099,7 @@ let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) let interp_clr sigma = function | Some clr, (k, c) - when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> + when (k = NoFlag || k = WithAt) && is_pf_var sigma c -> hyp_of_var sigma c :: clr | Some clr, _ -> clr | None, _ -> [] @@ -1167,7 +1167,7 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let cl = EConstr.of_constr cl in let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in if not(occur_existential sigma c) then - if tag_of_cpattern t = xWithAt then + if tag_of_cpattern t = WithAt then if not (EConstr.isVar sigma c) then errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index a7ebd5f9f5..0008d31ffd 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 @@ -223,16 +223,16 @@ let simplintac occ rdx sim = end let rec get_evalref env sigma c = match EConstr.kind sigma c with - | Var id -> EvalVarRef id - | Const (k,_) -> EvalConstRef k + | Var id -> Tacred.EvalVarRef id + | Const (k,_) -> Tacred.EvalConstRef k | App (c', _) -> get_evalref env sigma c' | Cast (c', _, _) -> get_evalref env sigma c' - | Proj(c,_) -> EvalConstRef(Projection.constant c) + | Proj(c,_) -> Tacred.EvalConstRef(Projection.constant c) | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with - | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + | App (f, a) when kt = NoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> (sigma, f), true | Const _ | Var _ -> p, true | Proj _ -> p, true @@ -736,7 +736,7 @@ let unlocktac ist args = Ssrcommon.tacMK_SSR_CONST "locked" >>= fun locked -> Ssrcommon.tacMK_SSR_CONST "master_key" >>= fun key -> let ktacs = [ - (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) xInParens); + (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) InParens); Ssrelim.casetac key (fun ?seed:_ k -> k) ] in Tacticals.New.tclTHENLIST (List.map utac args @ ktacs) diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 4961138190..f2c7f495b3 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -143,8 +143,8 @@ let havetac ist let gl, _ = pf_e_type_of gl idty in pf_unify_HO gl args_id.(2) abstract_key in Tacticals.tclTHENFIRST (Proofview.V82.of_tactic itac_mkabs) (fun gl -> - let mkt t = mk_term xNoFlag t in - let mkl t = (xNoFlag, (t, None)) in + let mkt t = mk_term NoFlag t in + let mkl t = (NoFlag, (t, None)) in let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in let interp_ty gl rtc t = let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc (pf_env gl) (project gl) ist t in a,b,u in diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 46f90a7ee1..1e940b5ad3 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -741,7 +741,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin [A.. -> Ind] and opens new goals for [A..] as well as for the branches of [Ind], see the [~to_ind] argument *) if not(Termops.occur_existential sigma c) then - if Ssrmatching.tag_of_cpattern t = Ssrprinters.xWithAt then + if Ssrmatching.tag_of_cpattern t = Ssrmatching.WithAt then if not (EConstr.isVar sigma c) then Ssrcommon.errorstrm Pp.(str "@ can be used with variables only") else match Context.Named.lookup (EConstr.destVar sigma c) hyps with diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index f06b460ee9..935cef58b9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -38,6 +38,8 @@ open Constrexpr_ops open Proofview open Proofview.Notations +open Ssrmatching_plugin.Ssrmatching + open Ssrprinters open Ssrcommon open Ssrtacticals @@ -455,9 +457,9 @@ END (* Old kinds of terms *) let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> xInParens - | Tok.KEYWORD "@" -> xWithAt - | _ -> xNoFlag + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind @@ -554,9 +556,9 @@ END GRAMMAR EXTEND Gram GLOBAL: ssrbwdview; ssrbwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term xNoFlag c] } + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term NoFlag c] } | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> { - (mk_term xNoFlag c) :: w } ]]; + (mk_term NoFlag c) :: w } ]]; END (* New Views *) @@ -2201,10 +2203,10 @@ let pr_ssrcongrarg _ _ _ ((n, f), dgens) = ARGUMENT EXTEND ssrcongrarg TYPED AS ((int * ssrterm) * ssrdgens) PRINTED BY { pr_ssrcongrarg } -| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term xNoFlag c), dgens } -| [ natural(n) constr(c) ] -> { (n, mk_term xNoFlag c),([[]],[]) } -| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term xNoFlag c), dgens } -| [ constr(c) ] -> { (0, mk_term xNoFlag c), ([[]],[]) } +| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term NoFlag c), dgens } +| [ natural(n) constr(c) ] -> { (n, mk_term NoFlag c),([[]],[]) } +| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term NoFlag c), dgens } +| [ constr(c) ] -> { (0, mk_term NoFlag c), ([[]],[]) } END @@ -2260,7 +2262,7 @@ let pr_rule = function let pr_ssrrule _ _ _ = pr_rule -let noruleterm loc = mk_term xNoFlag (mkCProp loc) +let noruleterm loc = mk_term NoFlag (mkCProp loc) } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index ab36d4fc7c..6ed68094dc 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -28,16 +28,6 @@ let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> let pp_term gl t = let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t -(* FIXME *) -(* terms are pre constr, the kind is parsing/printing flag to distinguish - * between x, @x and (x). It affects automatic clear and let-in preservation. - * Cpattern is a temporary flag that becomes InParens ASAP. *) -(* type ssrtermkind = InParens | WithAt | NoFlag | Cpattern *) -let xInParens = '(' -let xWithAt = '@' -let xNoFlag = ' ' -let xCpattern = 'x' - (* Term printing utilities functions for deciding bracketing. *) let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") (* String lexing utilities *) @@ -45,10 +35,10 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = xInParens + | _ -> kind = Ssrmatching_plugin.Ssrmatching.InParens (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) @@ -57,17 +47,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/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 87eb05b667..21fb28038a 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -24,11 +24,6 @@ val pp_concat : Pp.t -> ?sep:Pp.t -> Pp.t list -> Pp.t -val xInParens : ssrtermkind -val xWithAt : ssrtermkind -val xNoFlag : ssrtermkind -val xCpattern : ssrtermkind - val pr_clear : (unit -> Pp.t) -> ssrclear -> Pp.t val pr_clear_ne : ssrclear -> Pp.t val pr_dir : ssrdir -> Pp.t diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index cbc352126e..c822675589 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -40,7 +40,7 @@ let tclPERM perm tac = let rot_hyps dir i hyps = let n = List.length hyps in if i = 0 then List.rev hyps else - if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + if i > n then CErrors.user_err (Pp.str "Not enough goals") else let rec rot i l_hyps = function | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' | hyps' -> hyps' @ (List.rev l_hyps) in 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/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 2252435658..7022949ab6 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -67,9 +67,9 @@ END { let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind } @@ -78,8 +78,8 @@ GRAMMAR EXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END @@ -97,8 +97,8 @@ GRAMMAR EXTEND Gram GLOBAL: lcpattern; lcpattern: [[ k = ssrtermkind; c = lconstr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index a4aa08300d..7774258fca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -37,6 +37,8 @@ open Evar_kinds open Constrexpr open Constrexpr_ops +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + let errorstrm = CErrors.user_err ~hdr:"ssrmatching" let loc_error loc msg = CErrors.user_err ?loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info @@ -78,18 +80,22 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = '(' + | _ -> kind = InParens (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) 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 @@ -98,14 +104,6 @@ let prl_glob_constr_and_expr env sigma = function let pr_glob_constr_and_expr env sigma = function | _, Some c -> pr_constr_expr env sigma c | c, None -> pr_glob_constr c -let pr_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (pr_glob_constr_and_expr env sigma) c -let prl_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (prl_glob_constr_and_expr env sigma) c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = @@ -149,28 +147,6 @@ let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) -(* ssrterm conbinators *) -let combineCG t1 t2 f g = - let mk_ist i1 i2 = match i1, i2 with - | None, Some i -> Some i - | Some i, None -> Some i - | None, None -> None - | Some i, Some j when i == j -> Some i - | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in - match t1, t2 with - | (x, (t1, None), i1), (_, (t2, None), i2) -> - x, (g t1 t2, None), mk_ist i1 i2 - | (x, (_, Some t1), i1), (_, (_, Some t2), i2) -> - x, (mkRHole, Some (f t1 t2)), mk_ist i1 i2 - | _, (_, (_, None), _) -> CErrors.anomaly (str"have: mixed C-G constr.") - | _ -> CErrors.anomaly (str"have: mixed G-C constr.") -let loc_ofCG = function - | (_, (s, None), _) -> Glob_ops.loc_of_glob_constr s - | (_, (_, Some s), _) -> Constrexpr_ops.constr_loc s - -let mk_term k c ist = k, (mkRHole, Some c), ist -let mk_lterm = mk_term ' ' - let nf_evar sigma c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) @@ -309,7 +285,8 @@ let iter_constr_LR f c = match kind c with | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, iv, v, b) -> f v; iter_invert f iv; f p; Array.iter f b + | Case (_, _, pms, (_, p), iv, v, b) -> + f v; Array.iter f pms; f p; iter_invert f iv; Array.iter (fun (_, c) -> f c) b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a @@ -773,7 +750,7 @@ let rec uniquize = function EConstr.push_rel ctx_item env, h' + 1 in let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in let f = EConstr.of_constr f in - let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = map_constr_with_binders_left_to_right env sigma inc_h self acc f in let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), @@ -799,25 +776,15 @@ type ('ident, 'term) ssrpattern = | E_In_X_In_T of 'term * 'ident * 'term | E_As_X_In_T of 'term * 'ident * 'term -let pr_pattern = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t - -let pr_pattern_w_ids = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t +let pr_pattern pr_ident pr_term = function + | T t -> pr_term t + | In_T t -> str "in " ++ pr_term t + | X_In_T (x,t) -> pr_ident x ++ str " in " ++ pr_term t + | In_X_In_T (x,t) -> str "in " ++ pr_ident x ++ str " in " ++ pr_term t | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t + pr_term e ++ str " in " ++ pr_ident x ++ str " in " ++ pr_term t | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + pr_term e ++ str " as " ++ pr_ident x ++ str " in " ++ pr_term t let pr_pattern_aux pr_constr = function | T t -> pr_constr t @@ -830,16 +797,53 @@ let pr_pattern_aux pr_constr = function pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern env (sigma, p) = pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p + +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } + +let pr_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (pr_glob_constr_and_expr env sigma) pattern +let prl_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (prl_glob_constr_and_expr env sigma) pattern + let pr_cpattern = pr_term -let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) +let pr_pattern_w_ids = pr_pattern pr_id prl_term + +let mk_term k c ist = {kind=k; pattern=(mkRHole, Some c); interpretation=ist} +let mk_lterm = mk_term NoFlag let glob_ssrterm gs = function - | k, (_, Some c), None -> - let x = Tacintern.intern_constr gs c in - k, (fst x, Some c), None + | {kind; pattern=(_, Some c); interpretation=None} -> + let x = Tacintern.intern_constr gs c in + {kind; pattern=(fst x, Some c); interpretation=None} | ct -> ct +(* ssrterm conbinators *) +let combineCG t1 t2 f g = + let mk_ist i1 i2 = match i1, i2 with + | None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i, Some j when i == j -> Some i + | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in + match t1, t2 with + | {kind=x; pattern=(t1, None); interpretation=i1}, {pattern=(t2, None); interpretation=i2} -> + {kind=x; pattern=(g t1 t2, None); interpretation = mk_ist i1 i2} + | {kind=x; pattern=(_, Some t1); interpretation=i1}, {pattern=(_, Some t2); interpretation=i2} -> + {kind=x; pattern=(mkRHole, Some (f t1 t2)); interpretation = mk_ist i1 i2} + | _, {pattern=(_, None); _} -> CErrors.anomaly (str"have: mixed C-G constr.") + | _ -> CErrors.anomaly (str"have: mixed G-C constr.") +let loc_ofCG = function + | {pattern = (s, None); _} -> Glob_ops.loc_of_glob_constr s + | {pattern = (_, Some s); _} -> Constrexpr_ops.constr_loc s + (* This piece of code asserts the following notations are reserved *) (* Reserved Notation "( a 'in' b )" (at level 0). *) (* Reserved Notation "( a 'as' b )" (at level 0). *) @@ -847,19 +851,19 @@ let glob_ssrterm gs = function (* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) let glob_cpattern gs p = pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = pi2 (glob_ssrterm gs (mk_lterm x None)) in + let glob x = (glob_ssrterm gs (mk_lterm x None)).pattern in let encode k s l = let name = Name (Id.of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None), None in + {kind=k; pattern=(mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None); interpretation=None} in let bind_in t1 t2 = let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in let check_var t2 = if not (isCVar t2) then loc_error (constr_loc t2) "Only identifiers are allowed here" in match p with - | _, (_, None), _ as x -> x - | k, (v, Some t), _ as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else + | {pattern = (_, None); _} as x -> x + | {kind=k; pattern=(v, Some t); _} as orig -> + if k = Cpattern then glob_ssrterm gs {kind=InParens; pattern=(v, Some t); interpretation=None} else match t.CAst.v with | CNotation(_,(InConstrEntry,"( _ in _ )"), ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with @@ -887,8 +891,8 @@ let glob_rpattern s p = | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) -let subst_ssrterm s (k, c, ist) = - k, Tacsubst.subst_glob_constr_and_expr s c, ist +let subst_ssrterm s {kind; pattern; interpretation} = + {kind; pattern=Tacsubst.subst_glob_constr_and_expr s pattern; interpretation} let subst_rpattern s = function | T t -> T (subst_ssrterm s t) @@ -898,7 +902,7 @@ let subst_rpattern s = function | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) -let interp_ssrterm ist (k,t,_) = k, t, Some ist +let interp_ssrterm ist {kind; pattern; _} = {kind; pattern; interpretation = Some ist} let interp_rpattern s = function | T t -> T (interp_ssrterm s t) @@ -906,23 +910,24 @@ let interp_rpattern s = function | X_In_T(x,t) -> X_In_T (interp_ssrterm s x,interp_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (interp_ssrterm s x,interp_ssrterm s t) | E_In_X_In_T(e,x,t) -> - E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) | E_As_X_In_T(e,x,t) -> - E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t -type cpattern = char * Genintern.glob_constr_and_expr * Geninterp.interp_sign option -let tag_of_cpattern = pi1 +let tag_of_cpattern p = p.kind let loc_of_cpattern = loc_ofCG -let cpattern_of_term (c, t) ist = c, t, Some ist type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern pr_cpattern pr_cpattern + +let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern pr_cpattern pr_cpattern) type pattern = Evd.evar_map * (constr, constr) ssrpattern -let id_of_cpattern (_, (c1, c2), _) = +let id_of_cpattern {pattern = (c1, c2); _} = let open CAst in match DAst.get c1, c2 with | _, Some { v = CRef (qid, _) } when qualid_is_ident qid -> @@ -937,12 +942,12 @@ let id_of_Cterm t = match id_of_cpattern t with let interp_open_constr ist env sigma gc = Tacinterp.interp_open_constr ist env sigma gc -let pf_intern_term env sigma (_, c, ist) = glob_constr ist env sigma c +let pf_intern_term env sigma {pattern = c; interpretation = ist; _} = glob_constr ist env sigma c let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t let interp_term env sigma = function - | (_, c, Some ist) -> + | {pattern = c; interpretation = Some ist; _} -> on_snd EConstr.Unsafe.to_constr (interp_open_constr ist env sigma c) | _ -> errorstrm (str"interpreting a term with no ist") @@ -970,17 +975,17 @@ let pr_ist { lfun= lfun } = *) let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = - pp(lazy(str"interpreting: " ++ pr_pattern red)); + pp(lazy(str"interpreting: " ++ pr_rpattern red)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in let eAsXInT e x t = E_As_X_In_T(e,x,t) in - let mkG ?(k=' ') x ist = k,(x,None), ist in - let ist_of (_,_,ist) = ist in - let decode (_,_,ist as t) ?reccall f g = + let mkG ?(k=NoFlag) x ist = {kind = k; pattern = (x,None); interpretation = ist } in + let ist_of x = x.interpretation in + let decode ({interpretation=ist; _} as t) ?reccall f g = try match DAst.get (pf_intern_term env sigma0 t) with | GCast(t,CastConv c) when isGHole t && isGLambda c-> let (x, c) = destGLambda c in - f x (' ',(c,None),ist) + f x {kind = NoFlag; pattern = (c,None); interpretation = ist} | GVar id when Option.has_some ist && let ist = Option.get ist in Id.Map.mem id ist.lfun && @@ -1023,7 +1028,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = sigma new_evars in sigma in let red = let rec decode_red = function - | T(k,(t,None),ist) -> + | T {kind=k; pattern=(t,None); interpretation=ist} -> begin match DAst.get t with | GCast (c,CastConv t) when isGHole c && @@ -1054,7 +1059,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = let red = match redty with | None -> red - | Some (ty, ist) -> let ty = ' ', ty, Some ist in + | Some (ty, ist) -> let ty = {kind=NoFlag; pattern=ty; interpretation = Some ist} in match red with | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> @@ -1068,9 +1073,12 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); - let mkXLetIn ?loc x (a,(g,c),ist) = match c with - | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist - | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in + let mkXLetIn ?loc x {kind; pattern=(g,c); interpretation} = match c with + | Some b -> {kind; pattern=(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)); interpretation} + | None -> { kind + ; pattern = DAst.make ?loc @@ GLetIn + (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None + ; interpretation} in match red with | T t -> let sigma, t = interp_term env sigma0 t in sigma, T t | In_T t -> let sigma, t = interp_term env sigma0 t in sigma, In_T t @@ -1251,16 +1259,16 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (GlobRef.VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) + { kind= NoFlag + ; pattern = DAst.make @@ GRef (GlobRef.VarRef id, None), None + ; interpretation = Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })} -let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with +let is_wildcard ({pattern = (l, r); _} : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true | _ -> false (* "ssrpattern" *) -let pr_rpattern = pr_pattern - let pf_merge_uc uc gl = re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 17b47227cb..2b90cef039 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -20,17 +20,16 @@ open Genintern (** Pattern parsing *) +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + (** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) -type cpattern +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } val pr_cpattern : cpattern -> Pp.t -(** The type of rewrite patterns, the patterns of the [rewrite] tactic. - These patterns also include patterns that identify all the subterms - of a context (i.e. "in" prefix) *) -type rpattern -val pr_rpattern : rpattern -> Pp.t - (** Pattern interpretation and matching *) exception NoMatch @@ -48,6 +47,12 @@ type ('ident, 'term) ssrpattern = type pattern = evar_map * (constr, constr) ssrpattern val pp_pattern : env -> pattern -> Pp.t +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern = (cpattern, cpattern) ssrpattern +val pr_rpattern : rpattern -> Pp.t + (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) val redex_of_pattern : @@ -193,9 +198,6 @@ val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * val fill_occ_term : Environ.env -> Evd.evar_map -> EConstr.t -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t -(* It may be handy to inject a simple term into the first form of cpattern *) -val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> cpattern - (** Helpers to make stateful closures. Example: a [find_P] function may be called many times, but the pattern instantiation phase is performed only the first time. The corresponding [conclude] has to return the instantiated @@ -219,7 +221,7 @@ val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) -val tag_of_cpattern : cpattern -> char +val tag_of_cpattern : cpattern -> ssrtermkind val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool @@ -245,7 +247,7 @@ sig val pr_rpattern : rpattern -> Pp.t val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern - val mk_term : char -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + val mk_term : ssrtermkind -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern 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/plugins/syntax/number.ml b/plugins/syntax/number.ml index 89d757a72a..0e7640f430 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -387,10 +387,10 @@ let locate_global_inductive allow_params qid = | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> i, List.map (function - | Notation_term.NRef r -> Some r + | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l | _ -> raise Not_found in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a793e217d4..6370bd4f9a 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 @@ -1156,17 +1165,16 @@ let rec ungeneralize sigma n ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) let p = - let sign,p = decompose_lam_assum sigma p in + let (nas, p) = p in let sign2,p = decompose_prod_n_assum sigma ng p in - let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in - it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in - mkCase (ci,p,iv,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_decls sigma q c in - it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) - ci.ci_cstr_ndecls brs) + let p = prod_applist sigma p [mkRel (n+Array.length nas+ng)] in + nas, it_mkProd_or_LetIn p sign2 + in + let map (nas, br) = nas, ungeneralize sigma (n + Array.length nas) ng br in + mkCase (ci, u, pms, p, iv, c, Array.map map brs) | App (f,args) -> (* We traverse an inner generalization *) assert (isCase sigma f); @@ -1186,12 +1194,9 @@ let rec is_dependent_generalization sigma ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) is_dependent_generalization sigma ng c - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) - Array.exists2 (fun q c -> - let _,b = decompose_lam_n_decls sigma q c in - is_dependent_generalization sigma ng b) - ci.ci_cstr_ndecls brs + Array.exists (fun (_, b) -> is_dependent_generalization sigma ng b) brs | App (g,args) -> (* We traverse an inner generalization *) assert (isCase sigma g); @@ -1750,7 +1755,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let good = List.filter (fun (_,u,_) -> is_conv_leq !!env sigma t u) subst in match good with | [] -> - map_constr_with_full_binders sigma (push_binder sigma) aux x t + map_constr_with_full_binders !!env sigma (push_binder sigma) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = 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..7930c3d634 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -76,8 +76,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, @@ -111,15 +110,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 @@ -138,7 +142,7 @@ let rec stack_concat stk1 stk2 = match stk1 with TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) - | CASE(c,b,iv,i,s,stk1') -> CASE(c,b,iv,i,s,stack_concat stk1' stk2) + | CASE(u,pms,c,b,iv,i,s,stk1') -> CASE(u,pms,c,b,iv,i,s,stack_concat stk1' stk2) | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) @@ -352,9 +356,9 @@ let rec reify_stack t = function | TOP -> t | APP (args,st) -> reify_stack (mkApp(t,Array.map reify_value args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> reify_stack - (mkCase (ci, ty, iv, t, br)) + (mkCase (ci, u, pms, ty, iv, t,br)) st | PROJ (p, st) -> reify_stack (mkProj (p, t)) st @@ -401,6 +405,33 @@ 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) + +(* TODO: share the common parts with EConstr *) +let expand_branch env u pms (ind, i) br = + let open Declarations in + let nas, _br = br.(i - 1) in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + Inductive.instantiate_context u subst nas ctx + +let cbv_subst_of_rel_context_instance mkclos sign args env = + let rec aux subst sign l = + let open Context.Rel.Declaration in + match sign, l with + | LocalAssum _ :: sign', a::args' -> aux (subs_cons a subst) sign' args' + | LocalDef (_,c,_)::sign', args' -> + aux (subs_cons (mkclos subst c) subst) sign' args' + | [], [] -> subst + | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") + in aux env (List.rev sign) (Array.to_list args) + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -420,7 +451,7 @@ let rec norm_head info env t stack = they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app nargs stack) - | Case (ci,p,iv,c,v) -> norm_head info env c (CASE(p,v,iv,ci,env,stack)) + | Case (ci,u,pms,p,iv,c,v) -> norm_head info env c (CASE(u,pms,p,v,iv,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack | Proj (p, c) -> @@ -456,7 +487,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 +557,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) @@ -548,16 +579,33 @@ and cbv_stack_value info env = function cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,iv,ci,env,stk))) + | (CONSTR(((sp,n),_),[||]), APP(args,CASE(u,pms,_p,br,iv,ci,env,stk))) when red_set info.reds fMATCH -> + let nargs = Array.length args - ci.ci_npar in let cargs = - Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in - cbv_stack_term info (stack_app cargs stk) env br.(n-1) + Array.sub args ci.ci_npar nargs in + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + subs_consn cargs 0 nargs env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx cargs env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR(((_,n),u),[||]), CASE(_,br,_,_,env,stk)) + | (CONSTR(((sp, n), _),[||]), CASE(u,pms,_,br,_,ci,env,stk)) when red_set info.reds fMATCH -> - cbv_stack_term info stk env br.(n-1) + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx [||] env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor in a Projection -> IOTA *) | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) @@ -631,10 +679,31 @@ let rec apply_stack info t = function | TOP -> t | APP (args,st) -> apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> + (* FIXME: Prevent this expansion by caching whether an inductive contains let-bindings *) + let (_, ty, _, _, br) = Inductive.expand_case info.env (ci, u, pms, ty, iv, mkProp, br) in + let ty = + let (_, mip) = Inductive.lookup_mind_specif info.env ci.ci_ind in + Term.decompose_lam_n_decls (mip.Declarations.mind_nrealdecls + 1) ty + in + let mk_br c n = Term.decompose_lam_n_decls n c in + let br = Array.map2 mk_br br ci.ci_cstr_ndecls in + let map_ctx (nas, c) = + let open Context.Rel.Declaration in + let fold decl e = match decl with + | LocalAssum _ -> subs_lift e + | LocalDef (_, b, _) -> + let b = cbv_stack_term info TOP e b in + (* The let-binding persists, so we have to shift *) + subs_shft (1, subs_cons b e) + in + let env = List.fold_right fold nas env in + let nas = Array.of_list (List.rev_map get_annot nas) in + (nas, cbv_norm_term info env c) + in apply_stack info - (mkCase (ci, cbv_norm_term info env ty, iv, t, - Array.map (cbv_norm_term info env) br)) + (mkCase (ci, u, Array.map (cbv_norm_term info env) pms, map_ctx ty, iv, t, + Array.map map_ctx br)) st | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 409f4c0f70..4d81678200 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -42,8 +42,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a3f1c0b004..15d1ddb4ec 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,9 +351,10 @@ let matches_core env sigma allow_bound_rels sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 - | PIf (a1,b1,b1'), Case (ci,_,_,a2,[|b2;b2'|]) -> - let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in - let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in + | PIf (a1,b1,b1'), Case (ci, u2, pms2, p2, iv, a2, ([|b2;b2'|] as br2)) -> + let (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci, u2, pms2, p2, iv, a2, br2) in + let ctx_b2,b2 = br2.(0) in + let ctx_b2',b2' = br2.(1) in let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then @@ -367,7 +368,8 @@ let matches_core env sigma allow_bound_rels else raise PatternMatchingFailure - | PCase (ci1,p1,a1,br1), Case (ci2,p2,_,a2,br2) -> + | PCase (ci1, p1, a1, br1), Case (ci2, u2, pms2, p2, iv, a2, br2) -> + let (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci2, u2, pms2, p2, iv, a2, br2) in let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () @@ -380,14 +382,37 @@ let matches_core env sigma allow_bound_rels if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) then raise PatternMatchingFailure in + let sorec_under_ctx subst (n, c1) (decls, c2) = + let env = push_rel_context decls env in + let rec fold (ctx, subst) nas decls = match nas, decls with + | [], _ -> + (* Historical corner case: less bound variables are allowed in + destructuring let-bindings. See #13735. *) + (ctx, subst) + | na1 :: nas, d :: decls -> + let na2 = Context.Rel.Declaration.get_annot d in + let t = Context.Rel.Declaration.get_type d in + let ctx = push_binder na1 na2 t ctx in + let subst = add_binders na1 na2 binding_vars subst in + fold (ctx, subst) nas decls + | _, [] -> + assert false + in + let ctx, subst = fold (ctx, subst) (Array.to_list n) (List.rev decls) in + sorec ctx env subst c1 c2 + in let chk_branch subst (j,n,c) = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); - sorec ctx env subst c br2.(j) + sorec_under_ctx subst (n, c) br2.(j) + in + let subst = sorec ctx env subst a1 a2 in + let subst = match p1 with + | None -> subst + | Some p1 -> sorec_under_ctx subst p1 p2 in - let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in - List.fold_left chk_branch chk_head br1 + List.fold_left chk_branch subst br1 | PFix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(lna2,tl2,bl2)) when Array.equal Int.equal ln1 ln2 && i1 = i2 -> @@ -504,12 +529,30 @@ let sub_match ?(closed=true) env sigma pat c = | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [(env, app); (env, Array.last lc)] mk_ctx next - | Case (ci,hd,iv,c1,lc) -> + | Case (ci,u,pms,hd0,iv,c1,lc0) -> + let (mib, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + let (_, hd, _, _, br) = expand_case env sigma (ci, u, pms, hd0, iv, c1, lc0) in + let hd = + let (ctx, hd) = decompose_lam_assum sigma hd in + (push_rel_context ctx env, hd) + in + let map i br = + let decls = mip.Declarations.mind_consnrealdecls.(i) in + let (ctx, c) = decompose_lam_n_decls sigma decls br in + (push_rel_context ctx env, c) + in + let lc = Array.to_list (Array.mapi map br) in let next_mk_ctx = function - | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,iv,c1,Array.of_list lc)) + | c1 :: rem -> + let pms, rem = List.chop (Array.length pms) rem in + let pms = Array.of_list pms in + let hd, lc = match rem with [] -> assert false | x :: l -> (x, l) in + let hd = (fst hd0, hd) in + let map_br (nas, _) br = (nas, br) in + mk_ctx (mkCase (ci,u,pms,hd,iv,c1,Array.map2 map_br lc0 (Array.of_list lc))) | _ -> assert false in - let sub = (env, c1) :: (env, hd) :: subargs env lc in + let sub = (env, c1) :: Array.fold_right (fun c accu -> (env, c) :: accu) pms (hd :: lc) in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies as recdefs)) -> let nb_fix = Array.length types in @@ -528,10 +571,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..722a0a2048 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util @@ -33,6 +35,78 @@ type detyping_flags = { flg_isgoal : bool; } +(** Reimplementation of kernel case expansion functions in more lenient way *) +module RobustExpand : +sig +val return_clause : Environ.env -> Evd.evar_map -> Ind.t -> + EInstance.t -> EConstr.t array -> EConstr.case_return -> rel_context * EConstr.t +val branch : Environ.env -> Evd.evar_map -> Construct.t -> + EInstance.t -> EConstr.t array -> EConstr.case_branch -> rel_context * EConstr.t +end = +struct +open CVars +open Declarations +open Univ +open Constr + +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + let () = if not (Int.equal (Array.length nas) (List.length ctx)) then raise Exit in + instantiate (Array.length nas - 1) ctx + +let return_clause env sigma ind u params (nas, p) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + List.map EConstr.of_rel_decl realdecls, p + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), p + +let branch env sigma (ind, i) u params (nas, br) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ctx = instantiate_context u subst nas ctx in + List.map EConstr.of_rel_decl ctx, br + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), br + +end + module Avoid : sig type t @@ -241,16 +315,9 @@ let print_primproj_params = (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) -let computable sigma p k = +let computable sigma (nas, ccl) = (* We first remove as many lambda as the arity, then we look - if it remains a lambda for a dependent elimination. This function - works for normal eta-expanded term. For non eta-expanded or - non-normal terms, it may affirm the pred is synthetisable - because of an undetected ultimate dependent variable in the second - clause, or else, it may affirm the pred non synthetisable - because of a non normal term in the fourth clause. - A solution could be to store, in the MutCase, the eta-expanded - normal form of pred to decide if it depends on its variables + if it remains a lambda for a dependent elimination. Lorsque le prédicat est dépendant de manière certaine, on ne déclare pas le prédicat synthétisable (même si la @@ -258,10 +325,7 @@ let computable sigma p k = sinon on perd la réciprocité de la synthèse (qui, lui, engendrera un prédicat non dépendant) *) - let sign,ccl = decompose_lam_assum sigma p in - Int.equal (Context.Rel.length sign) (k + 1) - && - noccur_between sigma 1 (k+1) ccl + noccur_between sigma 1 (Array.length nas) ccl let lookup_name_as_displayed env sigma t s = let rec lookup avoid n c = match EConstr.kind sigma c with @@ -393,30 +457,27 @@ let update_name sigma na ((_,(e,_)),c) = | _ -> na -let get_domain env sigma c = - let (_,t,_) = EConstr.destProd sigma (Reductionops.whd_all env sigma (Retyping.get_type_of env sigma c)) in - t - -let rec decomp_branch tags nal flags (avoid,env as e) sigma c = - match tags with - | [] -> (List.rev nal,(e,c)) - | b::tags -> +let decomp_branch flags e sigma (ctx, c) = + let n = List.length ctx in + let rec aux i nal (avoid, env as e) c = + if Int.equal i 0 then (List.rev nal,(e,c)) + else let decl, c, let_in = - match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> LocalAssum (na,t), c, true - | LetIn (na,b,t,c),true -> LocalDef (na,b,t), c, false - | _, false -> - let na = make_annot (Name default_dependent_ident) Sorts.Relevant (* dummy *) in - LocalAssum (na, get_domain (snd env) sigma c), applist (lift 1 c, [mkRel 1]), false - | _, true -> - let na = make_annot Anonymous Sorts.Relevant (* dummy *) in - LocalDef (na, mkProp (* dummy *), type1), lift 1 c, false + match EConstr.kind sigma c with + | Lambda (na,t,c) -> LocalAssum (na,t), c, true + | LetIn (na,b,t,c) -> LocalDef (na,b,t), c, false + | _ -> assert false in let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env (get_name decl) c in - decomp_branch tags (na'::nal) flags - (avoid', add_name (set_name na' decl) env) sigma c + aux (i - 1) (na'::nal) (avoid', add_name (set_name na' decl) env) c + in + aux n [] e (EConstr.it_mkLambda_or_LetIn c ctx) -let rec build_tree na isgoal e sigma ci cl = +let rec build_tree na isgoal e sigma (ci, u, pms, cl) = + let map i br = + RobustExpand.branch (snd (snd e)) sigma (ci.ci_ind, i + 1) u pms br + in + let cl = Array.mapi map cl in let mkpat n rhs pl = let na = update_name sigma na rhs in na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in @@ -429,12 +490,12 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [Id.Set.empty,[],rhs] | na::nal -> match EConstr.kind sigma c with - | Case (ci,p,iv,c,cl) when + | Case (ci,u,pms,p,iv,c,cl) when eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) - computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> - let clauses = build_tree na isgoal e sigma ci cl in + computable sigma p (* FIXME: can do better *) -> + let clauses = build_tree na isgoal e sigma (ci, u, pms, cl) in List.flatten (List.map (fun (ids,pat,rhs) -> let lines = align_tree nal isgoal rhs sigma in @@ -447,7 +508,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat and contract_branch isgoal e sigma (cdn,mkpat,rhs) = - let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in + let nal,rhs = decomp_branch isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in List.map (fun (ids,hd,rhs) -> let na, pat = mkpat rhs hd in @@ -457,15 +518,10 @@ and contract_branch isgoal e sigma (cdn,mkpat,rhs) = (* Transform internal representation of pattern-matching into list of *) (* clauses *) -let is_nondep_branch sigma c l = - try - (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_decls sigma (List.length l) c in - noccur_between sigma 1 (Context.Rel.length sign) ccl - with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *) - false +let is_nondep_branch sigma (nas, ccl) = + noccur_between sigma 1 (Array.length nas) ccl -let extract_nondep_branches test c b l = +let extract_nondep_branches b l = let rec strip l r = match DAst.get r, l with | r', [] -> r @@ -473,7 +529,7 @@ let extract_nondep_branches test c b l = | GLetIn (_,_,_,t), true::l -> strip l t (* FIXME: do we need adjustment? *) | _,_ -> assert false in - if test c l then Some (strip l b) else None + strip l b let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = @@ -498,13 +554,14 @@ let it_destRLambda_or_LetIn_names l c = | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c -let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = +let detype_case computable detype detype_eqns avoid env sigma (ci, univs, params, p, iv, c, bl) = let synth_type = synthetize_type () in let tomatch = detype c in let tomatch = match iv with | NoInvert -> tomatch - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + (* XXX use holes instead of params? *) + let t = mkApp (mkIndU (ci.ci_ind,univs), Array.append params indices) in DAst.make @@ GCast (tomatch, CastConv (detype t)) in let alias, aliastyp, pred= @@ -512,6 +569,8 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = then Anonymous, None, None else + let (ctx, p) = RobustExpand.return_clause (snd env) sigma ci.ci_ind univs params p in + let p = EConstr.it_mkLambda_or_LetIn p ctx in let p = detype p in let nl,typ = it_destRLambda_or_LetIn_names ci.ci_pp_info.ind_tags p in let n,typ = match DAst.get typ with @@ -540,21 +599,29 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = let constagsl = ci.ci_pp_info.cstr_tags in match tag, aliastyp with | LetStyle, None -> + let map i br = + let (ctx, body) = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in GLetTuple (nal,(alias,pred),tomatch,d) | IfStyle, None -> - let bl' = Array.map detype bl in - let nondepbrs = - Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in - if Array.for_all ((!=) None) nondepbrs then - GIf (tomatch,(alias,pred), - Option.get nondepbrs.(0),Option.get nondepbrs.(1)) + if Array.for_all (fun br -> is_nondep_branch sigma br) bl then + let map i br = + let ctx, body = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in + let bl' = Array.map detype bl in + let nondepbrs = Array.map2 extract_nondep_branches bl' constagsl in + GIf (tomatch,(alias,pred), nondepbrs.(0), nondepbrs.(1)) else - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) let rec share_names detype flags n l avoid env sigma c t = @@ -648,26 +715,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 +741,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 @@ -799,12 +855,12 @@ and detype_r d flags avoid env sigma t = GRef (GlobRef.IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) - | Case (ci,p,iv,c,bl) -> - let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in + | Case (ci,u,pms,p,iv,c,bl) -> + let comp = computable sigma p in + let case = (ci, u, pms, p, iv, c, bl) in detype_case comp (detype d flags avoid env sigma) - (detype_eqns d flags avoid env sigma ci comp) - (is_nondep_branch sigma) avoid - ci p iv c bl + (detype_eqns d flags avoid env sigma comp) + avoid env sigma case | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef | Int i -> GInt i @@ -816,18 +872,21 @@ and detype_r d flags avoid env sigma t = let u = detype_instance sigma u in GArray(u, t, def, ty) -and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = +and detype_eqns d flags avoid env sigma computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; - let mat = build_tree Anonymous flags (avoid,env) sigma ci bl in + let mat = build_tree Anonymous flags (avoid,env) sigma bl in List.map (fun (ids,pat,((avoid,env),c)) -> CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> + let (ci, u, pms, bl) = bl in Array.to_list - (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) + (Array.map3 (detype_eqn d flags avoid env sigma u pms) constructs consnargsl bl) -and detype_eqn d flags avoid env sigma constr construct_nargs branch = +and detype_eqn d flags avoid env sigma u pms constr construct_nargs br = + let ctx, body = RobustExpand.branch (snd env) sigma constr u pms br in + let branch = EConstr.it_mkLambda_or_LetIn body ctx in let make_pat decl avoid env b ids = if force_wildcard () && noccurn sigma 1 b then DAst.make @@ PatVar Anonymous,avoid,(add_name (set_name Anonymous decl) env),ids @@ -835,39 +894,24 @@ and detype_eqn d flags avoid env sigma constr construct_nargs branch = let na,avoid' = compute_name sigma ~let_in:false ~pattern:true flags avoid env (get_name decl) b in DAst.make (PatVar na),avoid',(add_name (set_name na decl) env),add_vname ids na in - let rec buildrec ids patlist avoid env l b = - match EConstr.kind sigma b, l with - | _, [] -> CAst.make @@ + let rec buildrec ids patlist avoid env n b = + if Int.equal n 0 then + CAst.make @@ (Id.Set.elements ids, [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype d flags avoid env sigma b) - | Lambda (x,t,b), false::l -> + else match EConstr.kind sigma b with + | Lambda (x,t,b) -> let pat,new_avoid,new_env,new_ids = make_pat (LocalAssum (x,t)) avoid env b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b - | LetIn (x,b,t,b'), true::l -> + | LetIn (x,b,t,b') -> let pat,new_avoid,new_env,new_ids = make_pat (LocalDef (x,b,t)) avoid env b' ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b' - - | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid env l c - - | _, true::l -> - let pat = DAst.make @@ PatVar Anonymous in - buildrec ids (pat::patlist) avoid env l b - - | _, false::l -> - (* eta-expansion : n'arrivera plus lorsque tous les - termes seront construits à partir de la syntaxe Cases *) - (* nommage de la nouvelle variable *) - let new_b = applist (lift 1 b, [mkRel 1]) in - let typ = get_domain (snd env) sigma b in - let pat,new_avoid,new_env,new_ids = - make_pat (LocalAssum (make_annot Anonymous Sorts.Relevant (* dummy *),typ)) avoid env new_b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l new_b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b' + | _ -> assert false in - buildrec Id.Set.empty [] avoid env construct_nargs branch + buildrec Id.Set.empty [] avoid env (List.length ctx) branch and detype_binder d flags bk avoid env sigma decl c = let na = get_name decl in @@ -1116,18 +1160,3 @@ let rec subst_glob_constr env subst = DAst.map (function GArray(u,t',def',ty') ) - -(* Utilities to transform kernel cases to simple pattern-matching problem *) - -let simple_cases_matrix_of_branches ind brs = - List.map (fun (i,n,b) -> - let nal,c = it_destRLambda_or_LetIn_names n b in - let mkPatVar na = DAst.make @@ PatVar na in - let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in - let ids = List.map_filter Nameops.Name.to_option nal in - CAst.make @@ (ids,[p],c)) - brs - -let return_type_of_predicate ind nrealargs_tags pred = - let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in - (List.hd nal, Some (CAst.make (ind, List.tl nal))), Some p diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 254f772ff8..6d6f7fa97b 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -72,14 +72,6 @@ val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option val force_wildcard : unit -> bool val synthetize_type : unit -> bool -(** Utilities to transform kernel cases to simple pattern-matching problem *) - -val it_destRLambda_or_LetIn_names : bool list -> glob_constr -> Name.t list * glob_constr -val simple_cases_matrix_of_branches : - inductive -> (int * bool list * glob_constr) list -> cases_clauses -val return_type_of_predicate : - inductive -> bool list -> glob_constr -> predicate_pattern * glob_constr option - val subst_genarg_hook : (substitution -> Genarg.glob_generic_argument -> Genarg.glob_generic_argument) Hook.t diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index cdf2922516..990e84e5a7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -127,9 +127,10 @@ let flex_kind_of_term flags env evd c sk = else Rigid | Evar ev -> if is_evar_allowed flags (fst ev) then Flexible ev else Rigid - | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> Rigid + | Lambda _ | Prod _ | Sort _ | Ind _ | Int _ | Float _ | Array _ -> Rigid + | Construct _ | CoFix _ (* Incorrect: should check only app in sk *) -> Rigid | Meta _ -> Rigid - | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) + | Fix _ -> Rigid (* happens when the fixpoint is partially applied (should check it?) *) | Cast _ | App _ | Case _ -> assert false let apprec_nohdbeta flags env evd c = @@ -205,7 +206,7 @@ let occur_rigidly flags env evd (evk,_) t = if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true else Reducible | Rel _ | Var _ -> Reducible - | Case (_,_,_,c,_) -> + | Case (_,_,_,_,_,c,_) -> (match aux c with | Rigid b -> Rigid b | _ -> Reducible) @@ -328,12 +329,6 @@ let ise_and evd l = | UnifFailure _ as x -> x in ise_and evd l -let ise_exact ise x1 x2 = - match ise x1 x2 with - | None, out -> out - | _, (UnifFailure _ as out) -> out - | Some _, Success i -> UnifFailure (i,NotSameArgSize) - let ise_array2 evd f v1 v2 = let rec allrec i = function | -1 -> Success i @@ -355,37 +350,52 @@ let rec ise_inst2 evd f l1 l2 = match l1, l2 with (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) -let rec ise_app_stack2 env f evd sk1 sk2 = - match sk1,sk2 with - | Stack.App node1 :: q1, Stack.App node2 :: q2 -> - let (t1,l1) = Stack.decomp_node_last node1 q1 in - let (t2,l2) = Stack.decomp_node_last node2 q2 in - begin match ise_app_stack2 env f evd l1 l2 with - |(_,UnifFailure _) as x -> x - |x,Success i' -> x,f env i' CONV t1 t2 +let rec ise_app_rev_stack2 env f evd revsk1 revsk2 = + match Stack.decomp_rev revsk1, Stack.decomp_rev revsk2 with + | Some (t1,revsk1), Some (t2,revsk2) -> + begin + match ise_app_rev_stack2 env f evd revsk1 revsk2 with + | (_, UnifFailure _) as x -> x + | x, Success i' -> x, f env i' CONV t1 t2 end - | _, _ -> (sk1,sk2), Success evd + | _, _ -> (revsk1,revsk2), Success evd (* This function tries to unify 2 stacks element by element. It works from the end to the beginning. If it unifies a non empty suffix of stacks but not the entire stacks, the first part of the answer is - Some(the remaining prefixes to tackle)) *) -let ise_stack2 no_app env evd f sk1 sk2 = - let rec ise_stack2 deep i sk1 sk2 = - let fail x = if deep then Some (List.rev sk1, List.rev sk2), Success i + Some(the remaining prefixes to tackle) + If [no_app] is set, situations like [match head u1 u2 with ... end] + will not try to match [u1] and [u2] (why?); but situations like + [match head u1 u2 with ... end v] will try to match [v] (??) *) +(* Input: E1[] =? E2[] where the E1, E2 are concatenations of + n-ary-app/case/fix/proj elimination rules + Output: + - either None if E1 = E2 is solved, + - or Some (E1'',E2'') such that there is a decomposition of + E1[] = E1'[E1''[]] and E2[] = E2'[E2''[]] s.t. E1' = E2' and + E1'' cannot be unified with E2'' + - UnifFailure if no such non-empty E1' = E2' exists *) +let rec ise_stack2 no_app env evd f sk1 sk2 = + let rec ise_rev_stack2 deep i revsk1 revsk2 = + let fail x = if deep then Some (List.rev revsk1, List.rev revsk2), Success i else None, x in - match sk1, sk2 with + match revsk1, revsk2 with | [], [] -> None, Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> - (match f env i CONV t1 t2 with - | Success i' -> - (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with - | Success i'' -> ise_stack2 true i'' q1 q2 - | UnifFailure _ as x -> fail x) - | UnifFailure _ as x -> fail x) + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in + begin + match ise_and i [ + (fun i -> f env i CONV t1 t2); + (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2)] + with + | Success i' -> ise_rev_stack2 true i' q1 q2 + | UnifFailure _ as x -> fail x + end | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) - then ise_stack2 true i q1 q2 + then ise_rev_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2)::q2 -> @@ -393,51 +403,54 @@ let ise_stack2 no_app env evd f sk1 sk2 = match ise_and i [ (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); - (fun i -> ise_exact (ise_stack2 false i) a1 a2)] with - | Success i' -> ise_stack2 true i' q1 q2 + (fun i -> snd (ise_stack2 no_app env i f a1 a2))] with + | Success i' -> ise_rev_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x else fail (UnifFailure (i,NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else - begin match ise_app_stack2 env f i sk1 sk2 with + begin match ise_app_rev_stack2 env f i revsk1 revsk2 with |_,(UnifFailure _ as x) -> fail x - |(l1, l2), Success i' -> ise_stack2 true i' l1 l2 + |(l1, l2), Success i' -> ise_rev_stack2 true i' l1 l2 end |_, _ -> fail (UnifFailure (i,(* Maybe improve: *) NotSameHead)) - in ise_stack2 false evd (List.rev sk1) (List.rev sk2) + in ise_rev_stack2 false evd (List.rev sk1) (List.rev sk2) (* Make sure that the matching suffix is the all stack *) -let exact_ise_stack2 env evd f sk1 sk2 = - let rec ise_stack2 i sk1 sk2 = - match sk1, sk2 with +let rec exact_ise_stack2 env evd f sk1 sk2 = + let rec ise_rev_stack2 i revsk1 revsk2 = + match revsk1, revsk2 with | [], [] -> Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in ise_and i [ - (fun i -> ise_stack2 i q1 q2); + (fun i -> ise_rev_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); (fun i -> f env i CONV t1 t2)] | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and i [ - (fun i -> ise_stack2 i q1 q2); + (fun i -> ise_rev_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); - (fun i -> ise_stack2 i a1 a2)] + (fun i -> exact_ise_stack2 env i f a1 a2)] else UnifFailure (i,NotSameHead) | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) - then ise_stack2 i q1 q2 + then ise_rev_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> - begin match ise_app_stack2 env f i sk1 sk2 with + begin match ise_app_rev_stack2 env f i revsk1 revsk2 with |_,(UnifFailure _ as x) -> x - |(l1, l2), Success i' -> ise_stack2 i' l1 l2 + |(l1, l2), Success i' -> ise_rev_stack2 i' l1 l2 end |_, _ -> UnifFailure (i,(* Maybe improve: *) NotSameHead) in if Reductionops.Stack.compare_shape sk1 sk2 then - ise_stack2 evd (List.rev sk1) (List.rev sk2) + ise_rev_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) (* Add equality constraints for covariant/invariant positions. For @@ -448,6 +461,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 @@ -523,31 +588,35 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in - let miller_pfenning on_left fallback ev lF tM evd = + let miller_pfenning l2r fallback ev lF tM evd = match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = tM in let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (conv_fun evar_conv_x) flags env evd - (position_problem on_left pbty,ev,t2) + (position_problem l2r pbty,ev,t2) in - let consume_stack on_left (termF,skF) (termO,skO) evd = - let switch f a b = if on_left then f a b else f b a in + let consume_stack l2r (termF,skF) (termO,skO) evd = + let switch f a b = if l2r then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in match switch (ise_stack2 not_only_app env evd (evar_conv_x flags)) skF skO with - |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> + | Some (l,r), Success i' when l2r && (not_only_app || List.is_empty l) -> + (* E[?n]=E'[redex] reduces to either l[?n]=r[redex] with + case/fix/proj in E' (why?) or ?n=r[redex] *) switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) - |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> + | Some (r,l), Success i' when not l2r && (not_only_app || List.is_empty l) -> + (* E'[redex]=E[?n] reduces to either r[redex]=l[?n] with + case/fix/proj in E' (why?) or r[redex]=?n *) switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) - |None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO - |_, (UnifFailure _ as x) -> x - |Some _, _ -> UnifFailure (evd,NotSameArgSize) in - let eta env evd onleft sk term sk' term' = - assert (match sk with [] -> true | _ -> false); + | None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO + | _, (UnifFailure _ as x) -> x + | Some _, _ -> UnifFailure (evd,NotSameArgSize) in + let eta_lambda env evd onleft term (term',sk') = + (* Reduces an equation [env |- <(fun na:c1 => c'1)|empty> = <term'|sk'>] to + [env, na:c1 |- c'1 = sk'[term'] (with some additional reduction) *) let (na,c1,c'1) = destLambda evd term in - let c = nf_evar evd c1 in - let env' = push_rel (RelDecl.LocalAssum (na,c)) env in + let env' = push_rel (RelDecl.LocalAssum (na,c1)) env in let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env' evd (c'1, Stack.empty) in let out2 = whd_nored_state env' evd @@ -556,92 +625,48 @@ 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 on_left (_, skF as apprF) (_,skM as apprM) i = + let consume l2r (_, skF as apprF) (_,skM as apprM) i = if not (Stack.is_empty skF && Stack.is_empty skM) then - consume_stack on_left apprF apprM i + consume_stack l2r apprF apprM i else quick_fail i in - let miller on_left ev (termF,skF as apprF) (termM, skM as apprM) i = - let switch f a b = if on_left then f a b else f b a in + let miller l2r ev (termF,skF as apprF) (termM, skM as apprM) i = + let switch f a b = if l2r then f a b else f b a in let not_only_app = Stack.not_purely_applicative skM in match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> let tM = Stack.zip evd apprM in - miller_pfenning on_left + miller_pfenning l2r (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM else quick_fail i) ev lF tM i in - let flex_maybeflex on_left ev (termF,skF as apprF) (termM, skM as apprM) vM = - let switch f a b = if on_left then f a b else f b a in + let flex_maybeflex l2r ev (termF,skF as apprF) (termM, skM as apprM) vM = + (* Problem: E[?n[inst]] = E'[redex] + Strategy, as far as I understand: + 1. if E[]=[]u1..un and ?n[inst] u1..un = E'[redex] is a Miller pattern: solve it now + 2a. if E'=E'1[E'2] and E=E'1 unifiable, recursively solve ?n[inst] = E'2[redex] + 2b. if E'=E'1[E'2] and E=E1[E2] and E=E'1 unifiable and E' contient app/fix/proj, + recursively solve E2[?n[inst]] = E'2[redex] + 3. reduce the redex into M and recursively solve E[?n[inst]] =? E'[M] *) + let switch f a b = if l2r then f a b else f b a in let delta i = switch (evar_eqappr_x flags env i pbty) apprF (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) in - let default i = ise_try i [miller on_left ev apprF apprM; - consume on_left apprF apprM; + let default i = ise_try i [miller l2r ev apprF apprM; + consume l2r apprF apprM; delta] in match EConstr.kind evd termM with @@ -662,8 +687,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let delta' i = switch (evar_eqappr_x flags env i pbty) apprF apprM' in - fun i -> ise_try i [miller on_left ev apprF apprM'; - consume on_left apprF apprM'; delta'] + fun i -> ise_try i [miller l2r ev apprF apprM'; + consume l2r apprF apprM'; delta'] with Retyping.RetypeError _ -> (* Happens thanks to w_unify building ill-typed terms *) default @@ -671,21 +696,32 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty end | _ -> default evd in - let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) = - let switch f a b = if on_left then f a b else f b a in + let flex_rigid l2r ev (termF, skF as apprF) (termR, skR as apprR) = + (* Problem: E[?n[inst]] = E'[M] with M blocking computation (in theory) + Strategy, as far as I understand: + 1. if E[]=[]u1..un and ?n[inst] u1..un = E'[M] is a Miller pattern: solve it now + 2a. if E'=E'1[E'2] and E=E'1 unifiable and E' contient app/fix/proj, + recursively solve ?n[inst] = E'2[M] + 2b. if E'=E'1[E'2] and E=E1[E2] and E=E'1 unifiable and E' contient app/fix/proj, + recursively solve E2[?n[inst]] = E'2[M] + 3a. if M a lambda or a constructor: eta-expand and recursively solve + 3b. if M a constructor C ..ui..: eta-expand and recursively solve proji[E[?n[inst]]]=ui + 4. fail if E purely applicative and ?n occurs rigidly in E'[M] + 5. absorb arguments if purely applicative and postpone *) + let switch f a b = if l2r then f a b else f b a in let eta evd = match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> - eta env evd false skR termR skF termF - | Construct u -> eta_constructor flags env evd skR u skF termF + eta_lambda env evd false termR apprF + | Construct u -> eta_constructor flags env evd u skR apprF | _ -> UnifFailure (evd,NotSameHead) in match Stack.list_of_app_stack skF with | None -> - ise_try evd [consume_stack on_left apprF apprR; eta] + ise_try evd [consume_stack l2r apprF apprR; eta] | Some lF -> let tR = Stack.zip evd apprR in - miller_pfenning on_left + miller_pfenning l2r (fun () -> ise_try evd [eta;(* Postpone the use of an heuristic *) @@ -715,6 +751,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',term2) else + (* HH: Why not to drop sk1 and sk2 since they unified *) evar_eqappr_x flags env evd pbty (ev1', sk1) (term2, sk2) | Some (r,[]), Success i' -> @@ -735,7 +772,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty if isEvar i' ev1' then solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) - else evar_eqappr_x flags env evd pbty + else + (* HH: Why not to drop sk1 and sk2 since they unified *) + evar_eqappr_x flags env evd pbty (ev1', sk1) (term2, sk2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) @@ -763,7 +802,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else (* We could instead try Miller unification, then postpone to see if other equations help, as in: - [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) + [Check fun a b c : unit => (eq_refl : _ a b = _ c a b)] *) UnifFailure (i,NotSameArgSize) | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") in @@ -775,7 +814,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> - (* sk1[?ev1] =? sk2[?ev2] *) + (* Notations: + - "sk" is a stack (or, more abstractly, an evaluation context, written E) + - "ev" is an evar "?ev", more precisely an evar ?n with an instance inst + - "al" is an evar instance + Problem: E₁[?n₁[inst₁]] = E₂[?n₂[inst₂]] (i.e. sk1[?ev1] =? sk2[?ev2] + Strategy is first-order unification + 1a. if E₁=E₂ unifiable, solve ?n₁[inst₁] = ?n₂[inst₂] + 1b. if E₂=E₂'[E₂''] and E₁=E₂' unifiable, recursively solve ?n₁[inst₁] = E₂''[?n₂[inst₂]] + 1b'. if E₁=E₁'[E₁''] and E₁'=E₂ unifiable, recursively solve E₁''[?n₁[inst₁]] = ?n₂[inst₂] + recursively solve E2[?n[inst]] = E'2[redex] + 2. fails if neither E₁ nor E₂ is a prefix of the other *) let f1 i = first_order env i term1 term2 sk1 sk2 and f2 i = if Evar.equal sp1 sp2 then @@ -975,10 +1024,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* Eta-expansion *) | Rigid, _ when isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> - eta env evd true sk1 term1 sk2 term2 + eta_lambda env evd true term1 (term2,sk2) | _, Rigid when isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> - eta env evd false sk2 term2 sk1 term1 + eta_lambda env evd false term2 (term1,sk1) | Rigid, Rigid -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with @@ -1032,10 +1081,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else UnifFailure (evd,NotSameHead) | Construct u, _ -> - eta_constructor flags env evd sk1 u sk2 term2 + eta_constructor flags env evd u sk1 (term2,sk2) | _, Construct u -> - eta_constructor flags env evd sk2 u sk1 term1 + eta_constructor flags env evd u sk2 (term1,sk1) | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -1130,7 +1179,9 @@ and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk (fst (decompose_app_vect i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) -and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = +and eta_constructor flags env evd ((ind, i), u) sk1 (term2,sk2) = + (* reduces an equation <Construct(ind,i)|sk1> == <term2|sk2> to the + equations [arg_i = Proj_i (sk2[term2])] where [sk1] is [params args] *) let open Declarations in let mib = lookup_mind (fst ind) env in match get_projections env ind with @@ -1233,7 +1284,7 @@ let apply_on_subterm env evd fixed f test c t = if occur_evars !evdref !fixedref t then match EConstr.kind !evdref t with | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t - | _ -> map_constr_with_binders_left_to_right !evdref + | _ -> map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else @@ -1248,7 +1299,7 @@ let apply_on_subterm env evd fixed f test c t = evdref := evd'; t') else ( if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); - map_constr_with_binders_left_to_right !evdref + map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) in @@ -1338,7 +1389,7 @@ let thin_evars env sigma sign c = if not (Id.Set.mem id ctx) then raise (TypingFailed !sigma) else t | _ -> - map_constr_with_binders_left_to_right !sigma + map_constr_with_binders_left_to_right env !sigma (fun d (env,acc) -> (push_rel d env, acc+1)) applyrec (env,acc) t in 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/evarsolve.ml b/pretyping/evarsolve.ml index 44414aa6a0..cb3eef9df0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -232,7 +232,7 @@ let recheck_applications unify flags env evdref t = else () in aux 0 fty | _ -> - iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t + iter_with_full_binders env !evdref (fun d env -> push_rel d env) aux env t in aux env t @@ -304,7 +304,7 @@ let noccur_evar env evd evk c = | LocalAssum _ -> () | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr b))) | Proj (p,c) -> occur_rec true acc c - | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) + | _ -> iter_with_full_binders env evd (fun rd (k,env) -> (succ k, push_rel rd env)) (occur_rec check_types) acc c in try occur_rec false (0,env) c; true with Occur -> false @@ -490,14 +490,14 @@ let expansion_of_var sigma aliases x = | Some a, _ -> (true, Alias.repr sigma a) | None, a :: _ -> (true, Some a) -let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with +let rec expand_vars_in_term_using env sigma aliases t = match EConstr.kind sigma t with | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) | Var id -> of_alias (normalize_alias sigma aliases (VarAlias id)) | _ -> - let self aliases c = expand_vars_in_term_using sigma aliases c in - map_constr_with_full_binders sigma (extend_alias sigma) self aliases t + let self aliases c = expand_vars_in_term_using env sigma aliases c in + map_constr_with_full_binders env sigma (extend_alias sigma) self aliases t -let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) +let expand_vars_in_term env sigma = expand_vars_in_term_using env sigma (make_alias_map env sigma) let free_vars_and_rels_up_alias_expansion env sigma aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in @@ -533,7 +533,7 @@ let free_vars_and_rels_up_alias_expansion env sigma aliases c = | Const _ | Ind _ | Construct _ -> acc2 := Id.Set.union (vars_of_global env (fst @@ EConstr.destRef sigma c)) !acc2 | _ -> - iter_with_full_binders sigma + iter_with_full_binders env sigma (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) frec (aliases,depth) c in @@ -1585,7 +1585,16 @@ let rec invert_definition unify flags choose imitate_defs imitate envk (subst1 b c) | Evar (evk',args' as ev') -> if Evar.equal evk evk' then raise (OccurCheckIn (evd,rhs)); - (* Evar/Evar problem (but left evar is virtual) *) + (* At this point, we imitated a context say, C[ ], and virtually + instantiated ?evk@{x₁..xn} with C[?evk''@{x₁..xn,y₁..yk}] + for y₁..yk the spine of variables of C[ ], now facing the + equation env, y₁...yk |- ?evk'@{args'} =?= ?evk''@{args,y1:=y1..yk:=yk} *) + (* Assume evk' is defined in context x₁'..xk'. + As a first step, we try to find a restriction ?evk'''@{xᵢ₁'..xᵢⱼ} of + ?evk' and an instance args''' in the environment of ?evk such that + env, y₁..yk |- args'''[args] = args' and thus such that + env, y₁..yk |- ?evk'''@{args'''[args]} = ?evk''@{args,y1:=y1..yk:=yk} *) + (* Note that we don't need to declare ?evk'' yet: it may remain virtual *) let aliases = lift_aliases k aliases in (try let ev = (evk,List.map (lift k) argsv) in @@ -1597,14 +1606,14 @@ let rec invert_definition unify flags choose imitate_defs | CannotProject (evd,ev') -> if not !progress then raise (NotEnoughInformationEvarEvar t); - (* Make the virtual left evar real *) + (* We could not invert args' in terms of args, so we now make ?evk'' real *) let ty = get_type_of env' evd t in let (evd,evar'',ev'') = materialize_evar (evar_define unify flags ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) let (evk',args' as ev') = normalize_evar evd ev' in let evd = - (* Try to project (a restriction of) the left evar ... *) + (* Try now to invert args in terms of args' *) try let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in @@ -1636,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs let candidates = try let t = - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in (* Less dependent solutions come last *) l@[t] @@ -1650,7 +1659,7 @@ let rec invert_definition unify flags choose imitate_defs evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in let rhs = whd_beta env evd rhs (* heuristic *) in diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 094dae4828..d347f46637 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -136,6 +136,24 @@ val solve_evar_evar : ?force:bool -> (** The two evars are expected to be in inferably convertible types; if not, an exception IllTypedInstance is raised *) +(* [solve_simple_eqn unifier flags env evd (direction,?ev[inst],t)] + makes progresses on problems of the form [?ev[inst] := t] (or + [?ev[inst] :<= t], or [?ev[inst] :>= t]). It uses imitation and a + limited form of projection. At the time of writing this comment, + only rels/vars (possibly indirectly via a chain of evars) and + constructors are used for projection. For instance + [?e[x,S 0] := x + S 0] will be solved by imitating [+] and + projecting [x] and [S 0] (so that [?e[a,b]:=a+b]) but in + [?e[0+0] := 0+0], the possible imitation will not be seen. + + [choose] tells to make an irreversible choice when two valid + projections are competing. It is to be used when no more reversible + progress can be done. It is [false] by default. + + [imitate_defs] tells to expand local definitions if they cannot be + projected. It is [true] by default. +*) + val solve_simple_eqn : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> bool option * existential * constr -> unification_result diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index bd717e2d1f..9f84b7683f 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 -> @@ -100,57 +73,57 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, 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 replace_term_occ_gen_modulo env sigma occs like_first test bywhat cl occ t = + 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 + map_constr_with_binders_left_to_right env 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 replace_term_occ_modulo env evd occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in proceed_with_occurrences - (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t + (replace_term_occ_gen_modulo env evd occs' like_first test bywhat None) occs' t -let replace_term_occ_decl_modulo evd occs test bywhat d = +let replace_term_occ_decl_modulo env evd occs test bywhat d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo evd plocs like_first test bywhat) + (replace_term_occ_gen_modulo env evd plocs like_first test bywhat) hyploc) plocs d @@ -172,7 +145,7 @@ let make_eq_univs_test env evd c = let subst_closed_term_occ env evd occs c t = let test = make_eq_univs_test env evd c in let bywhat () = mkRel 1 in - let t' = replace_term_occ_modulo evd occs test bywhat t in + let t' = replace_term_occ_modulo env evd occs test bywhat t in t', test.testing_state let subst_closed_term_occ_decl env evd occs c d = @@ -182,6 +155,6 @@ let subst_closed_term_occ_decl env evd occs c d = let bywhat () = mkRel 1 in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo evd plocs like_first test bywhat None) + (fun _ -> replace_term_occ_gen_modulo env evd plocs like_first test bywhat None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 436b730a88..c71cb207ab 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -43,13 +43,13 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function matching subterms at the indicated occurrences [occl] with [mk ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) -val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> +val replace_term_occ_modulo : env -> evar_map -> occurrences or_like_first -> 'a testing_function -> (unit -> constr) -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : - evar_map -> + env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> named_declaration -> named_declaration @@ -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/heads.ml b/pretyping/heads.ml index d1ac0862ed..f6e45613e1 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -32,31 +32,29 @@ type head_approximation = | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead -(* FIXME: maybe change interface here *) -let rec compute_head env = function - | EvalConstRef cst -> - let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in - (match body with - | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head env c) - | EvalVarRef id -> - (match lookup_named id env with - | LocalDef (_,c,_) -> kind_of_head env c - | _ -> RigidHead RigidOther) +let rec compute_head_const env cst = + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c + +and compute_head_var env id = match lookup_named id env with +| LocalDef (_,c,_) -> kind_of_head env c +| _ -> RigidHead RigidOther and kind_of_head env t = let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> - (try on_subterm k l b (compute_head env (EvalVarRef id)) + (try on_subterm k l b (compute_head_var env id) with Not_found -> (* a goal variable *) match lookup_named id env with | LocalDef (_,c,_) -> aux k l c b | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> - (try on_subterm k l b (compute_head env (EvalConstRef cst)) + (try on_subterm k l b (compute_head_const env cst) with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ @@ -78,7 +76,7 @@ and kind_of_head env t = | App (c,al) -> aux k (Array.to_list al @ l) c b | Proj (p,c) -> RigidHead RigidOther - | Case (_,_,_,c,_) -> aux k [] c true + | Case (_,_,_,_,_,c,_) -> aux k [] c true | Int _ | Float _ | Array _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 5ffd919312..dd7cf8abaa 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -122,12 +122,24 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = | None -> let iv = make_case_invert env (find_rectype env sigma (EConstr.of_constr (lift 1 depind))) ci in let iv = EConstr.Unsafe.to_case_invert iv in - mkCase (ci, lift ndepar p, iv, mkRel 1, Termops.rel_vect ndepar k) + let ncons = Array.length mip.mind_consnames in + let mk_branch i = + (* eta-expansion to please branch contraction *) + let ft = get_type (lookup_rel (ncons - i) env) in + (* we need that to get the generated names for the branch *) + let (ctx, _) = decompose_prod_assum ft in + let n = mkRel (List.length ctx + 1) in + let args = Context.Rel.to_extended_vect mkRel 0 ctx in + let br = it_mkLambda_or_LetIn (mkApp (n, args)) ctx in + lift (ndepar + ncons - i - 1) br + in + let br = Array.init ncons mk_branch in + mkCase (Inductive.contract_case env (ci, lift ndepar p, iv, mkRel 1, br)) | Some ps -> let term = mkApp (mkRel 2, - Array.map - (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in + Array.map + (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in if dep then let ty = mkApp (mkRel 3, [| mkRel 1 |]) in mkCast (term, DEFAULTcast, ty) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 23145b1629..d02b015604 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 @@ -336,11 +344,7 @@ let get_projections = Environ.get_projections let make_case_invert env (IndType (((ind,u),params),indices)) ci = if Typeops.should_invert_case env ci - then - let univs = EConstr.EInstance.make u in - let params = Array.map_of_list EConstr.of_constr params in - let args = Array.append params (Array.of_list indices) in - CaseInvert {univs;args} + then CaseInvert {indices=Array.of_list indices} else NoInvert let make_case_or_project env sigma indt ci pred c branches = @@ -348,8 +352,7 @@ let make_case_or_project env sigma indt ci pred c branches = let IndType (((ind,_),_),_) = indt in let projs = get_projections env ind in match projs with - | None -> - mkCase (ci, pred, make_case_invert env indt ci, c, branches) + | None -> (mkCase (EConstr.contract_case env sigma (ci, pred, make_case_invert env indt ci, c, branches))) | Some ps -> assert(Array.length branches == 1); let na, ty, t = destLambda sigma pred in @@ -741,6 +744,6 @@ let control_only_guard env sigma c = in let rec iter env c = check_fix_cofix env c; - EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c + EConstr.iter_with_full_binders env sigma EConstr.push_rel iter env c in iter env c diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1e2bba9f73..8e83814fa0 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 @@ -209,7 +213,7 @@ val make_case_or_project : (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr val make_case_invert : env -> inductive_type -> case_info - -> (EConstr.constr,EConstr.EInstance.t) case_invert + -> EConstr.case_invert (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info 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/nativenorm.ml b/pretyping/nativenorm.ml index d06d6e01d1..92e412a537 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -320,13 +320,13 @@ and nf_atom_type env sigma atom = | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in - let iv = if Typeops.should_invert_case env ans.asw_ci then - CaseInvert {univs=u; args=allargs} - else NoInvert - in let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in + let iv = if Typeops.should_invert_case env ans.asw_ci then + CaseInvert {indices=realargs} + else NoInvert + in let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = hnf_prod_applist_assum env nparamdecls @@ -343,7 +343,8 @@ and nf_atom_type env sigma atom = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs a in - mkCase(ans.asw_ci, p, iv, a, branchs), tcase + let ci = ans.asw_ci in + mkCase (Inductive.contract_case env (ci, p, iv, a, branchs)), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in let tt = Array.map fst tt and rt = Array.map snd tt in diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index f6d61f4892..553511f1bf 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -18,7 +18,6 @@ type patvar = Id.t type case_info_pattern = { cip_style : Constr.case_style; cip_ind : inductive option; - cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) cip_extensible : bool (** does this match end with _ => _ ? *) } type constr_pattern = @@ -35,8 +34,8 @@ type constr_pattern = | PSort of Sorts.family | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern - | PCase of case_info_pattern * constr_pattern * constr_pattern * - (int * bool list * constr_pattern) list (** index of constructor, nb of args *) + | PCase of case_info_pattern * (Name.t array * constr_pattern) option * constr_pattern * + (int * Name.t array * constr_pattern) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) | PInt of Uint63.t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b259945d9e..0c4bbf71e2 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -24,7 +24,6 @@ open Environ let case_info_pattern_eq i1 i2 = i1.cip_style == i2.cip_style && Option.equal Ind.CanOrd.equal i1.cip_ind i2.cip_ind && - Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && i1.cip_extensible == i2.cip_extensible let rec constr_pattern_eq p1 p2 = match p1, p2 with @@ -51,7 +50,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 | PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> case_info_pattern_eq info1 info2 && - constr_pattern_eq p1 p2 && + Option.equal (fun (nas1, p1) (nas2, p2) -> Array.equal Name.equal nas1 nas2 && constr_pattern_eq p1 p2) p1 p2 && constr_pattern_eq r1 r2 && List.equal pattern_eq l1 l2 | PFix ((ln1,i1),f1), PFix ((ln2,i2),f2) -> @@ -74,7 +73,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = - Int.equal i1 i2 && List.equal (==) j1 j2 && constr_pattern_eq p1 p2 + Int.equal i1 i2 && Array.equal Name.equal j1 j2 && constr_pattern_eq p1 p2 and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = Array.equal Name.equal n1 n2 && @@ -92,8 +91,8 @@ let rec occur_meta_pattern = function | PIf (c,c1,c2) -> (occur_meta_pattern c) || (occur_meta_pattern c1) || (occur_meta_pattern c2) - | PCase(_,p,c,br) -> - (occur_meta_pattern p) || + | PCase(_, p,c,br) -> + Option.cata (fun (_, p) -> occur_meta_pattern p) false p || (occur_meta_pattern c) || (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PArray (t,def,ty) -> @@ -115,10 +114,10 @@ let rec occurn_pattern n = function | PIf (c,c1,c2) -> (occurn_pattern n c) || (occurn_pattern n c1) || (occurn_pattern n c2) - | PCase(_,p,c,br) -> - (occurn_pattern n p) || + | PCase(_, p, c, br) -> + Option.cata (fun (nas, p) -> occurn_pattern (Array.length nas + n) p) false p || (occurn_pattern n c) || - (List.exists (fun (_,_,p) -> occurn_pattern n p) br) + (List.exists (fun (_, nas, p) -> occurn_pattern (Array.length nas + n) p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false @@ -202,18 +201,26 @@ let pattern_of_constr env sigma t = | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) - | Case (ci,p,_,a,br) -> + | Case (ci, u, pms, p0, iv, a, br0) -> + let (ci, p, iv, a, br) = Inductive.expand_case env (ci, u, pms, p0, iv, a, br0) in + let pattern_of_ctx c (nas, c0) = + let ctx, c = Term.decompose_lam_n_decls (Array.length nas) c in + let env = push_rel_context ctx env in + let c = pattern_of_constr env c in + (Array.map Context.binder_name nas, c) + in + let p = pattern_of_ctx p p0 in let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; - cip_ind_tags = Some ci.ci_pp_info.ind_tags; cip_extensible = false } in let branch_of_constr i c = - (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) + let nas, c = pattern_of_ctx c br0.(i) in + (i, nas, c) in - PCase (cip, pattern_of_constr env p, pattern_of_constr env a, - Array.to_list (Array.mapi branch_of_constr br)) + PCase (cip, Some p, pattern_of_constr env a, + Array.to_list (Array.mapi branch_of_constr br)) | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in @@ -241,7 +248,10 @@ let map_pattern_with_binders g f l = function | PLetIn (n,a,t,b) -> PLetIn (n,f l a,Option.map (f l) t,f (g n l) b) | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> - PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + let fold nas l = Array.fold_left (fun l na -> g na l) l nas in + let map_branch (i, n, c) = (i, n, f (fold n l) c) in + let po = Option.map (fun (nas, po) -> nas, (f (fold nas l) po)) po in + PCase (ci,po,f l p, List.map map_branch pl) | PProj (p,pc) -> PProj (p, f l pc) | PFix (lni,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in @@ -351,7 +361,11 @@ let rec subst_pattern env sigma subst pat = let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in - let typ' = subst_pattern env sigma subst typ in + let map ((nas, typ) as t) = + let typ' = subst_pattern env sigma subst typ in + if typ' == typ then t else (nas, typ') + in + let typ' = Option.Smart.map map typ in let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = let c' = subst_pattern env sigma subst c in @@ -381,8 +395,6 @@ let rec subst_pattern env sigma subst pat = let mkPLetIn na b t c = PLetIn(na,b,t,c) let mkPProd na t u = PProd(na,t,u) let mkPLambda na t b = PLambda(na,t,b) -let mkPLambdaUntyped na b = PLambda(na,PMeta None,b) -let rev_it_mkPLambdaUntyped = List.fold_right mkPLambdaUntyped let mkPProd_or_LetIn (na,_,bo,t) c = match bo with @@ -445,18 +457,14 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> - let mkGLambda na c = DAst.make ?loc @@ - GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in - let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; cip_ind = None; - cip_ind_tags = None; cip_extensible = false } in - let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in - PCase (cip, PMeta None, pat_of_raw metas vars b, - [0,tags,pat_of_raw metas vars c]) + let tags = Array.of_list nal (* Approximation which can be without let-ins... *) in + PCase (cip, None, pat_of_raw metas vars b, + [0,tags,pat_of_raw metas (List.rev_append (Array.to_list tags) vars) c]) | GCases (sty,p,[c,(na,indnames)],brs) -> let get_ind p = match DAst.get p with | PatCstr((ind,_),_,_) -> Some ind @@ -475,18 +483,17 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function let pred = match p,indnames with | Some p, Some {CAst.v=(_,nal)} -> let nvars = na :: List.rev nal @ vars in - rev_it_mkPLambdaUntyped nal (mkPLambdaUntyped na (pat_of_raw metas nvars p)) - | None, _ -> PMeta None + Some (Array.rev_of_list (na :: List.rev nal), pat_of_raw metas nvars p) + | None, _ -> None | Some p, None -> match DAst.get p with - | GHole _ -> PMeta None + | GHole _ -> None | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; cip_ind = ind; - cip_ind_tags = None; cip_extensible = ext } in (* Nota : when we have a non-trivial predicate, @@ -555,10 +562,10 @@ and pats_of_glob_branches loc metas vars ind brs = err ?loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in - let vars' = List.rev lna @ vars in - let pat = rev_it_mkPLambdaUntyped lna (pat_of_raw metas vars' br) in + let vars' = List.rev_append lna vars in + let tags = Array.of_list lna in + let pat = pat_of_raw metas vars' br in let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in - let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) | _ -> err ?loc:loc' (Pp.str "Non supported pattern.") diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index b70ff20e32..e86a8a28c9 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 } @@ -1052,7 +1043,7 @@ struct if not record then let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info !!env (ind_of_ind_type indt) rci LetStyle in - mkCase (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|]) + mkCase (EConstr.contract_case !!env sigma (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|])) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) @@ -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 @@ -1168,7 +1159,7 @@ struct let pred = nf_evar sigma pred in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in let ci = make_case_info !!env (fst ind) rci IfStyle in - mkCase (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|]) + mkCase (EConstr.contract_case !!env sigma (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|])) in let cj = { uj_val = v; uj_type = p } in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon 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 3352bfce38..3da75f67b9 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -177,9 +177,12 @@ sig type 'a app_node val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -194,6 +197,7 @@ sig val append_app : 'a array -> 'a t -> 'a t val decomp : 'a t -> ('a * 'a t) option val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t) + val decomp_rev : 'a t -> ('a * 'a t) option val compare_shape : 'a t -> 'a t -> bool val map : ('a -> 'a) -> 'a t -> 'a t val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> @@ -214,13 +218,13 @@ end = struct open EConstr type 'a app_node = int * 'a array * int - (* first releavnt position, arguments, last relevant position *) + (* first relevant position, arguments, last relevant position *) (* - Invariant that this module must ensure : - (behare of direct access to app_node by the rest of Reductionops) + Invariant that this module must ensure: + (beware of direct access to app_node by the rest of Reductionops) - in app_node (i,_,j) i <= j - - There is no array realocation (outside of debug printing) + - There is no array reallocation (outside of debug printing) *) let pr_app_node pr (i,a,j) = @@ -229,9 +233,12 @@ struct ) + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -244,9 +251,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br) -> + | Case (_,_,_,_,_,br) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, c) -> pr_c c) br ++ str ")" | Proj p -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -267,12 +274,10 @@ struct let le = Array.length v in if Int.equal le 0 then s else App (0,v,pred le) :: s - let decomp_node (i,l,j) sk = - if i < j then (l.(i), App (succ i,l,j) :: sk) - else (l.(i), sk) - - let decomp = function - | App node::s -> Some (decomp_node node s) + let decomp_rev = function + | App (i,l,j) :: sk -> + if i < j then Some (l.(j), App (i,l,pred j) :: sk) + else Some (l.(j), sk) | _ -> None let decomp_node_last (i,l,j) sk = @@ -285,7 +290,7 @@ struct ([],[]) -> Int.equal bal 0 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 - | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> + | (Case _ :: s1, Case _::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Proj (p)::s1, Proj(p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 @@ -293,7 +298,7 @@ struct Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (Primitive(_,_,a1,_)::s1, Primitive(_,_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 - | ((Case _|Proj _|Fix _|Primitive _) :: _ | []) ,_ -> false in + | ((Case _ | Proj _ | Fix _ | Primitive _) :: _ | []) ,_ -> false in compare_rec 0 stk1 stk2 exception IncompatibleFold2 @@ -305,8 +310,9 @@ struct let t1,l1 = decomp_node_last n1 q1 in let t2,l2 = decomp_node_last n2 q2 in aux (f o t1 t2) l1 l2 - | Case (_,t1,_,a1) :: q1, Case (_,t2,_,a2) :: q2 -> - aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 + | Case ((_,_,pms1,(_, t1),_,a1)) :: q1, Case ((_,_,pms2, (_, t2),_,a2)) :: q2 -> + let f' o (_, t1) (_, t2) = f o t1 t2 in + aux (Array.fold_left2 f' (f (Array.fold_left2 f o pms1 pms2) t1 t2) a1 a2) q1 q2 | Proj (p1) :: q1, Proj (p2) :: q2 -> aux o q1 q2 | Fix ((_,(_,a1,b1)),s1) :: q1, Fix ((_,(_,a2,b2)),s2) :: q2 -> @@ -321,8 +327,8 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,iv,br) -> - Case (info, f ty, map_invert f iv, Array.map f br) + | Case (info,u,pms,ty,iv,br) -> + Case (info, u, Array.map f pms, on_snd f ty, iv, Array.map (on_snd f) br) | Fix ((r,(na,ty,bo)),arg) -> Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg) | Primitive (p,c,args,kargs) -> @@ -334,29 +340,35 @@ struct append_app a s let rec args_size = function - | App (i,_,j)::s -> j + 1 - i + args_size s - | (Case _|Fix _|Proj _|Primitive _)::_ | [] -> 0 + | App (i,_,j) :: s -> j + 1 - i + args_size s + | (Case _ | Fix _ | Proj _ | Primitive _) :: _ | [] -> 0 let strip_app s = let rec aux out = function | ( App _ as e) :: s -> aux (e :: out) s | s -> List.rev out,s in aux [] s + let strip_n_app n s = let rec aux n out = function | App (i,a,j) as e :: s -> - let nb = j - i + 1 in + let nb = j - i + 1 in if n >= nb then - aux (n - nb) (e::out) s + aux (n - nb) (e :: out) s else - let p = i+n in + let p = i + n in Some (CList.rev (if Int.equal n 0 then out else App (i,a,p-1) :: out), a.(p), - if j > p then App(succ p,a,j)::s else s) + if j > p then App (succ p,a,j) :: s else s) | s -> None in aux n [] s + let decomp s = + match strip_n_app 0 s with + | Some (_,a,s) -> Some (a,s) + | None -> None + let not_purely_applicative args = List.exists (function (Fix _ | Case _ | Proj _ ) -> true | App _ | Primitive _ -> false) args @@ -369,12 +381,11 @@ struct (Array.fold_right (fun x y -> x::y) a' args', s') | s -> ([],s) in let (out,s') = aux s in - let init = match s' with [] -> true | _ -> false in - Option.init init out + match s' with [] -> Some out | _ -> None let assign s p c = match strip_n_app p s with - | Some (pre,_,sk) -> pre @ (App (0,[|c|],0)::sk) + | Some (pre,_,sk) -> pre @ (App (0,[|c|],0) :: sk) | None -> assert false let tail n0 s0 = @@ -382,12 +393,12 @@ struct if Int.equal n 0 then s else match s with | App (i,a,j) :: s -> - let nb = j - i + 1 in + let nb = j - i + 1 in if n >= nb then aux (n - nb) s else let p = i+n in - if j >= p then App(p,a,j)::s else s + if j >= p then App (p,a,j) :: s else s | _ -> raise (Invalid_argument "Reductionops.Stack.tail") in aux n0 s0 @@ -404,7 +415,7 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case (ci,u,pms,rt,iv,br)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st)::s) -> zip (mkFix fix, st @ (append_app [|f|] s)) | f, (Proj (p)::s) -> zip (mkProj (p,f),s) @@ -465,13 +476,13 @@ let strong_with_flags whdfun flags env sigma t = | d -> d in push_rel d env in let rec strongrec env t = - map_constr_with_full_binders sigma + map_constr_with_full_binders env sigma push_rel_check_zeta strongrec env (whdfun flags env sigma t) in strongrec env t let strong whdfun env sigma t = let rec strongrec env t = - map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in + map_constr_with_full_binders env sigma push_rel strongrec env (whdfun env sigma t) in strongrec env t (*************************************) @@ -698,6 +709,20 @@ let debug_RAKAM = ~key:["Debug";"RAKAM"] ~value:false +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + let subst = List.rev args in + Vars.substl subst (snd br) + else + (* For backwards compat with unification, we do not reduce the let-bindings + upfront. *) + let ctx = expand_branch env sigma u pms (ind, i) br in + applist (it_mkLambda_or_LetIn (snd br) ctx, args) + let rec whd_state_gen flags env sigma = let open Context.Named.Declaration in let rec whrec (x, stack) : state = @@ -781,8 +806,8 @@ let rec whd_state_gen flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -790,13 +815,14 @@ let rec whd_state_gen flags env sigma = |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p)::s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> @@ -846,7 +872,7 @@ let rec whd_state_gen flags env sigma = whrec (** reduction machine without global env and refold machinery *) -let local_whd_state_gen flags _env sigma = +let local_whd_state_gen flags env sigma = let rec whrec (x, stack) = let c0 = EConstr.kind sigma x in let s = (EConstr.of_kind c0, stack) in @@ -878,8 +904,8 @@ let local_whd_state_gen flags _env sigma = | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> (whrec (c, Stack.Proj (p) :: stack)) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -892,13 +918,14 @@ let local_whd_state_gen flags _env sigma = Some c -> whrec (c,stack) | None -> s) - | Construct ((ind,c),u) -> + | Construct (cstr, u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case :: s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p) :: s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> @@ -930,14 +957,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)) @@ -1192,11 +1211,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 @@ -1205,7 +1228,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 @@ -1216,12 +1239,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: @@ -1423,23 +1445,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 d404a7e414..59bc4a8b72 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -57,9 +57,12 @@ module Stack : sig val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -69,10 +72,9 @@ module Stack : sig val empty : 'a t val is_empty : 'a t -> bool - val append_app : 'a array -> 'a t -> 'a t - val decomp : 'a t -> ('a * 'a t) option val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t) + [@@ocaml.deprecated "Use decomp_rev"] val compare_shape : 'a t -> 'a t -> bool @@ -84,30 +86,56 @@ module Stack : sig val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> constr t -> constr t -> 'a val map : ('a -> 'a) -> 'a t -> 'a t + + (** [append_app args sk] pushes array of arguments [args] on [sk] *) + val append_app : 'a array -> 'a t -> 'a t + + (** [append_app_list args sk] pushes list of arguments [args] on [sk] *) val append_app_list : 'a list -> 'a t -> 'a t - (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not - start by App *) + (** if [strip_app sk] = [(sk1,sk2)], then [sk = sk1 @ sk2] with + [sk1] purely applicative and [sk2] does not start with an argument *) val strip_app : 'a t -> 'a t * 'a t - (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) + (** @return (the nth first elements, the (n+1)th element, the remaining stack) + if there enough of those *) val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option + (** [decomp sk] extracts the first argument of [sk] is there is some *) + val decomp : 'a t -> ('a * 'a t) option + + (** [decomp sk] extracts the first argument of reversed stack [sk] is there is some *) + val decomp_rev : 'a t -> ('a * 'a t) option + + (** [not_purely_applicative sk] *) val not_purely_applicative : 'a t -> bool + + (** [list_of_app_stack sk] either returns [Some sk] turned into a list of + arguments if [sk] is purely applicative and [None] otherwise *) val list_of_app_stack : constr t -> constr list option + (** [assign sk n a] changes the [n]th argument of [sk] with [a], counting from 0 + @raise an anomaly if there is less that [n] arguments available *) val assign : 'a t -> int -> 'a -> 'a t + + (** [args_size sk] returns the number of arguments available at the + head of [sk] *) val args_size : 'a t -> int + + (** [tail n sk] drops the [n] first arguments of [sk] + @raise [Invalid_argument] if there are not enough arguments *) val tail : int -> 'a t -> 'a t + + (** [nth sk n] returns the [n]-th argument of [sk], counting from 0 + @raise [Not_found] if there is no [n]th argument *) val nth : 'a t -> int -> 'a + (** [zip sigma t sk] *) val zip : evar_map -> constr * constr t -> constr 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 @@ -115,11 +143,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 : @@ -127,12 +150,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 @@ -166,24 +183,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 @@ -269,11 +275,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/retyping.ml b/pretyping/retyping.ml index 34bcd0982c..064990f6bf 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -129,7 +129,8 @@ let retype ?(polyprop=true) sigma = | Evar ev -> existential_type sigma ev | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) - | Case (_,p,_iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> + let (_,p,iv,c,lf) = EConstr.expand_case env sigma (ci,u,pms,p,iv,c,lf) in let Inductiveops.IndType(indf,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t @@ -309,7 +310,7 @@ let relevance_of_term env sigma c = | Const (c,_) -> Relevanceops.relevance_of_constant env c | Ind _ -> Sorts.Relevant | Construct (c,_) -> Relevanceops.relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> Relevanceops.relevance_of_projection env p diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9cf7119709..01819a650b 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -43,6 +43,25 @@ exception ReductionTacticError of reduction_tactic_error exception Elimconst exception Redelimination +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +(* Better to have it here that in closure, since used in grammar.cma *) +let eq_egr e1 e2 = match e1, e2 with + EvalConstRef con1, EvalConstRef con2 -> Constant.CanOrd.equal con1 con2 + | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 + | _, _ -> false + +(* Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +let subst_evaluable_reference subst = function + | EvalVarRef id -> EvalVarRef id + | EvalConstRef kn -> EvalConstRef (Mod_subst.subst_constant subst kn) + let error_not_evaluable r = user_err ~hdr:"error_not_evaluable" (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ @@ -277,8 +296,8 @@ let compute_consteval_direct env sigma ref = | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) - | Case (_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n - | Case (_,_,_,d,_) -> srec env n labs true d + | Case (_,_,_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n + | Case (_,_,_,_,_,d,_) -> srec env n labs true d | Proj (p, d) when isRel sigma d -> EliminationProj n | _ -> NotAnElimination in @@ -459,29 +478,36 @@ let contract_cofix_use_function env sigma f sigma (nf_beta env sigma bodies.(bodynum)) type 'a miota_args = { - mP : constr; (** the result type *) + mU : EInstance.t; (* Universe instance of the return clause *) + mParams : constr array; (* Parameters of the inductive *) + mP : case_return; (* the result type *) mconstr : constr; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) - mlf : 'a array } (** the branch code vector *) + mlf : 'a pcase_branch array } (** the branch code vector *) -let reduce_mind_case sigma mia = +let reduce_mind_case env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) + | Construct ((_, i as cstr), u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1),real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix cofix -> let cofix_def = contract_cofix sigma cofix in (* XXX Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> + | Construct ((_, i as cstr),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1), real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> let build_cofix_name = if isConst sigma func then @@ -507,8 +533,7 @@ let reduce_mind_case_use_function func env sigma mia = fun _ -> None in let cofix_def = contract_cofix_use_function env sigma build_cofix_name cofix in - (* Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -709,9 +734,9 @@ and whd_simpl_stack env sigma = | LetIn (n,b,t,c) -> redrec (Vars.substl [b] c, stack) | App (f,cl) -> assert false (* see push_app above *) | Cast (c,_,_) -> redrec (c, stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - redrec (special_red_case env sigma (ci,p,iv,c,lf), stack) + redrec (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> s') | Fix fix -> @@ -823,15 +848,15 @@ and reduce_proj env sigma c = let proj_narg = Projection.npars proj + Projection.arg proj in List.nth cargs proj_narg | _ -> raise Redelimination) - | Case (n,p,iv,c,brs) -> + | Case (n,u,pms,p,iv,c,brs) -> let c' = redrec c in - let p = (n,p,iv,c',brs) in + let p = (n,u,pms,p,iv,c',brs) in (try special_red_case env sigma p with Redelimination -> mkCase p) | _ -> raise Redelimination in redrec c -and special_red_case env sigma (ci, p, iv, c, lf) = +and special_red_case env sigma (ci, u, pms, p, iv, c, lf) = let rec redrec s = let (constr, cargs) = whd_simpl_stack env sigma s in match match_eval_ref env sigma constr cargs with @@ -841,14 +866,14 @@ and special_red_case env sigma (ci, p, iv, c, lf) = | Some gvalue -> if reducible_mind_case sigma gvalue then reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; + {mP=p; mU = u; mParams = pms; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} else redrec (gvalue, cargs)) | None -> if reducible_mind_case sigma constr then - reduce_mind_case sigma - {mP=p; mconstr=constr; mcargs=cargs; + reduce_mind_case env sigma + {mP=p; mU = u; mParams = pms; mconstr=constr; mcargs=cargs; mci=ci; mlf=lf} else raise Redelimination @@ -896,7 +921,7 @@ let try_red_product env sigma c = let open Context.Rel.Declaration in mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) - | Case (ci,p,iv,d,lf) -> simpfun (mkCase (ci,p,iv,redrec env d,lf)) + | Case (ci,u,pms,p,iv,d,lf) -> simpfun (mkCase (ci,u,pms,p,iv,redrec env d,lf)) | Proj (p, c) -> let c' = match EConstr.kind sigma c with @@ -1043,31 +1068,26 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = (* Still the same projection, we ignore the change in parameters *) mkProj (p, a') else mkApp (app', [| a' |]) - | _ -> map_constr_with_binders_left_to_right sigma g f acc c + | _ -> map_constr_with_binders_left_to_right env 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 +1107,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 +1125,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 + map_constr_with_binders_left_to_right env 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 +1171,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 = @@ -1293,9 +1301,9 @@ let one_step_reduce env sigma c = | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - (special_red_case env sigma (ci,p,iv,c,lf), stack) + (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> (try match reduce_fix env sigma fix stack with diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 65e3421736..aa232175bb 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -18,6 +18,21 @@ open Locus open Univ open Ltac_pretype +(* XXX: Move to a module *) +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool + +(** Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +val subst_evaluable_reference : + Mod_subst.substitution -> evaluable_global_reference -> evaluable_global_reference + type reduction_tactic_error = InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index aeb3873de7..5b8b367ff2 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 @@ -178,7 +178,7 @@ let type_case_branches env sigma (ind,largs) pj c = let ty = whd_betaiota env sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in sigma, (lc, ty, Sorts.relevance_of_sort ps) -let judge_of_case env sigma ci pj iv cj lfj = +let judge_of_case env sigma case ci pj iv cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in @@ -189,7 +189,7 @@ let judge_of_case env sigma ci pj iv cj lfj = let () = if (match iv with | NoInvert -> false | CaseInvert _ -> true) != should_invert_case env ci then Type_errors.error_bad_invert env in - sigma, { uj_val = mkCase (ci, pj.uj_val, iv, cj.uj_val, Array.map j_val lfj); + sigma, { uj_val = mkCase case; uj_type = rslty } let check_type_fixpoint ?loc env sigma lna lar vdefj = @@ -383,20 +383,23 @@ let rec execute env sigma cstr = let sigma, ty = type_of_constructor env sigma ctor in sigma, make_judge cstr ty - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + let case = (ci, u, pms, p, iv, c, lf) in + let (ci, p, iv, c, lf) = EConstr.expand_case env sigma case in let sigma, cj = execute env sigma c in let sigma, pj = execute env sigma p in let sigma, lfj = execute_array env sigma lf in let sigma = match iv with | NoInvert -> sigma - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let t = mkApp (mkIndU (ci.ci_ind,u), args) in let sigma, tj = execute env sigma t in let sigma, tj = type_judgment env sigma tj in let sigma = check_actual_type env sigma cj tj.utj_val in sigma in - judge_of_case env sigma ci pj iv cj lfj + judge_of_case env sigma case ci pj iv cj lfj | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 1c24578a1c..83e46e3295 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -563,7 +563,7 @@ let is_rigid_head sigma flags t = | Construct _ | Int _ | Float _ | Array _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ - | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _, _) + | Lambda _ | LetIn _ | App (_, _) | Case _ | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -652,7 +652,7 @@ let rec is_neutral env sigma ts t = not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true - | Case (_, p, _, c, _) -> is_neutral env sigma ts c + | Case (_, _, _, _, _, c, _) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) @@ -698,6 +698,16 @@ let careful_infer_conv ~pb ~ts env sigma m n = (fun sigma -> infer_conv ~pb ~ts env sigma m n) else infer_conv ~pb ~ts env sigma m n +type maybe_ground = Ground | NotGround | Unknown + +let error_cannot_unify_local env sigma (m, n, p) = + error_cannot_unify_local env sigma (fst m, fst n, p) + +let fast_occur_meta_or_undefined_evar sigma (c, gnd) = match gnd with +| Unknown -> occur_meta_or_undefined_evar sigma c +| Ground -> false +| NotGround -> true + let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm @@ -795,7 +805,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else Evd.set_eq_sort curenv sigma s1 s2 in (sigma', metasubst, evarsubst) with e when CErrors.noncritical e -> - error_cannot_unify curenv sigma (m,n)) + error_cannot_unify curenv sigma (fst m,fst n)) | Lambda (na,t1,c1), Lambda (__,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} @@ -853,7 +863,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) - | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> + | Case (ci1, u1, pms1, p1, iv1, c1, cl1), Case (ci2, u2, pms2, p2, iv2, c2, cl2) -> + let (ci1, p1, iv1, c1, cl1) = EConstr.expand_case env sigma (ci1, u1, pms1, p1, iv1, c1, cl1) in + let (ci2, p2, iv2, c2, cl2) = EConstr.expand_case env sigma (ci2, u2, pms2, p2, iv2, c2, cl2) in (try if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in @@ -963,7 +975,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e modulo_delta = TransparentState.full; modulo_eta = true; modulo_betaiota = true } - ty1 ty2 + (ty1, Unknown) (ty2, Unknown) with RetypeError _ -> substn and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = @@ -1070,10 +1082,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 +1096,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) @@ -1133,10 +1143,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e try let res = if subterm_restriction opt flags || - occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n + fast_occur_meta_or_undefined_evar sigma m || fast_occur_meta_or_undefined_evar sigma n then None else + let (m, _) = m in + let (n, _) = n in let ans = match flags.modulo_conv_on_closed_terms with | Some convflags -> careful_infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in @@ -1152,7 +1164,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e in let a = match res with | Some sigma -> sigma, ms, es - | None -> unirec_rec (env,0) cv_pb opt subst m n in + | None -> unirec_rec (env,0) cv_pb opt subst (fst m) (fst n) in if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); a with e -> @@ -1160,7 +1172,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); Exninfo.iraise e -let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env +let unify_0 env sigma pb flags c1 c2 = + unify_0_with_initial_metas (sigma,[],[]) true env pb flags (c1, Unknown) (c2, Unknown) let left = true let right = false @@ -1494,13 +1507,13 @@ let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta sigma (head_app env sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma n) - (get_type_of env sigma m) + (get_type_of env sigma n, Unknown) + (get_type_of env sigma m, Unknown) else if isEvar_or_Meta sigma (head_app env sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma m) - (get_type_of env sigma n) + (get_type_of env sigma m, Unknown) + (get_type_of env sigma n, Unknown) else subst let try_resolve_typeclasses env evd flag m n = @@ -1511,7 +1524,7 @@ let try_resolve_typeclasses env evd flag m n = let w_unify_core_0 env evd with_types cv_pb flags m n = let (mc1,evd') = retract_coercible_metas evd in - let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) m n in + let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) (fst m) (fst n) in let subst2 = unify_0_with_initial_metas (sigma,ms,es) false env cv_pb flags.core_unify_flags m n @@ -1524,7 +1537,7 @@ let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in - let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in + let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags (m, Unknown) (n, Unknown) in let subst = fold_subst (evd', [], []) f1 f2 in let subst = Array.fold_left2 fold_subst subst l1 l2 in let evd = w_merge env true flags.merge_unify_flags subst in @@ -1611,6 +1624,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in + let cgnd = if occur_meta_or_undefined_evar sigma c then NotGround else Ground in let matching_fun _ t = try let t',l2 = @@ -1624,7 +1638,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else applist (t,l1), l2 else t, [] in - let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in + let sigma = w_typed_unify env sigma Reduction.CONV flags (c, cgnd) (t', Unknown) in let ty = Retyping.get_type_of env sigma t in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) @@ -1680,7 +1694,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma occ test mkvarid d in if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl && not (indirectly_dependent sigma c d depdecls) then @@ -1691,7 +1705,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo sigma (AtOccs occ) test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma (AtOccs occ) test mkvarid d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1701,7 +1715,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo sigma occ test mkvarid concl + replace_term_occ_modulo env sigma occ test mkvarid concl in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in @@ -1765,6 +1779,7 @@ let keyed_unify env evd kop = let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in let kop = Keys.constr_key (fun c -> EConstr.kind evd c) op in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (try @@ -1774,7 +1789,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let f1, l1 = decompose_app_vect evd op in let f2, l2 = decompose_app_vect evd cl in w_typed_unify_array env evd flags f1 l1 f2 l2,cl - else w_typed_unify env evd CONV flags op cl,cl + else w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; user_err Pp.(str "Unsat")) else user_err Pp.(str "Bound 1") @@ -1789,11 +1804,11 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c1 with ex when precatchable_exception ex -> matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when precatchable_exception ex -> - iter_fail matchrec lf) + iter_fail matchrec (Array.map snd lf)) | LetIn(_,c1,_,c2) -> (try matchrec c1 @@ -1869,11 +1884,12 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = else bind (f a.(i)) (ffail (i+1)) in ffail 0 in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (bind (if closed0 evd cl - then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) + then return (fun () -> w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl) else fail "Bound 1") (match EConstr.kind evd cl with | App (f,args) -> @@ -1883,8 +1899,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) - bind (matchrec c) (bind_iter matchrec lf) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) + bind (matchrec c) (bind_iter matchrec (Array.map snd lf)) | Proj (p,c) -> matchrec c @@ -2052,7 +2068,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = raise ex) (* General case: try first order *) - | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + | _ -> w_typed_unify env evd cv_pb flags (ty1, Unknown) (ty2, Unknown) (* Profiling *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 077597c278..c4de353d18 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -116,13 +116,3 @@ val unify_0 : Environ.env -> types -> types -> subst0 - -val unify_0_with_initial_metas : - subst0 -> - bool -> - Environ.env -> - Evd.conv_pb -> - core_unify_flags -> - types -> - types -> - subst0 diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 1420401875..cf6d581066 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -284,10 +284,10 @@ and nf_stk ?from:(from=0) env sigma c t stk = let tcase = build_case_type p realargs c in let ci = Inductiveops.make_case_info env ind relevance RegularStyle in let iv = if Typeops.should_invert_case env ci then - CaseInvert {univs=u; args=allargs} + CaseInvert {indices=realargs} else NoInvert in - nf_stk env sigma (mkCase(ci, p, iv, c, branchs)) tcase stk + nf_stk env sigma (mkCase (Inductive.contract_case env (ci, p, iv, c, branchs))) tcase stk | Zproj p :: stk -> assert (from = 0) ; let p' = Projection.make p true in 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..ca9dee2df6 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)) @@ -480,7 +480,7 @@ let pr_goal_name sigma g = let pr_goal_header nme sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in - str "subgoal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") + str "goal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ()) (* display the conclusion of a goal *) @@ -753,10 +753,10 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | [] -> let exl = Evd.undefined_map sigma in if Evar.Map.is_empty exl then - v 0 (str "No more subgoals." ++ pr_evar_info None sigma seeds) + v 0 (str "No more goals." ++ pr_evar_info None sigma seeds) else let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in - v 0 ((str "No more subgoals," + v 0 ((str "No more goals," ++ str " but there are non-instantiated existential variables:" ++ cut () ++ (hov 0 pei) ++ pr_evar_info None sigma seeds @@ -765,9 +765,9 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let goals = print_multiple_goals g1 rest in let ngoals = List.length rest+1 in v 0 ( - int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") + int ngoals ++ focused_if_needed ++ str(String.plural ngoals "goal") ++ print_extra - ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", subgoal 1" else "") + ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", goal 1" else "") ++ (if pr_first && should_tag() then pr_goal_tag g1 else str"") ++ (if pr_first then pr_goal_name sigma g1 else mt()) ++ cut () ++ goals ++ (if unfocused=[] then str "" @@ -792,7 +792,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = begin match bgoals,shelf,given_up with | [] , [] , g when Evar.Set.is_empty g -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals | [] , [] , _ -> - Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); + Feedback.msg_info (str "No more goals, but there are some goals you gave up:"); fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:(Evar.Set.elements given_up) ++ fnl () ++ str "You need to go back and solve them." diff --git a/printing/printer.mli b/printing/printer.mli index ea388ae57e..524c715455 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 @@ -154,7 +154,7 @@ val pr_existential_key : evar_map -> Evar.t -> Pp.t val pr_existential : env -> evar_map -> existential -> Pp.t val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t -val pr_evaluable_reference : evaluable_global_reference -> Pp.t +val pr_evaluable_reference : Tacred.evaluable_global_reference -> Pp.t val pr_pconstant : env -> evar_map -> pconstant -> Pp.t val pr_pinductive : env -> evar_map -> pinductive -> Pp.t diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 387f0f6f5f..44d3b44077 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 @@ -253,7 +268,7 @@ let meta_reducible_instance env evd b = let rec irec u = let u = whd_betaiota env Evd.empty u (* FIXME *) in match EConstr.kind evd u with - | Case (ci,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + | Case (ci,u,pms,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in (match try @@ -262,8 +277,10 @@ let meta_reducible_instance env evd b = if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with - | Some g -> irec (mkCase (ci,p,iv,g,bl)) - | None -> mkCase (ci,irec p,iv,c,Array.map irec bl)) + | Some g -> irec (mkCase (ci,u,pms,p,iv,g,bl)) + | None -> + let on_ctx (na, c) = (na, irec c) in + mkCase (ci,u,Array.map irec pms,on_ctx p,iv,c,Array.map on_ctx bl)) | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> let m = destMeta evd (strip_outer_cast evd f) in (match @@ -297,11 +314,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 +430,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 +556,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 @@ -611,8 +629,10 @@ let clenv_cast_meta clenv = else mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,iv,c,br) -> - mkCase (ci, crec_hd p, map_invert crec_hd iv, crec_hd c, Array.map crec br) + | Case(ci,u,pms,p,iv,c,br) -> + (* FIXME: we only change c because [p] is always a lambda and [br] is + most of the time??? *) + mkCase (ci, u, pms, p, iv, crec_hd c, br) | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in @@ -640,7 +660,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/logic.ml b/proofs/logic.ml index f159395177..8b31c07f5e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -265,15 +265,12 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | Case(ci,p,iv,c,br) -> - (* Hack assuming only two situations: the legacy one that branches, - if with Metas, are Meta, and the new one with eta-let-expanded - branches *) - let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in - let acc = Constr.fold (collrec deep) acc p in + | Case(ci,u,pms,p,iv,c,br) -> + let acc = Array.fold_left (collrec deep) acc pms in + let acc = Constr.fold (collrec deep) acc (snd p) in let acc = Constr.fold_invert (collrec deep) acc iv in let acc = Constr.fold (collrec deep) acc c in - Array.fold_left (collrec deep) acc br + Array.fold_left (fun accu (_, br) -> collrec deep accu br) acc br | App _ -> Constr.fold (collrec deep) acc c | Proj (_, c) -> collrec deep acc c | _ -> Constr.fold (collrec true) acc c @@ -369,15 +366,16 @@ let rec mk_refgoals ~check env sigma goalacc conclty trm = let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX Is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -418,14 +416,15 @@ and mk_hdgoals ~check env sigma goalacc trm = let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -479,13 +478,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = | App (f,cl) -> (f, cl) | _ -> (c,[||]) in Array.fold_left3 - (fun (lacc,sigma,bacc) ty fi l -> - if isMeta (strip_outer_cast fi) then - (* Support for non-eta-let-expanded Meta as found in *) - (* destruct/case with an non eta-let expanded elimination scheme *) - let (r,_,s,fi') = mk_refgoals ~check env sigma lacc ty fi in - r,s,(fi'::bacc) - else + (fun (lacc,sigma,bacc) ty fi n -> (* Deal with a branch in expanded form of the form Case(ci,p,c,[|eta-let-exp(Meta);...;eta-let-exp(Meta)|]) as if it were not so, so as to preserve compatibility with when @@ -494,7 +487,6 @@ and treat_case ~check env sigma ci lbrty lf acc' = CAUTION: it does not deal with the general case of eta-zeta reduced branches having a form different from Meta, as it would be theoretically the case with third-party code *) - let n = List.length l in let ctx, body = Term.decompose_lam_n_decls n fi in let head, args = decompose_app_vect body in (* Strip cast because clenv_cast_meta adds a cast when the branch is @@ -503,8 +495,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let head = strip_outer_cast head in if isMeta head then begin assert (args = Context.Rel.to_extended_vect mkRel 0 ctx); - let head' = lift (-n) head in - let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head' in + let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head in let fi' = it_mkLambda_or_LetIn (mkApp (head'',args)) ctx in (r,s,fi'::bacc) end @@ -513,7 +504,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let sigma, t'ty = goal_type_of ~check env sigma fi in let sigma = check_conv_leq_goal ~check env sigma fi t'ty ty in (lacc,sigma,fi::bacc)) - (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags + (acc',sigma,[]) lbrty lf ci.ci_cstr_ndecls let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in 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/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 41cb7399da..dc5a1b0ac2 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -68,7 +68,7 @@ module Strict = struct match sugg with | NeedClosingBrace -> Pp.(str"Try unfocusing with \"}\".") | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> Pp.(str"No more subgoals.") + | ProofFinished -> Pp.(str"No more goals.") | Suggest b -> Pp.(str"Expecting " ++ pr_bullet b ++ str".") | Unfinished b -> Pp.(str"Current bullet " ++ pr_bullet b ++ str" is not finished.") diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 08f88d46c1..6a6dd783e4 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -69,7 +69,7 @@ val pf_reduce_to_atomic_ind : Goal.goal sigma -> types -> (inductive * EInst [@@ocaml.deprecated "Use Tacred.pf_reduce_to_atomic_ind"] val pf_compute : Goal.goal sigma -> constr -> constr [@@ocaml.deprecated "Use the version in Tacmach.New"] -val pf_unfoldn : (occurrences * evaluable_global_reference) list +val pf_unfoldn : (occurrences * Tacred.evaluable_global_reference) list -> Goal.goal sigma -> constr -> constr [@@ocaml.deprecated "Use Tacred.unfoldn"] 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/partac.ml b/stm/partac.ml index 8232b017f9..6143ac450b 100644 --- a/stm/partac.ml +++ b/stm/partac.ml @@ -125,7 +125,7 @@ end = struct (* {{{ *) str" existentials remain unsolved: " ++ prlist (Termops.pr_existential_key sigma) (Evar.Set.elements evars)) ) with e when CErrors.noncritical e -> - RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int r_goalno ++ str ")") + RespError (CErrors.print e ++ spc() ++ str "(for goal "++int r_goalno ++ str ")") let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name @@ -163,7 +163,7 @@ let enable_par ~nworkers = ComTactic.set_par_implementation let open TacTask in let results = (Proof.data p).Proof.goals |> CList.map_i (fun i g -> let g_solution, t_assign = - Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) + Future.create_delegate ~name:(Printf.sprintf "goal %d" i) (fun x -> x) in TaskQueue.enqueue_task queue ~cancel_switch:(ref false) 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/auto.ml b/tactics/auto.ml index 369508c2a3..353e138599 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -277,8 +277,8 @@ let hintmap_of env sigma secvars hdc concl = else Hint_db.map_auto env sigma ~secvars hdc concl let exists_evaluable_reference env = function - | EvalConstRef _ -> true - | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false + | Tacred.EvalConstRef _ -> true + | Tacred.EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 31873ea6b0..39959d6fb8 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -104,9 +104,11 @@ sig | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -121,7 +123,7 @@ sig val append_app : 'a array -> 'a t -> 'a t val decomp : 'a t -> ('a * 'a t) option val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool) - -> 'a t -> 'a t -> bool + -> ('a case_stk -> 'a case_stk -> bool) -> 'a t -> 'a t -> bool val strip_app : 'a t -> 'a t * 'a t val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option val will_expose_iota : 'a t -> bool @@ -156,9 +158,11 @@ struct | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -172,9 +176,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br,cst) -> + | Case ((_,_,_,_,_,br),cst) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, b) -> pr_c b) br ++ str ")" | Proj (p,cst) -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -221,7 +225,7 @@ struct if i < j then (l.(j), App (i,l,pred j) :: sk) else (l.(j), sk) - let equal f f_fix sk1 sk2 = + let equal f f_fix f_case sk1 sk2 = let equal_cst_member x y = match x, y with | Cst_const (c1,u1), Cst_const (c2, u2) -> @@ -236,8 +240,8 @@ struct let t1,s1' = decomp_node_last a1 s1 in let t2,s2' = decomp_node_last a2 s2 in (f t1 t2) && (equal_rec s1' s2') - | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> - f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 + | Case ((ci1,pms1,p1,t1,iv1,a1),_) :: s1, Case ((ci2,pms2,p2,iv2,t2,a2),_) :: s2 -> + f_case (ci1,pms1,p1,t1,iv1,a1) (ci2,pms2,p2,iv2,t2,a2) && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Projection.Repr.CanOrd.equal (Projection.repr p) (Projection.repr p2) && equal_rec s1 s2 @@ -284,7 +288,7 @@ struct let will_expose_iota args = List.exists - (function (Fix (_,_,l) | Case (_,_,_,_,l) | + (function (Fix (_,_,l) | Case (_,l) | Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args @@ -346,9 +350,9 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br,cst_l)::s) when refold -> - zip (best_state sigma (mkCase (ci,rt,iv,f,br), s) cst_l) - | f, (Case (ci,rt,iv,br,_)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case ((ci,u,pms,rt,iv,br),cst_l)::s) when refold -> + zip (best_state sigma (mkCase (ci,u,pms,rt,iv,f,br), s) cst_l) + | f, (Case ((ci,u,pms,rt,iv,br),_)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st,cst_l)::s) when refold -> zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) | f, (Fix (fix,st,_)::s) -> zip @@ -533,7 +537,26 @@ let debug_RAKAM = Reductionops.debug_RAKAM let equal_stacks sigma (x, l) (y, l') = let f_equal x y = eq_constr sigma x y in let eq_fix a b = f_equal (mkFix a) (mkFix b) in - Stack.equal f_equal eq_fix l l' && f_equal x y + let eq_case (ci1, u1, pms1, p1, _, br1) (ci2, u2, pms2, p2, _, br2) = + Array.equal f_equal pms1 pms2 && + f_equal (snd p1) (snd p2) && + Array.equal (fun (_, c1) (_, c2) -> f_equal c1 c2) br1 br2 + in + Stack.equal f_equal eq_fix eq_case l l' && f_equal x y + +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + let subst = + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + List.rev args + else + let ctx = expand_branch env sigma u pms (ind, i) br in + subst_of_rel_context_instance ctx args + in + Vars.substl subst (snd br) let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in @@ -699,8 +722,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec Cst_stack.empty (d, Stack.Case (ci,p,iv,lf,cst_l) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec Cst_stack.empty (d, Stack.Case ((ci,u,pms,p,iv,lf),cst_l) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -708,13 +731,14 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf,_)::s') when use_match -> - whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case(case,_)::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec Cst_stack.empty (r, s') |args, (Stack.Proj (p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9e66e8668f..d93501eea6 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1014,10 +1014,11 @@ let deps_of_constraints cstrs evm p = cstrs let evar_dependencies pred evm p = + let cache = Evarutil.create_undefined_evars_cache () in Evd.fold_undefined (fun ev evi _ -> if Evd.is_typeclass_evar evm ev && pred evm ev evi then - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + let evars = Evar.Set.add ev (Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi) in Intpart.union_set evars p else ()) evm () 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/eauto.ml b/tactics/eauto.ml index e920093648..20c557b282 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -386,6 +386,7 @@ let make_dimension n = function | Some d -> (false,d) let autounfolds ids csts gl cls = + let open Tacred in let hyps = Tacmach.New.pf_ids_of_hyps gl in let env = Tacmach.New.pf_env gl in let ids = List.filter (fun id -> List.mem id hyps && Tacred.is_evaluable env (EvalVarRef id)) ids in 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/eqschemes.ml b/tactics/eqschemes.ml index f90c143a1a..54e9a87c96 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -216,7 +216,7 @@ let build_sym_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat @@ -225,7 +225,7 @@ let build_sym_scheme env ind = rel_vect (2*nrealargs+2) nrealargs])), NoInvert, mkRel 1 (* varH *), - [|cstr (nrealargs+1)|])))) + [|cstr (nrealargs+1)|]))))) in c, UState.of_context_set ctx let sym_scheme_kind = @@ -279,13 +279,13 @@ let build_sym_involutive_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + (mkCase (Inductive.contract_case env (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat @@ -300,7 +300,7 @@ let build_sym_involutive_scheme env ind = mkRel 1|])), NoInvert, mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))) in (c, UState.of_context_set ctx) let sym_involutive_scheme_kind = @@ -437,11 +437,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in let main_body = - mkCase (ci, + mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, NoInvert, applied_sym_C 3, - [|mkVar varHC|]) + [|mkVar varHC|])) in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -451,7 +451,7 @@ let build_l2r_rew_scheme dep env ind kind = (mkNamedLambda (make_annot varHC indr) applied_PC (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) (if dep then (* we need a coercion *) - mkCase (cieq, + mkCase (Inductive.contract_case env (cieq, mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), @@ -459,7 +459,7 @@ let build_l2r_rew_scheme dep env ind kind = NoInvert, mkApp (sym_involutive, Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), - [|main_body|]) + [|main_body|])) else main_body)))))) in (c, UState.of_context_set ctx) @@ -540,7 +540,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda (make_annot varH indr) applied_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkNamedProd (make_annot varP indr) @@ -553,7 +553,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda (make_annot varHC indr) applied_PC' - (mkVar varHC))|]))))) + (mkVar varHC))|])))))) in c, UState.of_context_set ctx (**********************************************************************) @@ -620,7 +620,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = (if dep then realsign_ind else realsign)) s) (mkNamedLambda (make_annot varHC indr) (lift 1 applied_PG) (mkApp - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), @@ -629,7 +629,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = [|mkLambda (make_annot (Name varHC) indr, lift (nrealargs+3) applied_PC, - mkRel 1)|]), + mkRel 1)|])), [|mkVar varHC|])))))) in c, UState.of_context_set ctx @@ -825,7 +825,7 @@ let build_congr env (eq,refl,ctx) ind = (mkIndU indu, Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ Context.Rel.to_extended_list mkRel 0 realsign)) - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda @@ -843,7 +843,7 @@ let build_congr env (eq,refl,ctx) ind = mkVar varH, [|mkApp (refl, [|mkVar varB; - mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))) in c, UState.of_context_set ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" 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..a9100efddb 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 @@ -73,7 +76,7 @@ type 'a and_short_name = 'a * Names.lident option let wit_red_expr : ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (Genintern.glob_constr_and_expr,Names.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, - (EConstr.t,Names.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) + (Genintern.glob_constr_and_expr,Tacred.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, + (EConstr.t,Tacred.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) Genarg.genarg_type = make0 "redexpr" diff --git a/tactics/hints.ml b/tactics/hints.ml index 6fab111e6f..0cc8becd8f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -46,7 +46,7 @@ let rec head_bound sigma t = match EConstr.kind sigma t with | Prod (_, _, b) -> head_bound sigma b | LetIn (_, _, _, b) -> head_bound sigma b | App (c, _) -> head_bound sigma c -| Case (_, _, _, c, _) -> head_bound sigma c +| Case (_, _, _, _, _, c, _) -> head_bound sigma c | Ind (ind, _) -> GlobRef.IndRef ind | Const (c, _) -> GlobRef.ConstRef c | Construct (c, _) -> GlobRef.ConstructRef c @@ -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 @@ -593,7 +591,7 @@ struct let head_evar sigma c = let rec hrec c = match EConstr.kind sigma c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_,_,_,_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c @@ -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/hints.mli b/tactics/hints.mli index 54f4716652..f5947bb946 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -36,7 +36,7 @@ type 'a hint_ast = | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) - | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Unfold_nth of Tacred.evaluable_global_reference (* Hint Unfold *) | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) type hint = private { @@ -173,8 +173,8 @@ type hints_entry = | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path - | HintsUnfoldEntry of evaluable_global_reference list - | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool + | HintsUnfoldEntry of Tacred.evaluable_global_reference list + | HintsTransparencyEntry of Tacred.evaluable_global_reference hints_transparency_target * bool | HintsModeEntry of GlobRef.t * hint_mode list | HintsExternEntry of hint_info * Genarg.glob_generic_argument diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index a8747e0a7c..b415b30de8 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -81,7 +81,7 @@ let subst_strategy (subs,(local,obj)) = local, List.Smart.map (fun (k,ql as entry) -> - let ql' = List.Smart.map (Mod_subst.subst_evaluable_reference subs) ql in + let ql' = List.Smart.map (Tacred.subst_evaluable_reference subs) ql in if ql==ql' then entry else (k,ql')) obj @@ -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)) @@ -262,7 +344,7 @@ let subst_red_expr subs = let sigma = Evd.from_env env in Redops.map_red_expr_gen (subst_mps subs) - (Mod_subst.subst_evaluable_reference subs) + (Tacred.subst_evaluable_reference subs) (Patternops.subst_pattern env sigma subs) let inReduction : bool * string * red_expr -> obj = diff --git a/tactics/redexpr.mli b/tactics/redexpr.mli index d43785218f..fb0043db8d 100644 --- a/tactics/redexpr.mli +++ b/tactics/redexpr.mli @@ -10,7 +10,6 @@ (** Interpretation layer of redexprs such as hnf, cbv, etc. *) -open Names open Constr open EConstr open Pattern @@ -19,10 +18,18 @@ open Reductionops open Locus type red_expr = - (constr, evaluable_global_reference, constr_pattern) red_expr_gen + (constr, Tacred.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 @@ -42,7 +49,7 @@ val declare_red_expr : bool -> string -> red_expr -> unit true, the effect is non-synchronous (i.e. it does not survive section and module closure). *) val set_strategy : - bool -> (Conv_oracle.level * evaluable_global_reference list) list -> unit + bool -> (Conv_oracle.level * Tacred.evaluable_global_reference list) list -> unit (** call by value normalisation function using the virtual machine *) val cbv_vm : reduction_function 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 8b38bc1b0a..b40bdbc25e 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] @@ -3272,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 @@ -3378,7 +3293,7 @@ let expand_projections env sigma c = let rec aux env c = match EConstr.kind sigma c with | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] - | _ -> map_constr_with_full_binders sigma push_rel aux env c + | _ -> map_constr_with_full_binders env sigma push_rel aux env c in aux env c diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 0fd2f1253f..a6471be549 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -179,11 +179,11 @@ val normalise_in_hyp : hyp_location -> unit Proofview.tactic val normalise_option : goal_location -> unit Proofview.tactic val normalise_vm_in_concl : unit Proofview.tactic val unfold_in_concl : - (occurrences * evaluable_global_reference) list -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> unit Proofview.tactic val unfold_in_hyp : - (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic val unfold_option : - (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index df07dcbca7..f12d4e5de5 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -335,8 +335,9 @@ struct meta in Meta meta - | Case (ci,c1,_iv,c2,ca) -> - Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) + | Case (ci,u1,pms1,c1,_iv,c2,ca) -> + let f_ctx (_, p) = pat_of_constr p in + Term(DCase(ci,f_ctx c1,pat_of_constr c2,Array.map f_ctx ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> 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/opened/bug_3166.v b/test-suite/bugs/closed/bug_3166.v index baf87631f0..3b3375fdd8 100644 --- a/test-suite/bugs/opened/bug_3166.v +++ b/test-suite/bugs/closed/bug_3166.v @@ -80,5 +80,5 @@ Goal forall T (x y : T) (p : x = y), True. ) as H0. compute in H0. change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. - Fail pose proof (fun k => @eq_trans _ _ _ k H0). + pose proof (fun k => @eq_trans _ _ _ k H0). Abort. 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_6157.v b/test-suite/bugs/closed/bug_6157.v new file mode 100644 index 0000000000..cd24e4c7ee --- /dev/null +++ b/test-suite/bugs/closed/bug_6157.v @@ -0,0 +1,15 @@ +(* Check that universe instances of refs are preserved *) + +Section U. +Set Universe Polymorphism. +Definition U@{i} := Type@{i}. + +Section foo. +Universe i. +Fail Check U@{i} : U@{i}. +Notation Ui := U@{i}. (* syndef path *) +Fail Check Ui : Type@{i}. +Notation "#" := U@{i}. (* non-syndef path *) +Fail Check # : Type@{i}. +End foo. +End U. 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/coqdoc/verbatim.html.out b/test-suite/coqdoc/verbatim.html.out index bf9f975ee8..070f80e771 100644 --- a/test-suite/coqdoc/verbatim.html.out +++ b/test-suite/coqdoc/verbatim.html.out @@ -90,7 +90,7 @@ verbatim <tr class="infruleassumption"> <td class="infrule">Γ ⊢ A ∨ B</td> <td></td> -</td> +</tr> </table></center> <div class="paragraph"> </div> 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/micromega/reify_bool.v b/test-suite/micromega/reify_bool.v new file mode 100644 index 0000000000..501fafc0b3 --- /dev/null +++ b/test-suite/micromega/reify_bool.v @@ -0,0 +1,18 @@ +Require Import ZArith. +Require Import Lia. +Import Z. +Unset Lia Cache. + +Goal forall (x y : Z), + implb (Z.eqb x y) (Z.eqb y x) = true. +Proof. + intros. + lia. +Qed. + +Goal forall (x y :Z), implb (Z.eqb x 0) (Z.eqb y 0) = true <-> + orb (negb (Z.eqb x 0))(Z.eqb y 0) = true. +Proof. + intro. + lia. +Qed. 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-coqtop/DependentEvars.out b/test-suite/output-coqtop/DependentEvars.out index 2e69b94505..11d1ca0bdb 100644 --- a/test-suite/output-coqtop/DependentEvars.out +++ b/test-suite/output-coqtop/DependentEvars.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -50,7 +50,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) p14 < -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -60,16 +60,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -79,9 +79,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/DependentEvars2.out b/test-suite/output-coqtop/DependentEvars2.out index 63bfafa88d..6bf2c35ad4 100644 --- a/test-suite/output-coqtop/DependentEvars2.out +++ b/test-suite/output-coqtop/DependentEvars2.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -52,7 +52,7 @@ Coq < Coq < 1 subgoal p14 < p14 < Second proof: -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -62,16 +62,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 1 focused subgoal +p14 < 1 focused goal (shelved: 2) P1, P2, P3, P4 : Prop @@ -86,19 +86,19 @@ p14 < 1 focused subgoal p14 < This subproof is complete, but there are some unfocused goals. Try unfocusing with "}". -3 subgoals +3 goals (shelved: 2) -subgoal 1 is: +goal 1 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal:) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -108,9 +108,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/ShowGoal.out b/test-suite/output-coqtop/ShowGoal.out index 42d9ff31e9..467112f153 100644 --- a/test-suite/output-coqtop/ShowGoal.out +++ b/test-suite/output-coqtop/ShowGoal.out @@ -1,52 +1,52 @@ -Coq < 1 subgoal
+Coq < 1 goal
============================
forall i : nat, exists j k : nat, i = j /\ j = k /\ i = k
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
exists k : nat, i = ?j /\ ?j = k /\ i = k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
i = ?j /\ ?j = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
i = ?j
-subgoal 2 is:
+goal 2 is:
?j = ?k /\ i = ?k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
i = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 1)
i : nat
============================
i = ?k
-subgoal 2 is:
+goal 2 is:
i = ?k
-x < 1 subgoal
+x < 1 goal
i : nat
============================
diff --git a/test-suite/output-coqtop/ShowProofDiffs.out b/test-suite/output-coqtop/ShowProofDiffs.out index 285a3bcd89..a37e3e5af4 100644 --- a/test-suite/output-coqtop/ShowProofDiffs.out +++ b/test-suite/output-coqtop/ShowProofDiffs.out @@ -1,11 +1,11 @@ -Coq < Coq < 1 subgoal
+Coq < Coq < 1 goal
============================
[48;2;0;91;0m[48;2;0;141;0;4m[1mforall[22m i : nat, [37mexists[39m j k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k[48;2;0;91;0;24m[0m
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
[48;2;0;91;0m[48;2;0;141;0;4mi : nat[48;2;0;91;0;24m[0m
============================
@@ -14,7 +14,7 @@ x < 1 focused subgoal [48;2;0;91;0m[48;2;0;141;0;4m([1mfun[22m i : nat =>[49;24m
[48;2;0;141;0;4mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mj[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m[0m
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
@@ -24,13 +24,13 @@ x < 1 focused subgoal [48;2;0;91;0mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [49m
[48;2;0;91;0m[48;2;0;141;0;4m[94m?[39m[94mj[39m (ex_intro ([1mfun[22m k : nat => i[37m =[39m ?j[37m /\[39m[48;2;0;91;0;24m ?j[37m [39m[48;2;0;141;0;4m[37m=[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mk[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m)[0m
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
[48;2;0;91;0mi[37m =[39m ?j[0m
-subgoal 2 is:
+goal 2 is:
[48;2;0;91;0m?j[37m =[39m ?k[37m /\[39m i[37m =[39m ?k[0m
[48;2;0;91;0m([1mfun[22m i : nat =>[49m
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 01564e7f25..ea647a990a 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -50,10 +50,11 @@ f = fun H : B => match H with | AC x => - let b0 := b in - (if b0 as b return (P b -> True) - then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) x + (fun x0 : P b => + let b0 := b in + (if b0 as b return (P b -> True) + then fun _ : P true => Logic.I + else fun _ : P false => Logic.I) x0) x end : B -> True The command has indeed failed with message: @@ -74,7 +75,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 @@ -86,7 +89,7 @@ Arguments lem2 _%bool_scope lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k -1 subgoal +1 goal x : nat n, n0 := match x + 0 with @@ -106,7 +109,7 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl end : x = x ============================ x + 0 = 0 -1 subgoal +1 goal p : nat a, @@ -181,3 +184,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/CompactContexts.out b/test-suite/output/CompactContexts.out index 9d1d19877e..f0a8019b67 100644 --- a/test-suite/output/CompactContexts.out +++ b/test-suite/output/CompactContexts.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal hP1 : True a : nat b : list nat h : forall x : nat, {y : nat | y > x} 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/Intuition.out b/test-suite/output/Intuition.out index f2bf25ca65..e273307d75 100644 --- a/test-suite/output/Intuition.out +++ b/test-suite/output/Intuition.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal m, n : Z H : (m >= n)%Z diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index 0a989646cf..2daa5a6bb5 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -1,23 +1,23 @@ -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) -> x + x1 = x4 + x0 -> foo (S x) -1 subgoal +1 goal x3 : nat ============================ @@ -27,7 +27,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat ============================ @@ -36,7 +36,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -45,7 +45,7 @@ H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -55,7 +55,7 @@ x5, x6, x7, S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, a : nat H : a = 0 -> forall a : nat, a = 0 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.out b/test-suite/output/Notations3.out index a9bed49922..60213cab0c 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -238,7 +238,7 @@ Notation "'exists' ! x .. y , p" := (default interpretation) Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) -1 subgoal +1 goal ============================ ##@% 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/Partac.out b/test-suite/output/Partac.out index 889e698fa2..ce5dbdedb4 100644 --- a/test-suite/output/Partac.out +++ b/test-suite/output/Partac.out @@ -1,6 +1,6 @@ The command has indeed failed with message: The term "false" has type "bool" while it is expected to have type "nat". -(for subgoal 1) +(for goal 1) The command has indeed failed with message: The term "0" has type "nat" while it is expected to have type "bool". -(for subgoal 2) +(for goal 2) 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/Show.out b/test-suite/output/Show.out index f02e442be5..3db00be048 100644 --- a/test-suite/output/Show.out +++ b/test-suite/output/Show.out @@ -1,10 +1,10 @@ -3 subgoals (ID 29) +3 goals (ID 29) H : 0 = 0 ============================ 1 = 1 -subgoal 2 (ID 33) is: +goal 2 (ID 33) is: 1 = S (S m') -subgoal 3 (ID 20) is: +goal 3 (ID 20) is: S (S n') = S m 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/Unicode.out b/test-suite/output/Unicode.out index a57b3bbad5..abe6c39e8f 100644 --- a/test-suite/output/Unicode.out +++ b/test-suite/output/Unicode.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -8,7 +8,7 @@ → True → ∀ (x : very_very_long_type_name1) (y : very_very_long_type_name2), f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -18,7 +18,7 @@ → True → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -29,7 +29,7 @@ → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z ∧ f y x ∧ f y z ∧ f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type 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/bug_9370.out b/test-suite/output/bug_9370.out index 0ff151c8b4..8d34b7143a 100644 --- a/test-suite/output/bug_9370.out +++ b/test-suite/output/bug_9370.out @@ -1,12 +1,12 @@ -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 diff --git a/test-suite/output/bug_9403.out b/test-suite/output/bug_9403.out index 850760d5ed..cd1030bd2e 100644 --- a/test-suite/output/bug_9403.out +++ b/test-suite/output/bug_9403.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal X : tele α, β, γ1, γ2 : X → Prop diff --git a/test-suite/output/bug_9569.out b/test-suite/output/bug_9569.out index 2d474e4933..e49449679f 100644 --- a/test-suite/output/bug_9569.out +++ b/test-suite/output/bug_9569.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal ============================ exists I : True, I = Logic.I -1 subgoal +1 goal ============================ f True False True False (Logic.True /\ Logic.False) -1 subgoal +1 goal ============================ [I | I = Logic.I; I = Logic.I] = [I | I = Logic.I; I = Logic.I] -1 subgoal +1 goal ============================ [I & I = Logic.I | I = Logic.I; Logic.I = I] diff --git a/test-suite/output/clear.out b/test-suite/output/clear.out index 42e3abf26f..ea01ac50d7 100644 --- a/test-suite/output/clear.out +++ b/test-suite/output/clear.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal z := 0 : nat ============================ diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 17c1aaa55b..453f6ee615 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -2,79 +2,79 @@ Nat.t = nat : Set Nat.t = nat : Set -2 subgoals +2 goals ============================ True -subgoal 2 is: +goal 2 is: True -2 subgoals, subgoal 1 (?Goal) +2 goals, goal 1 (?Goal) ============================ True -subgoal 2 (?Goal0) is: +goal 2 (?Goal0) is: True -1 subgoal +1 goal ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True *** Unfocused goals: -subgoal 2 (?Goal1) is: +goal 2 (?Goal1) is: True -subgoal 3 (?Goal) is: +goal 3 (?Goal) is: True -1 subgoal +1 goal ============================ True *** Unfocused goals: -subgoal 2 is: +goal 2 is: True -subgoal 3 is: +goal 3 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 is: +goal 1 is: True -subgoal 2 is: +goal 2 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 (?Goal0) is: +goal 1 (?Goal0) is: True -subgoal 2 (?Goal) is: +goal 2 (?Goal) is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 is: +goal 1 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 (?Goal) is: +goal 1 (?Goal) is: True diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index efdc94fb1e..ed42429f85 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -38,7 +38,7 @@ Ltac foo := let w := () in let z := 1 in pose v -2 subgoals +2 goals n : nat ============================ @@ -47,5 +47,5 @@ Ltac foo := | S n1 => a n1 end) n = n -subgoal 2 is: +goal 2 is: forall a : nat, a = 0 diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 48be63a46a..051bce7701 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -3,7 +3,7 @@ In environment y : nat The term "a y" has type "{y0 : nat | y = y0}" while it is expected to have type "{x : nat | x = y}". -1 focused subgoal +1 focused goal (shelved: 1) H : ?n <= 3 -> 3 <= ?n -> ?n = 3 diff --git a/test-suite/output/optimize_heap.out b/test-suite/output/optimize_heap.out index 94a0b19118..b6ee61a971 100644 --- a/test-suite/output/optimize_heap.out +++ b/test-suite/output/optimize_heap.out @@ -1,8 +1,8 @@ -1 subgoal +1 goal ============================ True -1 subgoal +1 goal ============================ True diff --git a/test-suite/output/set.out b/test-suite/output/set.out index 4b72d73eb3..61f3c52656 100644 --- a/test-suite/output/set.out +++ b/test-suite/output/set.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal y1 := 0 : nat x := 0 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2 := 0 : nat x := y2 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2, y3 := 0 : nat x := y2 + y3 : nat diff --git a/test-suite/output/simpl.out b/test-suite/output/simpl.out index 526e468f5b..fd35c5e339 100644 --- a/test-suite/output/simpl.out +++ b/test-suite/output/simpl.out @@ -1,14 +1,14 @@ -1 subgoal +1 goal x : nat ============================ x = S x -1 subgoal +1 goal x : nat ============================ 0 + x = S x -1 subgoal +1 goal x : nat ============================ 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/output/subst.out b/test-suite/output/subst.out index 209b2bc26f..9cc515b7ba 100644 --- a/test-suite/output/subst.out +++ b/test-suite/output/subst.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -11,7 +11,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -24,7 +24,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -37,7 +37,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal H1 : 0 = 1 HA : True @@ -47,7 +47,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -60,7 +60,7 @@ H2 : 0 = 2 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -73,7 +73,7 @@ H3 : 0 = 3 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -86,7 +86,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal HA, HB : True H4 : 0 = 4 diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out index 2fadd747b7..abcb8d7e0c 100644 --- a/test-suite/output/unifconstraints.out +++ b/test-suite/output/unifconstraints.out @@ -1,44 +1,44 @@ -3 focused subgoals +3 focused goals (shelved: 1) ============================ ?Goal 0 -subgoal 2 is: +goal 2 is: forall n : nat, ?Goal n -> ?Goal (S n) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal ?Goal2 <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) n, m : nat ============================ ?Goal@{n:=n; m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal@{n:=n; m:=m} n0 -> ?Goal@{n:=n; m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal1@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal1@{m:=m} n0 -> ?Goal1@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: @@ -46,16 +46,16 @@ unification constraint: True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal0@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal0@{m:=m} n0 -> ?Goal0@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: diff --git a/test-suite/output/unification.out b/test-suite/output/unification.out index cf31871e5a..4db5c2d161 100644 --- a/test-suite/output/unification.out +++ b/test-suite/output/unification.out @@ -9,25 +9,25 @@ Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate The command has indeed failed with message: The term "id" has type "ID" while it is expected to have type "Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope). -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S x = x 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/case_let_conversion.v b/test-suite/success/case_let_conversion.v new file mode 100644 index 0000000000..3f1ab96fe1 --- /dev/null +++ b/test-suite/success/case_let_conversion.v @@ -0,0 +1,39 @@ +Axiom checker_flags : Set. + +Inductive Box (R : Type) : Type := box : Box R. + +Inductive typing (H : checker_flags) : Type := +| type_Rel : typing H -> typing H +| type_Case : let i := tt in Box (typing H) -> typing H. + +Definition unbox (P : Type) (b : Box P) := match b with box _ => 0 end. + +Definition size (H : checker_flags) (d : typing H) : nat. +Proof. +revert d. +fix size 1. +destruct 1. +- exact (size d). +- exact (unbox _ b). +Defined. + +Definition foo (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +simpl. +reflexivity. +Qed. + +Definition bar (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +vm_compute. +reflexivity. +Qed. + +Definition qux (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +native_compute. +reflexivity. +Qed. diff --git a/test-suite/success/case_let_param.v b/test-suite/success/case_let_param.v new file mode 100644 index 0000000000..46d8c26e83 --- /dev/null +++ b/test-suite/success/case_let_param.v @@ -0,0 +1,15 @@ +Inductive foo (x := tt) := Foo : forall (y := x), foo. + +Definition get (t : foo) := match t with Foo _ y => y end. + +Goal get Foo = tt. +Proof. +reflexivity. +Qed. + +Goal forall x : foo, + match x with Foo _ y => y end = match x with Foo _ _ => tt end. +Proof. +intros. +reflexivity. +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.v b/test-suite/success/change.v index 2f676cf9ad..053429a5a9 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -14,8 +14,8 @@ Abort. (* Check the combination of at, with and in (see bug #2146) *) Goal 3=3 -> 3=3. intro H. -change 3 at 2 with (1+2). -change 3 at 2 with (1+2) in H |-. +change 3 with (1+2) at 2. +change 3 with (1+2) in H at 2 |-. change 3 with (1+2) in H at 1 |- * at 1. (* Now check that there are no more 3's *) change 3 with (1+2) in * || reflexivity. 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/let_pattern_mismatch.v b/test-suite/success/let_pattern_mismatch.v new file mode 100644 index 0000000000..a56a8fff4f --- /dev/null +++ b/test-suite/success/let_pattern_mismatch.v @@ -0,0 +1,18 @@ +(* Weird corner case accepted by the pattern-matching algorithm. Destructuring + let-bindings in patterns can actually be shorter than the case they match. *) + +Inductive ascii : Set := +| Ascii : bool -> bool -> bool -> bool -> bool -> bool -> bool -> bool -> ascii. + +Definition dummy (a : ascii) : unit := + let (a0,a1,a2,a3,a4,a5,a6,a7) := a in tt. + +Goal forall (a : ascii) (H : tt = dummy a), True. +Proof. +intros a H. +unfold dummy in *. +(* Two bound variables in the pattern, eight in the term. *) +match goal with +| H:context [ let (x, y) := ?X in _ ] |- _ => destruct X eqn:? +end. +Abort. diff --git a/test-suite/success/match_case_pattern_variables.v b/test-suite/success/match_case_pattern_variables.v new file mode 100644 index 0000000000..bb9117d033 --- /dev/null +++ b/test-suite/success/match_case_pattern_variables.v @@ -0,0 +1,34 @@ +(** Check that bound variables in case patterns are handled correctly. *) + +Goal forall (ch : unit) (t : list unit) (s : list unit), + match s with + | nil => False + | cons a l => ch = a /\ l = t + end. +Proof. +intros. +match goal with +| |- match ?e with + | nil => ?N + | cons a b => ?P + end => + let f := + constr:((fun (e' : list unit) => match e' with + | nil => N + | cons a b => P + end)) + in + change (f e) +end. +Abort. + +Goal forall (ch : unit) (n : nat) (s : prod unit nat), + let (a, l) := s in ch = a /\ l = n. +Proof. +intros. +match goal with +| [ |- let (a, b) := ?e in ?P ] => + let f := constr:((fun (e' : prod unit nat) => match e' with pair a b => P end)) in + change (f e) +end. +Abort. 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/Bool/BoolEq.v b/theories/Bool/BoolEq.v index f002ee427c..dd10c758a5 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -46,7 +46,7 @@ Section Bool_eq_dec. Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}. Proof. - intros. + intros x y. exists (beq x y). constructor. Defined. diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index ef78121d63..5eb2a99739 100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -18,7 +18,7 @@ Theorem ifdec_left : forall (A B:Prop) (C:Set) (H:{A} + {B}), ~ B -> forall x y:C, ifdec H x y = x. Proof. - intros; case H; auto. + intros A B C H **; case H; auto. intro; absurd B; trivial. Qed. @@ -26,7 +26,7 @@ Theorem ifdec_right : forall (A B:Prop) (C:Set) (H:{A} + {B}), ~ A -> forall x y:C, ifdec H x y = y. Proof. - intros; case H; auto. + intros A B C H **; case H; auto. intro; absurd A; trivial. Qed. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 7e9087c377..8366e8257e 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -29,13 +29,13 @@ case diff_true_false; trivial with bool. Qed. Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A. -intros. +intros A B H. inversion H. assumption. Qed. Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B. -intros. +intros A B H. inversion H. assumption. Qed. @@ -45,7 +45,7 @@ destruct 1; auto with bool. Qed. Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. -destruct b; intro H. +intros A B b; destruct b; intro H. - left; inversion H; auto with bool. - right; inversion H; auto with bool. Qed. diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index aff5008410..418fc88489 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -19,26 +19,26 @@ Definition zerob (n:nat) : bool := | S _ => false end. -Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true. +Lemma zerob_true_intro (n : nat) : n = 0 -> zerob n = true. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. #[global] Hint Resolve zerob_true_intro: bool. -Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0. +Lemma zerob_true_elim (n : nat) : zerob n = true -> n = 0. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. -Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false. +Lemma zerob_false_intro (n : nat) : n <> 0 -> zerob n = false. Proof. destruct n; [ destruct 1; auto with bool | trivial with bool ]. Qed. #[global] Hint Resolve zerob_false_intro: bool. -Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0. +Lemma zerob_false_elim (n : nat) : zerob n = false -> n <> 0. Proof. destruct n; [ inversion 1 | auto with bool ]. Qed. diff --git a/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v index f23cf158ac..82a76e8afd 100644 --- a/theories/Classes/CEquivalence.v +++ b/theories/Classes/CEquivalence.v @@ -64,8 +64,8 @@ Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. now transitivity y. Qed. -Arguments equiv_symmetric {A R} sa x y. -Arguments equiv_transitive {A R} sa x y z. +Arguments equiv_symmetric {A R} sa x y : rename. +Arguments equiv_transitive {A R} sa x y z : rename. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 9ff18ebe2c..d6a0ae5411 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -567,9 +567,7 @@ Section Normalize. Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. Proof. - red in H, H0. red in H. - apply (snd (H _ _)). - assumption. + apply (_ : Normalizes R0 R1). assumption. Qed. Lemma flip_atom R : Normalizes R (flip (flip R)). diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 236d35b68e..561822ef0c 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 @@ -354,14 +352,12 @@ Section Binary. Global Instance partial_order_antisym `(PartialOrder eqA R) : Antisymmetric eqA R. Proof with auto. reduce_goal. - apply H. firstorder. + firstorder. Qed. Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). Proof. - unfold flip; constructor; unfold flip. - - intros X. apply H. apply symmetry. apply X. - - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. + firstorder. Qed. End Binary. diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 7169aa673d..cd6765bab9 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -46,7 +46,7 @@ Qed. (** The generic function that should be used to program, together with some useful tactics. *) -Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H). +Definition decide P {H : Decidable P} := @Decidable_witness _ H. Ltac _decide_ P H := let b := fresh "b" in diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index d96bd72561..4d9069b4d0 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -64,8 +64,8 @@ Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv | 1. now transitivity y. Qed. -Arguments equiv_symmetric {A R} sa x y. -Arguments equiv_transitive {A R} sa x y z. +Arguments equiv_symmetric {A R} sa x y : rename. +Arguments equiv_transitive {A R} sa x y z : rename. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) 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/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index e9d434b488..ae1d978bfb 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -16,7 +16,7 @@ Lemma equal_f : forall {A B : Type} {f g : A -> B}, f = g -> forall x, f x = g x. Proof. - intros. + intros A B f g H x. rewrite H. auto. Qed. @@ -118,7 +118,7 @@ Definition f_equal__functional_extensionality_dep_good {A B f g} H a : f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H) = H a. Proof. - apply forall_eq_rect with (H := H); clear H g. + apply (fun P k => forall_eq_rect _ P k _ H); clear H g. change (eq_refl (f a)) with (f_equal (fun h => h a) (eq_refl f)). apply f_equal, functional_extensionality_dep_good_refl. Defined. 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/Logic/JMeq.v b/theories/Logic/JMeq.v index 7ee3a99d60..21eed3a696 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -39,8 +39,8 @@ Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. Register JMeq_hom as core.JMeq.hom. Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. -Proof. -intros; destruct H; trivial. +Proof. +intros A B x y H; destruct H; trivial. Qed. #[global] @@ -150,7 +150,7 @@ Lemma JMeq_eq_dep : forall U (P:U->Type) p q (x:P p) (y:P q), p = q -> JMeq x y -> eq_dep U P p x q y. Proof. -intros. +intros U P p q x y H H0. destruct H. apply JMeq_eq in H0 as ->. reflexivity. 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..f324bbf52b 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 *) @@ -261,7 +226,7 @@ Proof. apply Z.lt_le_trans with (1:= H5); auto with zarith. apply Zpower_le_monotone; auto with zarith. rewrite Zplus_mod; auto with zarith. - rewrite -> Zmod_small with (a := t); auto with zarith. + rewrite -> (Zmod_small t); auto with zarith. apply Zmod_small; auto with zarith. split; auto with zarith. assert (0 <= 2 ^a * r); auto with zarith. @@ -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 *) @@ -524,15 +489,15 @@ Definition cast i j := Lemma cast_refl : forall i, cast i i = Some (fun P H => H). Proof. - unfold cast;intros. + unfold cast;intros i. generalize (eqb_correct i i). - rewrite eqb_refl;intros. + rewrite eqb_refl;intros e. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. Lemma cast_diff : forall i j, i =? j = false -> cast i j = None. Proof. - intros;unfold cast;intros; generalize (eqb_correct i j). + intros i j H;unfold cast;intros; generalize (eqb_correct i j). rewrite H;trivial. Qed. @@ -544,15 +509,15 @@ Definition eqo i j := Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). Proof. - unfold eqo;intros. + unfold eqo;intros i. generalize (eqb_correct i i). - rewrite eqb_refl;intros. + rewrite eqb_refl;intros e. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. Lemma eqo_diff : forall i j, i =? j = false -> eqo i j = None. Proof. - unfold eqo;intros; generalize (eqb_correct i j). + unfold eqo;intros i j H; generalize (eqb_correct i j). rewrite H;trivial. Qed. @@ -686,7 +651,7 @@ Proof. apply Zgcdn_is_gcd. unfold Zgcd_bound. generalize (to_Z_bounded b). - destruct φ b. + destruct φ b as [|p|p]. unfold size; auto with zarith. intros (_,H). cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. @@ -762,7 +727,7 @@ Proof. replace ((φ m + φ n) mod wB)%Z with ((((φ m + φ n) - wB) + wB) mod wB)%Z. rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. rewrite !Zmod_small; auto with zarith. - apply f_equal2 with (f := Zmod); auto with zarith. + apply (f_equal2 Zmod); auto with zarith. case_eq (n <=? m + n)%int63; auto. rewrite leb_spec, H1; auto with zarith. assert (H1: (φ (m + n) = φ m + φ n)%Z). @@ -840,7 +805,7 @@ Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. Proof. apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. rewrite -> !lsl_spec, <-Zplus_mod. - apply f_equal2 with (f := Zmod); auto with zarith. + apply (f_equal2 Zmod); auto with zarith. Qed. Lemma lsr_M_r x i (H: (digits <=? i = true)%int63) : x >> i = 0%int63. @@ -1008,14 +973,14 @@ Proof. case H2; intros _ H3; case (Zle_or_lt φ i φ j); intros F2. 2: generalize (H3 F2); discriminate. clear H2 H3. - apply f_equal with (f := negb). - apply f_equal with (f := is_zero). + apply (f_equal negb). + apply (f_equal is_zero). apply to_Z_inj. rewrite -> !lsl_spec, !lsr_spec, !lsl_spec. pattern wB at 2 3; replace wB with (2^(1+ φ (digits - 1))); auto. rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. rewrite !Zmult_mod_distr_r. - apply f_equal2 with (f := Zmult); auto. + apply (f_equal2 Zmult); auto. replace wB with (2^ d); auto with zarith. replace d with ((d - φ i) + φ i)%Z by ring. case (to_Z_bounded i); intros H1i H2i. @@ -1113,8 +1078,8 @@ Proof. 2: generalize (Hn 0%int63); do 2 case bit; auto; intros [ ]; auto. rewrite lsl_add_distr. rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. - rewrite <-!add_assoc; apply f_equal2 with (f := add); auto. - rewrite add_comm, <-!add_assoc; apply f_equal2 with (f := add); auto. + rewrite <-!add_assoc; apply (f_equal2 add); auto. + rewrite add_comm, <-!add_assoc; apply (f_equal2 add); auto. rewrite add_comm; auto. intros Heq. generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. @@ -1395,7 +1360,7 @@ Lemma sqrt2_step_def rec ih il j: else j else j. Proof. - unfold sqrt2_step; case diveucl_21; intros;simpl. + unfold sqrt2_step; case diveucl_21; intros i j';simpl. case (j +c i);trivial. Qed. @@ -1425,7 +1390,7 @@ Proof. assert (W1:= to_Z_bounded a1). assert (W2:= to_Z_bounded a2). assert (Wb:= to_Z_bounded b). - assert (φ b>0) by (auto with zarith). + assert (φ b>0) as H by (auto with zarith). generalize (Z_div_mod (φ a1*wB+φ a2) φ b H). revert W. destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl (φ a1*wB+φ a2) φ b). @@ -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/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v index 5611329b12..f86246d3c2 100644 --- a/theories/Numbers/DecimalPos.v +++ b/theories/Numbers/DecimalPos.v @@ -216,7 +216,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 10 at 2 with (Nat.iter 10%nat N.succ 0). + change 10 with (Nat.iter 10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. diff --git a/theories/Numbers/HexadecimalPos.v b/theories/Numbers/HexadecimalPos.v index 47f6d983b7..29029cb839 100644 --- a/theories/Numbers/HexadecimalPos.v +++ b/theories/Numbers/HexadecimalPos.v @@ -235,7 +235,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 0x10 at 2 with (Nat.iter 0x10%nat N.succ 0). + change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. 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/Program/Wf.v b/theories/Program/Wf.v index d1be8812e9..69873d0321 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -43,7 +43,7 @@ Section Well_founded. forall (x:A) (r:Acc R x), F_sub x (fun y:{y:A | R y x} => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r. Proof. - destruct r using Acc_inv_dep; auto. + intros x r; destruct r using Acc_inv_dep; auto. Qed. Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s. @@ -95,12 +95,12 @@ Section Measure_well_founded. Proof with auto. unfold well_founded. cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0). - + intros. + + intros H a. apply (H (m a))... + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). - intros. + intros ? H ? H0. apply Acc_intro. - intros. + intros y H1. unfold MR in H1. rewrite H0 in H1. apply (H (m y))... @@ -174,7 +174,7 @@ Section Fix_rects. revert a'. pattern x, (Fix_F_sub A R P f x a). apply Fix_F_sub_rect. - intros. + intros ? H **. rewrite F_unfold. apply equiv_lowers. intros. @@ -197,11 +197,11 @@ Section Fix_rects. : forall x, Q _ (Fix_sub A R Rwf P f x). Proof with auto. unfold Fix_sub. - intros. + intros x. apply Fix_F_sub_rect. - intros. - assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))... - set (inv x0 X0 a). clearbody q. + intros x0 H a. + assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y))) as X0... + set (q := inv x0 X0 a). clearbody q. rewrite <- (equiv_lowers (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y))) (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... @@ -242,9 +242,9 @@ Module WfExtensionality. Fix_sub A R Rwf P F_sub x = F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)). Proof. - intros ; apply Fix_eq ; auto. - intros. - assert(f = g). + intros A R Rwf P F_sub x; apply Fix_eq ; auto. + intros ? f g H. + assert(f = g) as H0. - extensionality y ; apply H. - rewrite H0 ; auto. Qed. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index b008c6c2aa..4e596a165c 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -637,13 +637,13 @@ Qed. Lemma Qmult_1_l : forall n, 1*n == n. Proof. - intro; red; simpl; destruct (Qnum n); auto. + intro n; red; simpl; destruct (Qnum n); auto. Qed. Theorem Qmult_1_r : forall n, n*1==n. Proof. - intro; red; simpl. - rewrite Z.mul_1_r with (n := Qnum n). + intro n; red; simpl. + rewrite (Z.mul_1_r (Qnum n)). rewrite Pos.mul_comm; simpl; trivial. Qed. @@ -709,7 +709,7 @@ Qed. Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1. Proof. intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl; - intros; simpl_mult; try ring. + intros H **; simpl_mult; try ring. elim H; auto. Qed. @@ -722,7 +722,7 @@ Qed. Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x. Proof. - intros; unfold Qdiv. + intros x y H; unfold Qdiv. rewrite <- (Qmult_assoc x y (Qinv y)). rewrite (Qmult_inv_r y H). apply Qmult_1_r. @@ -730,7 +730,7 @@ Qed. Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x. Proof. - intros; unfold Qdiv. + intros x y ?; unfold Qdiv. rewrite (Qmult_assoc y x (Qinv y)). rewrite (Qmult_comm y x). fold (Qdiv (Qmult x y) y). @@ -845,7 +845,7 @@ Qed. Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z. Proof. - intros. + intros x y z ? ?. apply Qle_lt_trans with y; auto. apply Qlt_le_weak; auto. Qed. @@ -877,19 +877,19 @@ Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}. Proof. - unfold Qlt, Qle, Qeq; intros. + unfold Qlt, Qle, Qeq; intros x y. exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)). Defined. Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}. Proof. - unfold Qlt, Qle; intros. + unfold Qlt, Qle; intros x y. exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)). Defined. Lemma Qarchimedean : forall q : Q, { p : positive | q < Z.pos p # 1 }. Proof. - intros. destruct q as [a b]. destruct a. + intros q. destruct q as [a b]. destruct a as [|p|p]. - exists xH. reflexivity. - exists (p+1)%positive. apply (Z.lt_le_trans _ (Z.pos (p+1))). simpl. rewrite Pos.mul_1_r. @@ -1169,12 +1169,12 @@ Qed. Lemma Qinv_lt_contravar : forall a b : Q, 0 < a -> 0 < b -> (a < b <-> /b < /a). Proof. - intros. split. - - intro. rewrite <- Qmult_1_l. apply Qlt_shift_div_r. apply H0. + intros a b H H0. split. + - intro H1. rewrite <- Qmult_1_l. apply Qlt_shift_div_r. apply H0. rewrite <- (Qmult_inv_r a). rewrite Qmult_comm. apply Qmult_lt_l. apply Qinv_lt_0_compat. apply H. apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). - - intro. rewrite <- (Qinv_involutive b). rewrite <- (Qmult_1_l (// b)). + - intro H1. rewrite <- (Qinv_involutive b). rewrite <- (Qmult_1_l (// b)). apply Qlt_shift_div_l. apply Qinv_lt_0_compat. apply H0. rewrite <- (Qmult_inv_r a). apply Qmult_lt_l. apply H. apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). @@ -1190,7 +1190,7 @@ Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. Proof. intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. unfold Qpower_positive. -induction y; simpl; +induction y as [y IHy|y IHy|]; simpl; try rewrite IHy; try rewrite Hx; reflexivity. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 533c675415..e94ae1e789 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -129,19 +129,19 @@ Qed. Add Morphism Qplus' with signature (Qeq ==> Qeq ==> Qeq) as Qplus'_comp. Proof. - intros; unfold Qplus'. + intros ? ? H ? ? H0; unfold Qplus'. rewrite H, H0; auto with qarith. Qed. Add Morphism Qmult' with signature (Qeq ==> Qeq ==> Qeq) as Qmult'_comp. Proof. - intros; unfold Qmult'. + intros ? ? H ? ? H0; unfold Qmult'. rewrite H, H0; auto with qarith. Qed. Add Morphism Qminus' with signature (Qeq ==> Qeq ==> Qeq) as Qminus'_comp. Proof. - intros; unfold Qminus'. + intros ? ? H ? ? H0; unfold Qminus'. rewrite H, H0; auto with qarith. Qed. 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/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 9a1bbca99f..c11077607e 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -58,9 +58,9 @@ Open Scope Z_scope. Lemma Zgcdn_pos : forall n a b, 0 <= Zgcdn n a b. Proof. - induction n. + intros n; induction n. simpl; auto with zarith. - destruct a; simpl; intros; auto with zarith; auto. + intros a; destruct a; simpl; intros; auto with zarith; auto. Qed. Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b. @@ -75,9 +75,9 @@ Open Scope Z_scope. Lemma Zgcdn_linear_bound : forall n a b, Z.abs a < Z.of_nat n -> Zis_gcd a b (Zgcdn n a b). Proof. - induction n. + intros n; induction n as [|n IHn]. intros; lia. - destruct a; intros; simpl; + intros a; destruct a as [|p|p]; intros b H; simpl; [ generalize (Zis_gcd_0_abs b); intuition | | ]; unfold Z.modulo; generalize (Z_div_mod b (Zpos p) (eq_refl Gt)); @@ -106,7 +106,7 @@ Open Scope Z_scope. Lemma fibonacci_pos : forall n, 0 <= fibonacci n. Proof. enough (forall N n, (n<N)%nat -> 0<=fibonacci n) by eauto. - induction N. intros; lia. + intros N; induction N as [|N IHN]. intros; lia. intros [ | [ | n ] ]. 1-2: simpl; lia. intros. change (0 <= fibonacci (S n) + fibonacci n). @@ -116,11 +116,11 @@ Open Scope Z_scope. Lemma fibonacci_incr : forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. Proof. - induction 1. + induction 1 as [|m H IH]. auto with zarith. apply Z.le_trans with (fibonacci m); auto. clear. - destruct m. + destruct m as [|m]. simpl; auto with zarith. change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). generalize (fibonacci_pos m); lia. @@ -137,10 +137,10 @@ Open Scope Z_scope. fibonacci (S n) <= a /\ fibonacci (S (S n)) <= b. Proof. - induction n. + intros n; induction n as [|n IHn]. intros [|a|a]; intros; simpl; lia. intros [|a|a] b (Ha,Ha'); [simpl; lia | | easy ]. - remember (S n) as m. + remember (S n) as m eqn:Heqm. rewrite Heqm at 2. simpl Zgcdn. unfold Z.modulo; generalize (Z_div_mod b (Zpos a) eq_refl). destruct (Z.div_eucl b (Zpos a)) as (q,r). @@ -171,19 +171,19 @@ Open Scope Z_scope. 0 < a < b -> a < fibonacci (S n) -> Zis_gcd a b (Zgcdn n a b). Proof. - destruct a. 1,3 : intros; lia. + intros n a; destruct a as [|p|p]. 1,3 : intros; lia. cut (forall k n b, k = (S (Pos.to_nat p) - n)%nat -> 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)). destruct 2; eauto. - clear n; induction k. + clear n; intros k; induction k as [|k IHk]. intros. apply Zgcdn_linear_bound. lia. - intros. - generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros. - assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)). + intros n b H H0 H1. + generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros H2. + assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)) as H3. apply IHk; auto. lia. replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto. @@ -197,13 +197,13 @@ Open Scope Z_scope. Lemma Zgcd_bound_fibonacci : forall a, 0 < a -> a < fibonacci (Zgcd_bound a). Proof. - destruct a; [lia| | intro H; discriminate]. + intros a; destruct a as [|p|p]; [lia| | intro H; discriminate]. intros _. - induction p; [ | | compute; auto ]; + induction p as [p IHp|p IHp|]; [ | | compute; auto ]; simpl Zgcd_bound in *; rewrite plus_comm; simpl plus; set (n:= (Pos.size_nat p+Pos.size_nat p)%nat) in *; simpl; - assert (n <> O) by (unfold n; destruct p; simpl; auto). + assert (n <> O) as H by (unfold n; destruct p; simpl; auto). destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Pos2Z.inj_xI; lia. @@ -229,11 +229,11 @@ Open Scope Z_scope. Lemma Zgcdn_is_gcd_pos n a b : (Zgcd_bound (Zpos a) <= n)%nat -> Zis_gcd (Zpos a) b (Zgcdn n (Zpos a) b). Proof. - intros. + intros H. generalize (Zgcd_bound_fibonacci (Zpos a)). simpl Zgcd_bound in *. - remember (Pos.size_nat a+Pos.size_nat a)%nat as m. - assert (1 < m)%nat. + remember (Pos.size_nat a+Pos.size_nat a)%nat as m eqn:Heqm. + assert (1 < m)%nat as H0. { rewrite Heqm; destruct a; simpl; rewrite 1?plus_comm; auto with arith. } destruct m as [ |m]; [inversion H0; auto| ]. diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index b69af424b1..bc3f5706c9 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -83,10 +83,10 @@ Proof. intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed. Lemma Zpower2_Psize n p : Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat. Proof. - revert p; induction n. - destruct p; now split. + revert p; induction n as [|n IHn]. + intros p; destruct p; now split. assert (Hn := Nat2Z.is_nonneg n). - destruct p; simpl Pos.size_nat. + intros p; destruct p as [p|p|]; simpl Pos.size_nat. - specialize IHn with p. rewrite Nat2Z.inj_succ, Z.pow_succ_r; lia. - specialize IHn with p. @@ -138,7 +138,7 @@ Definition Zpow_mod a m n := Theorem Zpow_mod_pos_correct a m n : n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n. Proof. - intros Hn. induction m. + intros Hn. induction m as [m IHm|m IHm|]. - rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag. rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r. rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial. @@ -193,7 +193,7 @@ Proof. assert (p<=1) by (apply Z.divide_pos_le; auto with zarith). lia. - intros n Hn Rec. - rewrite Z.pow_succ_r by trivial. intros. + rewrite Z.pow_succ_r by trivial. intros H. assert (2<=p) by (apply prime_ge_2; auto). assert (2<=q) by (apply prime_ge_2; auto). destruct prime_mult with (2 := H); auto. @@ -229,7 +229,7 @@ Proof. (* x = 1 *) exists 0; rewrite Z.pow_0_r; auto. (* x = 0 *) - exists n; destruct H; rewrite Z.mul_0_r in H; auto. + exists n; destruct H as [? H]; rewrite Z.mul_0_r in H; auto. Qed. (** * Z.square: a direct definition of [z^2] *) diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 6f464d89bb..6b01d798e4 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -42,7 +42,7 @@ Lemma Zpower_nat_is_exp : forall (n m:nat) (z:Z), Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m. Proof. - induction n. + intros n; induction n as [|n IHn]. - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l. - intros. simpl. now rewrite IHn, Z.mul_assoc. Qed. @@ -135,7 +135,7 @@ Section Powers_of_2. Lemma two_power_nat_equiv n : two_power_nat n = 2 ^ (Z.of_nat n). Proof. - induction n. + induction n as [|n IHn]. - trivial. - now rewrite Nat2Z.inj_succ, Z.pow_succ_r, <- IHn by apply Nat2Z.is_nonneg. Qed. @@ -164,7 +164,7 @@ Section Powers_of_2. Theorem shift_nat_correct n x : Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x. Proof. - induction n. + induction n as [|n IHn]. - trivial. - now rewrite Zpower_nat_succ_r, <- Z.mul_assoc, <- IHn. Qed. @@ -295,7 +295,7 @@ Section power_div_with_rest. rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. repeat split; auto. rewrite !Z.mul_1_l, H, Z.add_assoc. - apply f_equal2 with (f := Z.add); auto. + apply (f_equal2 Z.add); auto. rewrite <- Z.sub_sub_distr, <- !Z.add_diag, Z.add_simpl_r. now rewrite Z.mul_1_l. - rewrite Pos2Z.neg_xO in H. @@ -303,7 +303,7 @@ Section power_div_with_rest. repeat split; auto. - repeat split; auto. rewrite H, (Z.mul_opp_l 1), Z.mul_1_l, Z.add_assoc. - apply f_equal2 with (f := Z.add); auto. + apply (f_equal2 Z.add); auto. rewrite Z.add_comm, <- Z.add_diag. rewrite Z.mul_add_distr_l. replace (-1 * d) with (-d). 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..e4129f8382 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,10 +1369,16 @@ Section S. simpl in *. subst. destruct pol;auto. - generalize (is_cnf_ff_inv (xcnf (negb true) f1)). - destruct (is_cnf_ff (xcnf (negb true) f1)). + generalize (is_cnf_tt_inv (xcnf (negb true) f1)). + destruct (is_cnf_tt (xcnf (negb true) f1)). + intros H. rewrite H by auto. + reflexivity. + + + generalize (is_cnf_ff_inv (xcnf (negb true) f1)). + destruct (is_cnf_ff (xcnf (negb true) f1)). + * intros H. + rewrite H by auto. unfold or_cnf_opt. simpl. destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto. @@ -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..a4b631fc13 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -38,7 +38,7 @@ Ltac inv H := inversion H ; try subst ; clear H. Lemma eq_le_iff : forall x, 0 = x <-> (0 <= x /\ x <= 0). Proof. intros. - split ; intros. + split ; intros H. - subst. compute. intuition congruence. - destruct H. @@ -48,7 +48,7 @@ Qed. Lemma lt_le_iff : forall x, 0 < x <-> 0 <= x - 1. Proof. - split ; intros. + split ; intros H. - apply Zlt_succ_le. ring_simplify. auto. @@ -70,12 +70,13 @@ Lemma le_neg : forall x, Proof. intro. rewrite lt_le_iff. - split ; intros. + split ; intros H. - apply Znot_le_gt in H. apply Zgt_le_succ in H. rewrite le_0_iff in H. ring_simplify in H; auto. - - assert (C := (Z.add_le_mono _ _ _ _ H H0)). + - intro H0. + assert (C := (Z.add_le_mono _ _ _ _ H H0)). ring_simplify in C. compute in C. apply C ; reflexivity. @@ -84,7 +85,7 @@ Qed. Lemma eq_cnf : forall x, (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0. Proof. - intros. + intros x. rewrite Z.eq_sym_iff. rewrite eq_le_iff. rewrite (le_0_iff x 0). @@ -108,7 +109,7 @@ Proof. auto using Z.le_antisymm. eauto using Z.le_trans. apply Z.le_neq. - destruct (Z.lt_trichotomy n m) ; intuition. + apply Z.lt_trichotomy. apply Z.add_le_mono_l; assumption. apply Z.mul_pos_pos ; auto. discriminate. @@ -160,18 +161,18 @@ Fixpoint Zeval_const (e: PExpr Z) : option Z := Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. - destruct n. + intros r n; destruct n as [|p]. reflexivity. simpl. unfold Z.pow_pos. replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring. generalize 1. - induction p; simpl ; intros ; repeat rewrite IHp ; ring. + induction p as [p IHp|p IHp|]; simpl ; intros ; repeat rewrite IHp ; ring. Qed. Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. Proof. - induction e ; simpl ; try congruence. + intros env e; induction e ; simpl ; try congruence. reflexivity. rewrite ZNpower. congruence. Qed. @@ -201,7 +202,7 @@ Lemma pop2_bop2 : forall (op : Op2) (q1 q2 : Z), is_true (Zeval_bop2 op q1 q2) <-> Zeval_pop2 op q1 q2. Proof. unfold is_true. - destruct op ; simpl; intros. + intro op; destruct op ; simpl; intros q1 q2. - apply Z.eqb_eq. - rewrite <- Z.eqb_eq. rewrite negb_true_iff. @@ -220,7 +221,7 @@ Definition Zeval_op2 (k: Tauto.kind) : Op2 -> Z -> Z -> Tauto.rtyp k:= Lemma Zeval_op2_hold : forall k op q1 q2, Tauto.hold k (Zeval_op2 k op q1 q2) <-> Zeval_pop2 op q1 q2. Proof. - destruct k. + intro k; destruct k. simpl ; tauto. simpl. apply pop2_bop2. Qed. @@ -235,18 +236,18 @@ Definition Zeval_formula' := Lemma Zeval_formula_compat : forall env k f, Tauto.hold k (Zeval_formula env k f) <-> Zeval_formula env Tauto.isProp f. Proof. - destruct k ; simpl. + intros env k; destruct k ; simpl. - tauto. - - destruct f ; simpl. - rewrite <- Zeval_op2_hold with (k:=Tauto.isBool). + - intros f; destruct f ; simpl. + rewrite <- (Zeval_op2_hold Tauto.isBool). simpl. tauto. Qed. Lemma Zeval_formula_compat' : forall env f, Zeval_formula env Tauto.isProp f <-> Zeval_formula' env f. Proof. - intros. + intros env f. unfold Zeval_formula. - destruct f. + destruct f as [Flhs Fop Frhs]. repeat rewrite Zeval_expr_compat. unfold Zeval_formula' ; simpl. unfold eval_expr. @@ -296,6 +297,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. @@ -340,7 +344,7 @@ Lemma Zunsat_sound : forall f, Zunsat f = true -> forall env, eval_nformula env f -> False. Proof. unfold Zunsat. - intros. + intros f H env ?. destruct f. eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto. Qed. @@ -362,7 +366,7 @@ Lemma xnnormalise_correct : forall env f, eval_nformula env (xnnormalise f) <-> Zeval_formula env Tauto.isProp f. Proof. - intros. + intros env f. rewrite Zeval_formula_compat'. unfold xnnormalise. destruct f as [lhs o rhs]. @@ -372,18 +376,18 @@ Proof. generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env lhs); generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros. + (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros z z0. - split ; intros. - + assert (z0 + (z - z0) = z0 + 0) by congruence. + + assert (z0 + (z - z0) = z0 + 0) as H0 by congruence. rewrite Z.add_0_r in H0. rewrite <- H0. ring. + subst. ring. - - split ; repeat intro. + - split ; intros H H0. subst. apply H. ring. apply H. - assert (z0 + (z - z0) = z0 + 0) by congruence. + assert (z0 + (z - z0) = z0 + 0) as H1 by congruence. rewrite Z.add_0_r in H1. rewrite <- H1. ring. @@ -393,11 +397,11 @@ Proof. - split ; intros. + apply Zle_0_minus_le; auto. + apply Zle_minus_le_0; auto. - - split ; intros. + - split ; intros H. + apply Zlt_0_minus_lt; auto. + apply Zlt_left_lt in H. apply H. - - split ; intros. + - split ; intros H. + apply Zlt_0_minus_lt ; auto. + apply Zlt_left_lt in H. apply H. @@ -427,7 +431,7 @@ Ltac iff_ring := Lemma xnormalise_correct : forall env f, (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. Proof. - intros. + intros env f. destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; generalize (eval_pol env e) as x; intro. @@ -455,11 +459,11 @@ Lemma cnf_of_list_correct : make_conj (fun x : NFormula Z => eval_nformula env x -> False) f. Proof. unfold cnf_of_list. - intros. + intros T tg f env. set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) => if Zunsat x then acc else ((x, tg) :: nil) :: acc)). set (E := ((fun x : NFormula Z => eval_nformula env x -> False))). - induction f. + induction f as [|a f IHf]. - compute. tauto. - rewrite make_conj_cons. @@ -486,10 +490,10 @@ Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env Tauto.isProp t. Proof. - intros. + intros T env t tg. rewrite <- xnnormalise_correct. unfold normalise. - generalize (xnnormalise t) as f;intro. + generalize (xnnormalise t) as f;intro f. destruct (Zunsat f) eqn:U. - assert (US := Zunsat_sound _ U env). rewrite eval_cnf_ff. @@ -516,10 +520,10 @@ Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := Lemma xnegate_correct : forall env f, (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. Proof. - intros. + intros env f. destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - generalize (eval_pol env e) as x; intro. + generalize (eval_pol env e) as x; intro x. - tauto. - rewrite eq_cnf. destruct (Z.eq_decidable x 0);tauto. @@ -530,10 +534,10 @@ Qed. Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env Tauto.isProp t. Proof. - intros. + intros T env t tg. rewrite <- xnnormalise_correct. unfold negate. - generalize (xnnormalise t) as f;intro. + generalize (xnnormalise t) as f;intro f. destruct (Zunsat f) eqn:U. - assert (US := Zunsat_sound _ U env). rewrite eval_cnf_tt. @@ -566,10 +570,10 @@ Require Import Znumtheory. Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. Proof. unfold ceiling. - intros. + intros a b H. apply Zdivide_mod in H. case_eq (Z.div_eucl a b). - intros. + intros z z0 H0. change z with (fst (z,z0)). rewrite <- H0. change (fst (Z.div_eucl a b)) with (Z.div a b). @@ -608,16 +612,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. @@ -637,12 +643,12 @@ Definition isZ0 (x:Z) := Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. Proof. - destruct x ; simpl ; intuition congruence. + intros x; destruct x ; simpl ; intuition congruence. Qed. Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. Proof. - destruct x ; simpl ; intuition congruence. + intros x; destruct x ; simpl ; intuition congruence. Qed. Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. @@ -677,8 +683,8 @@ Inductive Zdivide_pol (x:Z): PolC Z -> Prop := Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). Proof. - intros until 2. - induction H0. + intros a p H H0. + induction H0 as [? ?|? ? IHZdivide_pol j|? ? ? IHZdivide_pol1 ? IHZdivide_pol2 j]. (* Pc *) simpl. intros. @@ -697,7 +703,7 @@ Qed. Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. Proof. - induction p. 1-2: easy. + intros p; induction p as [c|p p1 IHp1|p1 IHp1 ? p3 IHp3]. 1-2: easy. simpl. case_eq (Zgcd_pol p1). case_eq (Zgcd_pol p3). @@ -710,7 +716,7 @@ Qed. Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. Proof. - intros. + intros p x y H H0. induction H. constructor. apply Z.divide_trans with (1:= H0) ; assumption. @@ -720,7 +726,7 @@ Qed. Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. Proof. - induction p ; constructor ; auto. + intros p; induction p as [c| |]; constructor ; auto. exists c. ring. Qed. @@ -739,19 +745,19 @@ Lemma Zdivide_pol_sub : forall p a b, Zdivide_pol a (PsubC Z.sub p b) -> Zdivide_pol (Z.gcd a b) p. Proof. - induction p. + intros p; induction p as [c|? p IHp|p ? ? ? IHp2]. simpl. - intros. inversion H0. + intros a b H H0. inversion H0. constructor. apply Zgcd_minus ; auto. - intros. + intros ? ? H H0. constructor. simpl in H0. inversion H0 ; subst; clear H0. apply IHp ; auto. - simpl. intros. + simpl. intros a b H H0. inv H0. constructor. - apply Zdivide_pol_Zdivide with (1:= H3). + apply Zdivide_pol_Zdivide with (1:= (ltac:(assumption) : Zdivide_pol a p)). destruct (Zgcd_is_gcd a b) ; assumption. apply IHp2 ; assumption. Qed. @@ -760,15 +766,15 @@ Lemma Zdivide_pol_sub_0 : forall p a, Zdivide_pol a (PsubC Z.sub p 0) -> Zdivide_pol a p. Proof. - induction p. + intros p; induction p as [c|? p IHp|? IHp1 ? ? IHp2]. simpl. - intros. inversion H. + intros ? H. inversion H. constructor. rewrite Z.sub_0_r in *. assumption. - intros. + intros ? H. constructor. simpl in H. inversion H ; subst; clear H. apply IHp ; auto. - simpl. intros. + simpl. intros ? H. inv H. constructor. auto. apply IHp2 ; assumption. @@ -778,9 +784,9 @@ Qed. Lemma Zgcd_pol_div : forall p g c, Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). Proof. - induction p ; simpl. + intros p; induction p as [c|? ? IHp|p1 IHp1 ? p3 IHp2]; simpl. (* Pc *) - intros. inv H. + intros ? ? H. inv H. constructor. exists 0. now ring. (* Pinj *) @@ -788,28 +794,28 @@ Proof. constructor. apply IHp ; auto. (* PX *) intros g c. - case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. + case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros z z0 H z1 z2 H0 H1. inv H1. unfold ZgcdM at 1. destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; destruct HH1 as [HH1 HH1'] ; rewrite HH1'. constructor. - apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). + apply (Zdivide_pol_Zdivide _ (ZgcdM z1 z2)). unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. - destruct HH2. + destruct HH2 as [H1 H2]. rewrite H2. apply Zdivide_pol_sub ; auto. apply Z.lt_le_trans with 1. reflexivity. now apply Z.ge_le. - destruct HH2. rewrite H2. + destruct HH2 as [H1 H2]. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. - destruct HH2. rewrite H2 in *. + destruct HH2 as [H1 H2]. rewrite H2 in *. destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. - destruct HH2. rewrite H2. + destruct HH2 as [H1 H2]. rewrite H2. destruct (Zgcd_is_gcd 1 z); auto. - apply Zdivide_pol_Zdivide with (x:= z). + apply (Zdivide_pol_Zdivide _ z). apply (IHp2 _ _ H); auto. destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. constructor. apply Zdivide_pol_one. @@ -868,7 +874,7 @@ Definition is_pol_Z0 (p : PolC Z) : bool := Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. Proof. unfold is_pol_Z0. - destruct p ; try discriminate. + intros p; destruct p as [z| |]; try discriminate. destruct z ; try discriminate. reflexivity. Qed. @@ -910,8 +916,8 @@ Fixpoint max_var (jmp : positive) (p : Pol Z) : positive := Lemma pos_le_add : forall y x, (x <= y + x)%positive. Proof. - intros. - assert ((Z.pos x) <= Z.pos (x + y))%Z. + intros y x. + assert ((Z.pos x) <= Z.pos (x + y))%Z as H. rewrite <- (Z.add_0_r (Zpos x)). rewrite <- Pos2Z.add_pos_pos. apply Z.add_le_mono_l. @@ -924,10 +930,10 @@ Qed. Lemma max_var_le : forall p v, (v <= max_var v p)%positive. Proof. - induction p; simpl. + intros p; induction p as [?|p ? IHp|? IHp1 ? ? IHp2]; simpl. - intros. apply Pos.le_refl. - - intros. + - intros v. specialize (IHp (p+v)%positive). eapply Pos.le_trans ; eauto. assert (xH + v <= p + v)%positive. @@ -937,7 +943,7 @@ Proof. } eapply Pos.le_trans ; eauto. apply pos_le_add. - - intros. + - intros v. apply Pos.max_case_strong;intros ; auto. specialize (IHp2 (Pos.succ v)%positive). eapply Pos.le_trans ; eauto. @@ -946,10 +952,10 @@ Qed. Lemma max_var_correct : forall p j v, In v (vars j p) -> Pos.le v (max_var j p). Proof. - induction p; simpl. + intros p; induction p; simpl. - tauto. - auto. - - intros. + - intros j v H. rewrite in_app_iff in H. destruct H as [H |[ H | H]]. + subst. @@ -975,7 +981,7 @@ Section MaxVar. (v <= acc -> v <= fold_left F l acc)%positive. Proof. - induction l ; simpl ; [easy|]. + intros l; induction l as [|a l IHl] ; simpl ; [easy|]. intros. apply IHl. unfold F. @@ -988,7 +994,7 @@ Section MaxVar. (acc <= acc' -> fold_left F l acc <= fold_left F l acc')%positive. Proof. - induction l ; simpl ; [easy|]. + intros l; induction l as [|a l IHl]; simpl ; [easy|]. intros. apply IHl. unfold F. @@ -1001,13 +1007,13 @@ Section MaxVar. Lemma max_var_nformulae_correct_aux : forall l p o v, In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive. Proof. - intros. + intros l p o v H H0. generalize 1%positive as acc. revert p o v H H0. - induction l. + induction l as [|a l IHl]. - simpl. tauto. - simpl. - intros. + intros p o v H H0 ?. destruct H ; subst. + unfold F at 2. simpl. @@ -1042,13 +1048,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 +1075,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 +1120,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. @@ -1113,14 +1129,14 @@ Require Import Wf_nat. Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). Proof. - induction l. + intros l; induction l as [|a l IHl]. (* nil *) simpl. tauto. (* cons *) simpl. - intros. - destruct H. + intros a0 b y H. + destruct H as [H|H]. subst. unfold ltof. simpl. @@ -1140,13 +1156,33 @@ 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 -> eval_Psatz l w = Some f' -> eval_nformula env f'. Proof. - intros. - apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. + intros env w l f' H H0. + apply (fun H => eval_Psatz_Sound Zsor ZSORaddon l _ H w) ; auto. apply make_conj_in ; auto. Qed. @@ -1158,7 +1194,7 @@ Proof. unfold nformula_of_cutting_plane. unfold eval_nformula. unfold RingMicromega.eval_nformula. unfold eval_op1. - intros. + intros env e e' c H H0. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. (**) @@ -1166,10 +1202,10 @@ Proof. revert H0. case_eq (Zgcd_pol e) ; intros g c0. generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0). - intros. + intros H0 H1 H2. inv H2. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. - apply Zgcd_pol_correct_lt with (env:=env) in H1. 2: auto using Z.gt_lt. + apply (Zgcd_pol_correct_lt _ env) in H1. 2: auto using Z.gt_lt. apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r. apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). apply Z.le_ge. @@ -1178,7 +1214,7 @@ Proof. rewrite <- H1. assumption. (* g <= 0 *) - intros. inv H2. auto with zarith. + intros H0 H1 H2. inv H2. auto with zarith. Qed. Lemma cutting_plane_sound : forall env f p, @@ -1187,34 +1223,34 @@ Lemma cutting_plane_sound : forall env f p, eval_nformula env (nformula_of_cutting_plane p). Proof. unfold genCuttingPlane. - destruct f as [e op]. + intros env f; destruct f as [e op]. destruct op. (* Equal *) - destruct p as [[e' z] op]. + intros p; destruct p as [[e' z] op]. case_eq (Zgcd_pol e) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|]. case_eq (makeCuttingPlane e). - intros. + intros ? ? H H0 H1 H2 H3. inv H3. unfold makeCuttingPlane in H. rewrite H1 in H. revert H. change (eval_pol env e = 0) in H2. case_eq (Z.gtb g 0). - intros. - rewrite <- Zgt_is_gt_bool in H. + intros H H3. + rewrite <- Zgt_is_gt_bool in H. rewrite Zgcd_pol_correct_lt with (1:= H1) in H2. 2: auto using Z.gt_lt. - unfold nformula_of_cutting_plane. + unfold nformula_of_cutting_plane. change (eval_pol env (padd e' (Pc z)) = 0). inv H3. rewrite eval_pol_add. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. simpl. rewrite andb_false_iff in H0. - destruct H0. + destruct H0 as [H0|H0]. rewrite Zgt_is_gt_bool in H ; congruence. rewrite andb_false_iff in H0. - destruct H0. + destruct H0 as [H0|H0]. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. subst. simpl. @@ -1224,13 +1260,13 @@ Proof. apply Zeq_bool_eq in H0. assert (HH := Zgcd_is_gcd g c). rewrite H0 in HH. - inv HH. + destruct HH as [H3 H4 ?]. apply Zdivide_opp_r in H4. rewrite Zdivide_ceiling ; auto. apply Z.sub_move_0_r. apply Z.div_unique_exact. now intros ->. now rewrite Z.add_move_0_r in H2. - intros. + intros H H3. unfold nformula_of_cutting_plane. inv H3. change (eval_pol env (padd e' (Pc 0)) = 0). @@ -1238,7 +1274,7 @@ Proof. simpl. now rewrite Z.add_0_r. (* NonEqual *) - intros. + intros ? H H0. inv H0. unfold eval_nformula in *. unfold RingMicromega.eval_nformula in *. @@ -1247,20 +1283,20 @@ Proof. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. now rewrite Z.add_0_r. (* Strict *) - destruct p as [[e' z] op]. + intros p; destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Z.sub e 1)). - intros. + intros ? ? H H0 H1. inv H1. - apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). + apply (makeCuttingPlane_ns_sound env) with (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). now apply Z.lt_le_pred. (* NonStrict *) - destruct p as [[e' z] op]. + intros p; destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). - intros. + intros ? ? H H0 H1. inv H1. - apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). + apply (makeCuttingPlane_ns_sound env) with (2:= H). assumption. Qed. @@ -1269,12 +1305,15 @@ Lemma genCuttingPlaneNone : forall env f, eval_nformula env f -> False. Proof. unfold genCuttingPlane. - destruct f. + intros env f; destruct f as [p o]. destruct o. case_eq (Zgcd_pol p) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))). - intros. + intros H H0 H1 H2. flatten_bool. + match goal with [ H' : (g >? 0) = true |- ?G ] => rename H' into H3 end. + match goal with [ H' : negb (Zeq_bool c 0) = true |- ?G ] => rename H' into H end. + match goal with [ H' : negb (Zeq_bool (Z.gcd g c) g) = true |- ?G ] => rename H' into H5 end. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. rewrite <- Zgt_is_gt_bool in H3. @@ -1324,7 +1363,7 @@ Lemma agree_env_subset : forall v1 v2 env env', agree_env v2 env env'. Proof. unfold agree_env. - intros. + intros v1 v2 env env' H ? ? ?. apply H. eapply Pos.le_trans ; eauto. Qed. @@ -1334,7 +1373,7 @@ Lemma agree_env_jump : forall fr j env env', agree_env (fr + j) env env' -> agree_env fr (Env.jump j env) (Env.jump j env'). Proof. - intros. + intros fr j env env' H. unfold agree_env ; intro. intros. unfold Env.jump. @@ -1347,7 +1386,7 @@ Lemma agree_env_tail : forall fr env env', agree_env (Pos.succ fr) env env' -> agree_env fr (Env.tail env) (Env.tail env'). Proof. - intros. + intros fr env env' H. unfold Env.tail. apply agree_env_jump. rewrite <- Pos.add_1_r in H. @@ -1358,7 +1397,7 @@ Qed. Lemma max_var_acc : forall p i j, (max_var (i + j) p = max_var i p + j)%positive. Proof. - induction p; simpl. + intros p; induction p as [|? ? IHp|? IHp1 ? ? IHp2]; simpl. - reflexivity. - intros. rewrite ! IHp. @@ -1380,27 +1419,27 @@ Lemma agree_env_eval_nformula : (AGREE : agree_env (max_var xH (fst e)) env env'), eval_nformula env e <-> eval_nformula env' e. Proof. - destruct e. - simpl; intros. + intros env env' e; destruct e as [p o]. + simpl; intros AGREE. assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p) = - (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)). + (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)) as H. { revert env env' AGREE. generalize xH. - induction p ; simpl. + induction p as [?|p ? IHp|? IHp1 ? ? IHp2]; simpl. - reflexivity. - - intros. - apply IHp with (p := p1%positive). + - intros p1 **. + apply (IHp p1). apply agree_env_jump. eapply agree_env_subset; eauto. rewrite (Pos.add_comm p). rewrite max_var_acc. apply Pos.le_refl. - - intros. + - intros p ? ? AGREE. f_equal. f_equal. - { apply IHp1 with (p:= p). + { apply (IHp1 p). eapply agree_env_subset; eauto. apply Pos.le_max_l. } @@ -1411,7 +1450,7 @@ Proof. apply Pos.le_1_l. } { - apply IHp2 with (p := p). + apply (IHp2 p). apply agree_env_tail. eapply agree_env_subset; eauto. rewrite !Pplus_one_succ_r. @@ -1428,11 +1467,11 @@ Lemma agree_env_eval_nformulae : make_conj (eval_nformula env) l <-> make_conj (eval_nformula env') l. Proof. - induction l. + intros env env' l; induction l as [|a l IHl]. - simpl. tauto. - intros. rewrite ! make_conj_cons. - assert (eval_nformula env a <-> eval_nformula env' a). + assert (eval_nformula env a <-> eval_nformula env' a) as H. { apply agree_env_eval_nformula. eapply agree_env_subset ; eauto. @@ -1456,7 +1495,7 @@ Qed. Lemma eq_true_iff_eq : forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2. Proof. - destruct b1,b2 ; intuition congruence. + intros b1 b2; destruct b1,b2 ; intuition congruence. Qed. Ltac pos_tac := @@ -1470,11 +1509,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]. + intros w; induction w as [w H] using (well_founded_ind (well_founded_ltof _ bdepth)). + destruct w as [ | w pf | w pf | p pf1 pf2 | w1 w2 pf | x pf]. - (* DoneProof *) simpl. discriminate. - (* RatProof *) @@ -1482,12 +1533,12 @@ Proof. intros l. case_eq (eval_Psatz l w) ; [| discriminate]. intros f Hf. case_eq (Zunsat f). - intros. + intros H0 ? ?. apply (checker_nf_sound Zsor ZSORaddon l w). unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. unfold Zunsat in H0. assumption. - intros. - assert (make_impl (eval_nformula env) (f::l) False). + intros H0 H1 env. + assert (make_impl (eval_nformula env) (f::l) False) as H2. apply H with (2:= H1). unfold ltof. simpl. @@ -1506,8 +1557,8 @@ Proof. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. case_eq (genCuttingPlane f'). - intros. - assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). + intros p H0 H1 env. + assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False) as H2. eapply (H pf) ; auto. unfold ltof. simpl. @@ -1518,15 +1569,37 @@ Proof. intro. apply H2. split ; auto. - apply eval_Psatz_sound with (env:=env) in Hlc. + apply (eval_Psatz_sound env) in Hlc. apply cutting_plane_sound with (1:= Hlc) (2:= H0). auto. (* genCuttingPlane = None *) - intros. + intros H0 H1 env. rewrite <- make_conj_impl. - intros. + intros H2. 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. + match goal with [ H' : ZChecker _ pf1 = true |- _ ] => rename H' into H0 end. + match goal with [ H' : ZChecker _ pf2 = true |- _ ] => rename H' into H1 end. + destruct (eval_nformula_split env p). + + apply (fun H' ck => H _ H' _ ck env) in H0. + rewrite <- make_conj_impl in *. + intro ; apply H0. + rewrite make_conj_cons. split; auto. + apply (cutting_plane_sound _ (p,NonStrict)) ; auto. + apply ltof_bdepth_split_l. + + apply (fun H' ck => H _ H' _ ck env) in H1. + rewrite <- make_conj_impl in *. + intro ; apply H1. + rewrite make_conj_cons. split; auto. + apply (cutting_plane_sound _ (popp p,NonStrict)) ; auto. + apply ltof_bdepth_split_r. - (* EnumProof *) intros l. simpl. @@ -1534,22 +1607,22 @@ Proof. case_eq (eval_Psatz l w2) ; [ | discriminate]. intros f1 Hf1 f2 Hf2. case_eq (genCuttingPlane f2). - destruct p as [ [p1 z1] op1]. + intros p; destruct p as [ [p1 z1] op1]. case_eq (genCuttingPlane f1). - destruct p as [ [p2 z2] op2]. + intros p; destruct p as [ [p2 z2] op2]. case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). intros Hcond. flatten_bool. - rename H1 into HZ0. - rename H2 into Hop1. - rename H3 into Hop2. + match goal with [ H1 : is_pol_Z0 (padd p1 p2) = true |- _ ] => rename H1 into HZ0 end. + match goal with [ H2 : valid_cut_sign op1 = true |- _ ] => rename H2 into Hop1 end. + match goal with [ H3 : valid_cut_sign op2 = true |- _ ] => rename H3 into Hop2 end. intros HCutL HCutR Hfix env. (* get the bounds of the enum *) rewrite <- make_conj_impl. - intro. - assert (-z1 <= eval_pol env p1 <= z2). + intro H0. + assert (-z1 <= eval_pol env p1 <= z2) as H1. split. - apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. + apply (eval_Psatz_sound env) in Hf2 ; auto. apply cutting_plane_sound with (1:= Hf2) in HCutR. unfold nformula_of_cutting_plane in HCutR. unfold eval_nformula in HCutR. @@ -1561,10 +1634,10 @@ Proof. rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity. now apply Z.le_sub_le_add_r in HCutR. (**) - apply is_pol_Z0_eval_pol with (env := env) in HZ0. + apply (fun H => is_pol_Z0_eval_pol _ H env) in HZ0. rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0. rewrite HZ0. - apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. + apply (eval_Psatz_sound env) in Hf1 ; auto. apply cutting_plane_sound with (1:= Hf1) in HCutL. unfold nformula_of_cutting_plane in HCutL. unfold eval_nformula in HCutL. @@ -1580,7 +1653,7 @@ Proof. match goal with | |- context[?F pf (-z1) z2 = true] => set (FF := F) end. - intros. + intros Hfix. assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). @@ -1588,16 +1661,18 @@ Proof. revert Hfix. generalize (-z1). clear z1. intro z1. revert z1 z2. - induction pf;simpl ;intros. + induction pf as [|a pf IHpf];simpl ;intros z1 z2 Hfix x **. revert Hfix. now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zlt_not_le _ _ LT); transitivity x. flatten_bool. + match goal with [ H' : _ <= x <= _ |- _ ] => rename H' into H0 end. + match goal with [ H' : FF pf (z1 + 1) z2 = true |- _ ] => rename H' into H2 end. destruct (Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ]. 2: exists a; auto. rewrite <- Z.le_succ_l in LT. assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition. elim IHpf with (2:=H2) (3:= LE). - intros. + intros x0 ?. exists x0 ; split;tauto. intros until 1. apply H ; auto. @@ -1609,7 +1684,7 @@ Proof. apply Z.add_le_mono_r. assumption. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. - assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). + assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False) as H2. eapply (H pr) ;auto. apply in_bdepth ; auto. rewrite <- make_conj_impl in H2. @@ -1623,15 +1698,15 @@ Proof. unfold eval_pol. ring. discriminate. (* No cutting plane *) - intros. + intros H0 H1 H2 env. rewrite <- make_conj_impl. - intros. + intros H3. apply eval_Psatz_sound with (2:= Hf1) in H3. apply genCuttingPlaneNone with (2:= H3) ; auto. (* No Cutting plane (bis) *) - intros. + intros H0 H1 env. rewrite <- make_conj_impl. - intros. + intros H2. apply eval_Psatz_sound with (2:= Hf2) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. - intros l. @@ -1641,15 +1716,15 @@ Proof. set (z1 := (Pos.succ fr)) in *. set (t1 := (Pos.succ z1)) in *. destruct (x <=? fr)%positive eqn:LE ; [|congruence]. - intros. + intros H0 env. set (env':= fun v => if Pos.eqb v z1 then if Z.leb (env x) 0 then 0 else env x else if Pos.eqb v t1 then if Z.leb (env x) 0 then -(env x) else 0 else env v). - apply H with (env:=env') in H0. + apply (fun H' ck => H _ H' _ ck env') in H0. + rewrite <- make_conj_impl in *. - intro. + intro H1. rewrite !make_conj_cons in H0. apply H0 ; repeat split. * @@ -1662,17 +1737,17 @@ Proof. destruct (env x <=? 0); ring. { unfold t1. pos_tac; normZ. - lia (Hyp H2). + lia (Hyp (e := Z.pos z1 - Z.succ (Z.pos z1)) ltac:(assumption)). } { unfold t1, z1. pos_tac; normZ. - lia (Add (Hyp LE) (Hyp H3)). + lia (Add (Hyp LE) (Hyp (e := Z.pos x - Z.succ (Z.succ (Z.pos fr))) ltac:(assumption))). } { unfold z1. pos_tac; normZ. - lia (Add (Hyp LE) (Hyp H3)). + lia (Add (Hyp LE) (Hyp (e := Z.pos x - Z.succ (Z.pos fr)) ltac:(assumption))). } * apply eval_nformula_bound_var. @@ -1682,7 +1757,7 @@ Proof. compute. congruence. rewrite Z.leb_gt in EQ. normZ. - lia (Add (Hyp EQ) (Hyp H2)). + lia (Add (Hyp EQ) (Hyp (e := 0 - (env x + 1)) ltac:(assumption))). * apply eval_nformula_bound_var. unfold env'. @@ -1691,15 +1766,15 @@ Proof. destruct (env x <=? 0) eqn:EQ. rewrite Z.leb_le in EQ. normZ. - lia (Add (Hyp EQ) (Hyp H2)). + lia (Add (Hyp EQ) (Hyp (e := 0 - (- env x + 1)) ltac:(assumption))). compute; congruence. unfold t1. clear. pos_tac; normZ. - lia (Hyp H). + lia (Hyp (e := Z.pos z1 - Z.succ (Z.pos z1)) ltac:(assumption)). * - rewrite agree_env_eval_nformulae with (env':= env') in H1;auto. - unfold agree_env; intros. + rewrite (agree_env_eval_nformulae _ env') in H1;auto. + unfold agree_env; intros x0 H2. unfold env'. replace (x0 =? z1)%positive with false. replace (x0 =? t1)%positive with false. @@ -1709,13 +1784,13 @@ Proof. unfold fr in *. apply Pos2Z.pos_le_pos in H2. pos_tac; normZ. - lia (Add (Hyp H2) (Hyp H4)). + lia (Add (Hyp H2) (Hyp (e := Z.pos x0 - Z.succ (Z.succ (Z.pos (max_var_nformulae l)))) ltac:(assumption))). } { unfold z1, fr in *. apply Pos2Z.pos_le_pos in H2. pos_tac; normZ. - lia (Add (Hyp H2) (Hyp H4)). + lia (Add (Hyp H2) (Hyp (e := Z.pos x0 - Z.succ (Z.pos (max_var_nformulae l))) ltac:(assumption))). } + unfold ltof. simpl. @@ -1729,27 +1804,27 @@ Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, Proof. intros f w. unfold ZTautoChecker. - apply tauto_checker_sound with (eval' := eval_nformula). + apply (tauto_checker_sound _ _ _ _ eval_nformula). - apply Zeval_nformula_dec. - - intros until env. + - intros t ? env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - - unfold Zdeduce. intros. revert H. + - unfold Zdeduce. intros ? ? ? H **. revert H. apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - - intros. + intros ? ? ? ? H. rewrite normalise_correct in H. rewrite Zeval_formula_compat; auto. - - intros. + intros ? ? ? ? H. rewrite negate_correct in H ; auto. rewrite Tauto.hold_eNOT. rewrite Zeval_formula_compat; auto. - intros t w0. unfold eval_tt. - intros. - rewrite make_impl_map with (eval := eval_nformula env). + intros H env. + rewrite (make_impl_map (eval_nformula env)). eapply ZChecker_sound; eauto. tauto. Qed. @@ -1758,6 +1833,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/setoid_ring/Field_theory.v b/theories/setoid_ring/Field_theory.v index c12f46bed6..4b3bba9843 100644 --- a/theories/setoid_ring/Field_theory.v +++ b/theories/setoid_ring/Field_theory.v @@ -397,7 +397,7 @@ Qed. Theorem cross_product_eq a b c d : ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d. Proof. -intros. +intros H H0 H1. transitivity (a / b * (d / d)). - now rewrite rdiv_r_r, rmul_1_r. - now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r. @@ -418,23 +418,23 @@ Qed. Lemma pow_pos_0 p : pow_pos rmul 0 p == 0. Proof. -induction p;simpl;trivial; now rewrite !IHp. +induction p as [p IHp|p IHp|];simpl;trivial; now rewrite !IHp. Qed. Lemma pow_pos_1 p : pow_pos rmul 1 p == 1. Proof. -induction p;simpl;trivial; ring [IHp]. +induction p as [p IHp|p IHp|];simpl;trivial; ring [IHp]. Qed. Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. Proof. -induction p;simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. +induction p as [p IHp|p IHp|];simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. Qed. Lemma pow_pos_mul_l x y p : pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. Proof. -induction p;simpl;trivial; ring [IHp]. +induction p as [p IHp|p IHp|];simpl;trivial; ring [IHp]. Qed. Lemma pow_pos_add_r x p1 p2 : @@ -446,7 +446,7 @@ Qed. Lemma pow_pos_mul_r x p1 p2 : pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2. Proof. -induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; +induction p1 as [p1 IHp1|p1 IHp1|];simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; simpl; trivial; ring [IHp1]. Qed. @@ -459,8 +459,8 @@ Qed. Lemma pow_pos_div a b p : ~ b == 0 -> pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p. Proof. - intros. - induction p; simpl; trivial. + intros H. + induction p as [p IHp|p IHp|]; simpl; trivial. - rewrite IHp. assert (nz := pow_pos_nz p H). rewrite !rdiv4; trivial. @@ -578,14 +578,15 @@ Qed. Theorem PExpr_eq_semi_ok e e' : PExpr_eq e e' = true -> (e === e')%poly. Proof. -revert e'; induction e; destruct e'; simpl; try discriminate. +revert e'; induction e as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe|? IHe ?]; + intro e'; destruct e'; simpl; try discriminate. - intros H l. now apply (morph_eq CRmorph). - case Pos.eqb_spec; intros; now subst. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H. now rewrite IHe. -- intros H. destruct (if_true _ _ H). +- intros H. destruct (if_true _ _ H) as [H0 H1]. apply N.eqb_eq in H0. now rewrite IHe, H0. Qed. @@ -667,7 +668,7 @@ Proof. - case Pos.eqb_spec; [intro; subst | intros _]. + simpl. now rewrite rpow_pow. + destruct e;simpl;trivial. - repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl. + repeat case ceqb_spec; intros H **; rewrite ?rpow_pow, ?H; simpl. * now rewrite phi_1, pow_pos_1. * now rewrite phi_0, pow_pos_0. * now rewrite pow_pos_cst. @@ -686,7 +687,8 @@ Infix "**" := NPEmul (at level 40, left associativity). Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. Proof. intros l. -revert e2; induction e1;destruct e2; simpl;try reflexivity; +revert e2; induction e1 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1|? IHe1 n]; + intro e2; destruct e2; simpl;try reflexivity; repeat (case ceqb_spec; intro H; try rewrite H; clear H); simpl; try reflexivity; try ring [phi_0 phi_1]. apply (morph_mul CRmorph). @@ -801,7 +803,7 @@ Qed. Theorem PCond_app l l1 l2 : PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2. Proof. -induction l1. +induction l1 as [|a l1 IHl1]. - simpl. split; [split|destruct 1]; trivial. - simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. Qed. @@ -813,7 +815,7 @@ Definition absurd_PCond := cons 0%poly nil. Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. Proof. unfold absurd_PCond; simpl. -red; intros. +red; intros ? H. apply H. apply phi_0. Qed. @@ -901,7 +903,7 @@ Theorem isIn_ok e1 p1 e2 p2 : Proof. Opaque NPEpow. revert p1 p2. -induction e2; intros p1 p2; +induction e2 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe2_1 ? IHe2_2|? IHe|? IHe2 n]; intros p1 p2; try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. - specialize (IHe2_1 p1 p2). destruct isIn as [([|p],e)|]. @@ -936,7 +938,7 @@ induction e2; intros p1 p2; destruct IHe2_2 as (IH,GT). split; trivial. set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. npe_simpl. rewrite IH. npe_ring. -- destruct n; trivial. +- destruct n as [|p]; trivial. specialize (IHe2 p1 (p * p2)%positive). destruct isIn as [(n,e)|]; trivial. destruct IHe2 as (IH,GT). split; trivial. @@ -983,7 +985,7 @@ Lemma split_aux_ok1 e1 p e2 : /\ e2 === right res * common res)%poly. Proof. Opaque NPEpow NPEmul. - intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). + intros res. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. - intros (H1,H2); split; npe_simpl. + now rewrite PE_1_l. @@ -1000,7 +1002,8 @@ Theorem split_aux_ok: forall e1 p e2, (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2) /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly. Proof. -induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl. +intro e1;induction e1 as [| |?|?|? IHe1_1 ? IHe1_2|? IHe1_1 ? IHe1_2|e1_1 IHe1_1 ? IHe1_2|? IHe1|? IHe1 n]; + intros k e2; try refine (split_aux_ok1 _ k e2);simpl. destruct (IHe1_1 k e2) as (H1,H2). destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4). clear IHe1_1 IHe1_2. @@ -1101,7 +1104,8 @@ Eval compute Theorem Pcond_Fnorm l e : PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. Proof. -induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; +induction e as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe|? IHe|? IHe1 ? IHe2|? IHe n]; + simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. - simpl. rewrite phi_1; exact rI_neq_rO. - simpl. rewrite phi_1; exact rI_neq_rO. @@ -1141,7 +1145,8 @@ Theorem Fnorm_FEeval_PEeval l fe: PCond l (condition (Fnorm fe)) -> FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l. Proof. -induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; +induction fe as [| |?|?|fe1 IHfe1 fe2 IHfe2|fe1 IHfe1 fe2 IHfe2|fe1 IHfe1 fe2 IHfe2|fe IHfe|fe IHfe|fe1 IHfe1 fe2 IHfe2|fe IHfe n]; + simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; intros (Hc1,Hc2) || intros Hc; try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1); try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2); @@ -1260,7 +1265,7 @@ Proof. destruct (Nnorm _ _ _) as [c | | ] eqn: HN; try ( apply rdiv_ext; eapply ring_rw_correct; eauto). - destruct (ceqb_spec c cI). + destruct (ceqb_spec c cI) as [H0|]. set (nnum := NPphi_dev _ _). apply eq_trans with (nnum / NPphi_dev l (Pc c)). apply rdiv_ext; @@ -1285,7 +1290,7 @@ Proof. destruct (Nnorm _ _ _) as [c | | ] eqn: HN; try ( apply rdiv_ext; eapply ring_rw_pow_correct; eauto). - destruct (ceqb_spec c cI). + destruct (ceqb_spec c cI) as [H0|]. set (nnum := NPphi_pow _ _). apply eq_trans with (nnum / NPphi_pow l (Pc c)). apply rdiv_ext; @@ -1415,7 +1420,8 @@ Theorem Field_simplify_eq_pow_in_correct : NPphi_pow l np1 == NPphi_pow l np2. Proof. - intros. subst nfe1 nfe2 lmp np1 np2. + intros n l lpe fe1 fe2 ? lmp ? nfe1 ? nfe2 ? den ? np1 ? np2 ? ? ?. + subst nfe1 nfe2 lmp np1 np2. rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. apply Field_simplify_aux_ok; trivial. @@ -1434,7 +1440,8 @@ forall n l lpe fe1 fe2, PCond l (condition nfe1 ++ condition nfe2) -> NPphi_dev l np1 == NPphi_dev l np2. Proof. - intros. subst nfe1 nfe2 lmp np1 np2. + intros n l lpe fe1 fe2 ? lmp ? nfe1 ? nfe2 ? den ? np1 ? np2 ? ? ?. + subst nfe1 nfe2 lmp np1 np2. rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). apply Field_simplify_aux_ok; trivial. @@ -1458,7 +1465,7 @@ Lemma fcons_ok : forall l l1, (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. Proof. intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. -induction l1; simpl; intros. +induction l1 as [|a l1 IHl1]; simpl; intros. trivial. elim PCond_fcons_inv with (1 := H); intros. destruct l1; trivial. split; trivial. apply IHl1; trivial. @@ -1480,7 +1487,7 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := Theorem PFcons_fcons_inv: forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. -induction l1 as [|e l1]; simpl Fcons. +intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons. - simpl; now split. - case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2); repeat split; trivial. @@ -1501,7 +1508,7 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. -induction l1 as [|e l1]; simpl Fcons0. +intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons0. - simpl; now split. - generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); @@ -1529,7 +1536,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). destruct (H0 _ H3) as (H4,H5). split; trivial. simpl. apply field_is_integral_domain; trivial. -- intros. destruct (H _ H0). split; trivial. +- intros ? H ? ? H0. destruct (H _ H0). split; trivial. apply PEpow_nz; trivial. Qed. @@ -1580,7 +1587,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). split; trivial. apply ropp_neq_0; trivial. rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial. -- intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. +- intros ? H ? ? H0. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. Qed. Definition Fcons2 e l := Fcons1 (PEsimp e) l. @@ -1674,7 +1681,7 @@ Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. Lemma add_inj_r p x y : gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. Proof. -elim p using Pos.peano_ind; simpl; intros. +elim p using Pos.peano_ind; simpl; [intros H|intros ? H ?]. apply S_inj; trivial. apply H. apply S_inj. @@ -1710,8 +1717,8 @@ Lemma gen_phiN_inj x y : gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> x = y. Proof. -destruct x; destruct y; simpl; intros; trivial. - elim gen_phiPOS_not_0 with p. +destruct x as [|p]; destruct y as [|p']; simpl; intros H; trivial. + elim gen_phiPOS_not_0 with p'. symmetry . rewrite (same_gen Rsth Reqe ARth); trivial. elim gen_phiPOS_not_0 with p. @@ -1770,14 +1777,14 @@ Lemma gen_phiZ_inj x y : gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> x = y. Proof. -destruct x; destruct y; simpl; intros. +destruct x as [|p|p]; destruct y as [|p'|p']; simpl; intros H. trivial. - elim gen_phiPOS_not_0 with p. + elim gen_phiPOS_not_0 with p'. rewrite (same_gen Rsth Reqe ARth). symmetry ; trivial. - elim gen_phiPOS_not_0 with p. + elim gen_phiPOS_not_0 with p'. rewrite (same_gen Rsth Reqe ARth). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p')). rewrite <- H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_not_0 with p. @@ -1790,12 +1797,12 @@ destruct x; destruct y; simpl; intros. rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite H. apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_discr_sgn with p0 p. + elim gen_phiPOS_discr_sgn with p' p. symmetry ; trivial. - replace p0 with p; trivial. + replace p' with p; trivial. apply gen_phiPOS_inject. rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)). + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p')). rewrite H; trivial. reflexivity. Qed. 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/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index a87dfb5b2e..50aa658128 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -48,7 +48,7 @@ let is_keyword = "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; - "subgoal"; "subgoals"; "vm_compute"; + "goal"; "goals"; "vm_compute"; "Opaque"; "Transparent"; "Time"; "Extraction"; "Extract"; "Variant"; @@ -783,7 +783,7 @@ module Html = struct printf " <td class=\"infrule\">%s</td>\n" (replace_spaces line)) in let end_assumption () = (printf " <td></td>\n"; - printf "</td>\n") in + printf "</tr>\n") in let rec print_assumptions hyps = match hyps with | [] -> start_assumption " " 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/Constr.v b/user-contrib/Ltac2/Constr.v index 4cc9d99c64..72cac900cd 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -24,7 +24,7 @@ Ltac2 Type case. Ltac2 Type case_invert := [ | NoInvert -| CaseInvert (instance,constr array) +| CaseInvert (constr array) ]. Ltac2 Type kind := [ 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/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 65b61a0d93..548e12d611 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -213,7 +213,7 @@ GRAMMAR EXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } + | IDENT "pat"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1 loc qid } | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1val loc qid } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 5d49d1635c..241ca7ad66 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -109,15 +109,14 @@ let to_rec_declaration (nas, cs) = let of_case_invert = let open Constr in function | NoInvert -> ValInt 0 - | CaseInvert {univs;args} -> - v_blk 0 [|of_instance univs; of_array of_constr args|] + | CaseInvert {indices} -> + v_blk 0 [|of_array of_constr indices|] let to_case_invert = let open Constr in function | ValInt 0 -> NoInvert - | ValBlk (0, [|univs;args|]) -> - let univs = to_instance univs in - let args = to_array to_constr args in - CaseInvert {univs;args} + | ValBlk (0, [|indices|]) -> + let indices = to_array to_constr indices in + CaseInvert {indices} | _ -> CErrors.anomaly Pp.(str "unexpected value shape") let of_result f = function @@ -378,6 +377,7 @@ end let () = define1 "constr_kind" constr begin fun c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> return begin match EConstr.kind sigma c with | Rel n -> v_blk 0 [|Value.of_int n|] @@ -434,7 +434,9 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_constructor cstr; of_instance u; |] - | Case (ci, c, iv, t, bl) -> + | Case (ci, u, pms, c, iv, t, bl) -> + (* FIXME: also change representation Ltac2-side? *) + let (ci, c, iv, t, bl) = EConstr.expand_case env sigma (ci, u, pms, c, iv, t, bl) in v_blk 13 [| Value.of_ext Value.val_case ci; Value.of_constr c; @@ -472,6 +474,8 @@ let () = define1 "constr_kind" constr begin fun c -> end let () = define1 "constr_make" valexpr begin fun knd -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> let c = match Tac2ffi.to_block knd with | (0, [|n|]) -> let n = Value.to_int n in @@ -529,7 +533,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> let iv = to_case_invert iv in let t = Value.to_constr t in let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, iv, t, bl) + EConstr.mkCase (EConstr.contract_case env sigma (ci, c, iv, t, bl)) | (14, [|recs; i; nas; cs|]) -> let recs = Value.to_array Value.to_int recs in let i = Value.to_int i in @@ -1100,7 +1104,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 +1117,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 +1129,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 +1151,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 "pat:(" ++ 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 +1173,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 +1197,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 +1245,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 +1294,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 +1369,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 +1418,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 +1429,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 +1444,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..a54eb45f61 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 () @@ -464,7 +466,7 @@ end let () = register_init "pattern" begin fun env sigma c -> let c = to_pattern c in let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in - str "pattern:(" ++ c ++ str ")" + str "pat:(" ++ c ++ str ")" end let () = register_init "message" begin fun _ _ pp -> diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 69758b3f37..54f5a2cf68 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -209,13 +209,13 @@ let letin_pat_tac ev ipat na c cl = Instead, we parse indifferently any pattern and dispatch when the tactic is called. *) let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (GlobRef.ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) -| Pattern.PRef (GlobRef.VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| Pattern.PRef (GlobRef.ConstRef cst) -> (mk_occurrences_expr occ, Inl (Tacred.EvalConstRef cst)) +| Pattern.PRef (GlobRef.VarRef id) -> (mk_occurrences_expr occ, Inl (Tacred.EvalVarRef id)) | _ -> (mk_occurrences_expr occ, Inr pat) let get_evaluable_reference = function -| GlobRef.VarRef id -> Proofview.tclUNIT (EvalVarRef id) -| GlobRef.ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| GlobRef.VarRef id -> Proofview.tclUNIT (Tacred.EvalVarRef id) +| GlobRef.ConstRef cst -> Proofview.tclUNIT (Tacred.EvalConstRef cst) | r -> Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 848cd501c6..9c5f111e28 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -165,6 +165,31 @@ 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 (ci, u, pms, p, iv, c, bl) -> + let mib = lookup_mind (fst ci.ci_ind) in + let (ci, p, iv, c, bl) = Inductive.expand_case_specif mib (ci, u, pms, p, iv, c, bl) in + 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 @@ -179,20 +204,19 @@ let rec traverse current ctx accu t = | Construct (((mind, _), _) as cst, _) -> traverse_inductive accu mind (ConstructRef cst) | Meta _ | Evar _ -> assert false -| Case (_,oty,_,c,[||]) -> +| Case (_, _, _, ([|_|], oty), _, c, [||]) when Vars.noccurn 1 oty -> (* non dependent match on an inductive with no constructors *) - begin match Constr.(kind oty, kind c) with - | Lambda(_,_,oty), Const (kn, _) - when Vars.noccurn 1 oty && - not (Declareops.constant_has_body (lookup_constant kn)) -> + begin match Constr.kind c with + | Const (kn, _) + when not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Option.map pi1 (Global.body_of_constant_body Library.indirect_accessor (lookup_constant kn)) in 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/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f715459616..cc59a96834 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -351,13 +351,13 @@ let build_beq_scheme mode kn = done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args,NoInvert, - mkVar (Id.of_string "Y") ,ar2)) + (mkCase (Inductive.contract_case env ((ci,do_predicate rel_list nb_cstr_args, + NoInvert, mkVar (Id.of_string "Y") ,ar2)))) (constrsi.(i).cs_args)) done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar))) + mkCase (Inductive.contract_case env (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar)))) in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and diff --git a/vernac/classes.mli b/vernac/classes.mli index e1816fb138..89ff4e6939 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -81,7 +81,7 @@ val add_class : env -> Evd.evar_map -> typeclass -> unit (** Setting opacity *) -val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit +val set_typeclass_transparency : Tacred.evaluable_global_reference -> bool -> bool -> unit (** For generation on names based on classes only *) 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..b3ffb864f2 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -69,9 +69,10 @@ let protect_pattern_in_binder bl c ctypopt = | LetIn (x,b,t,c) -> let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in evd, mkLetIn (x,t,b,c) - | Case (ci,p,iv,a,bl) -> + | Case (ci,u,pms,p,iv,a,bl) -> + let (ci, p, iv, a, bl) = EConstr.expand_case env evd (ci, u, pms, p, iv, a, bl) in let evd,bl = Array.fold_left_map (aux env) evd bl in - evd, mkCase (ci,p,iv,a,bl) + evd, mkCase (EConstr.contract_case env evd (ci, p, iv, a, bl)) | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) (* This last case may happen when reaching the proof of an impossible case, as when pattern-matching on a vector of length 1 *) @@ -110,9 +111,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 +127,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 +149,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/comHints.ml b/vernac/comHints.ml index f642411fa4..1c36e10e83 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -76,6 +76,7 @@ let warn_deprecated_hint_constr = *) let soft_evaluable = let open GlobRef in + let open Tacred in function | ConstRef c -> EvalConstRef c | VarRef id -> EvalVarRef id diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8cb077ca21..a91771f22d 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -492,7 +492,7 @@ let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams ~binders:k c = end) sigma args | _ -> Termops.fold_constr_with_full_binders - sigma + env sigma (fun d (env,k) -> EConstr.push_rel d env, k+1) aux envk sigma c in @@ -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..c715304419 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 @@ -881,7 +883,7 @@ let shrink_body c ty = (* Saving an obligation *) (***********************************************************************) -let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] +let unfold_entry cst = Hints.HintsUnfoldEntry [Tacred.EvalConstRef cst] let add_hint local prg cst = let locality = if local then Goptions.OptLocal else Goptions.OptExport in @@ -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..91ab17575d 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,25 +74,57 @@ 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 input_univ_names (src, l) = + if CList.is_empty l then () + else Lib.add_anonymous_leaf (input_univ_names (src, l)) + +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)) + input_univ_names (QualifiedUniv l, univs) let do_universe ~poly l = let in_section = Global.sections_are_opened () in @@ -104,14 +138,13 @@ let do_universe ~poly l = Univ.LSet.empty l, Univ.Constraint.empty in let src = if poly then BoundUniv else UnqualifiedUniv in - let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + let () = input_univ_names (src, l) in DeclareUctx.declare_universe_context ~poly ctx 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..2fe402ff08 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) @@ -1779,15 +1793,9 @@ let remove_delimiters local scope = let add_class_scope local scope cl = Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeClasses cl)) -(* Check if abbreviation to a name and avoid early insertion of - maximal implicit arguments *) -let try_interp_name_alias = function - | [], { CAst.v = CRef (ref,_) } -> intern_reference ref - | _ -> raise Not_found - let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } = let acvars,pat,reversibility = - try Id.Map.empty, NRef (try_interp_name_alias (vars,c)), APrioriReversible + try Id.Map.empty, try_interp_name_alias (vars,c), APrioriReversible with Not_found -> let fold accu id = Id.Map.add id NtnInternTypeAny accu in let i_vars = List.fold_left fold Id.Map.empty vars in @@ -1798,7 +1806,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 +1816,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..79a0cdf8d1 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) @@ -947,7 +947,7 @@ let print_about_any ?loc env sigma k udecl = [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> let () = match Syntax_def.search_syntactic_definition kn with - | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref + | [],Notation_term.NRef (ref,_) -> Dumpglob.add_glob ?loc ref | _ -> () in v 0 ( print_syntactic_def env kn ++ fnl () ++ diff --git a/vernac/record.ml b/vernac/record.ml index 583164a524..96e4a47d2d 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -366,7 +366,7 @@ let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramde let ci = Inductiveops.make_case_info env indsp rci LetStyle in (* Record projections are always NoInvert because they're at constant relevance *) - mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None + mkCase (Inductive.contract_case env (ci, p, NoInvert, mkRel 1, [|branch|])), None in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in @@ -625,7 +625,7 @@ let build_class_constant ~univs ~rdata field implfs params paramimpls coers bind let cref = GlobRef.ConstRef cst in Impargs.declare_manual_implicits false cref paramimpls; Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd implfs); - Classes.set_typeclass_transparency (EvalConstRef cst) false false; + Classes.set_typeclass_transparency (Tacred.EvalConstRef cst) false false; let sub = List.hd coers in let m = { meth_name = Name proj_name; @@ -744,7 +744,7 @@ let add_constant_class env sigma cst = } in Classes.add_class env sigma tc; - Classes.set_typeclass_transparency (EvalConstRef cst) false false + Classes.set_typeclass_transparency (Tacred.EvalConstRef cst) false false let add_inductive_class env sigma ind = let mind, oneind = Inductive.lookup_mind_specif env ind in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 0f63dfe5ce..4f3fc46c12 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)) @@ -308,6 +309,17 @@ let print_registered () = in hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) +let dump_universes output g = + let open Univ in + let dump_arc u = function + | UGraph.Node ltle -> + Univ.LMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | UGraph.Alias v -> + output Eq u v + in + Univ.LMap.iter dump_arc g let dump_universes_gen prl g s = let output = open_out s in @@ -341,7 +353,7 @@ let dump_universes_gen prl g s = in let output_constraint k l r = output_constraint k (prl l) (prl r) in try - UGraph.dump_universes output_constraint g; + dump_universes output_constraint g; close (); str "Universes written to file \"" ++ str s ++ str "\"." with reraise -> @@ -353,9 +365,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 @@ -366,18 +378,71 @@ let universe_subgraph ?loc kept univ = let univ = LSet.fold add kept UGraph.initial_universes in UGraph.merge_constraints csts univ +let sort_universes g = + let open Univ in + let rec normalize u = match LMap.find u g with + | UGraph.Alias u -> normalize u + | UGraph.Node _ -> u + in + let get_next u = match LMap.find u g with + | UGraph.Alias u -> assert false (* nodes are normalized *) + | UGraph.Node ltle -> ltle + in + (* Compute the longest chain of Lt constraints from Set to any universe *) + let rec traverse accu todo = match todo with + | [] -> accu + | (u, n) :: todo -> + let () = assert (Level.equal (normalize u) u) in + let n = match LMap.find u accu with + | m -> if m < n then Some n else None + | exception Not_found -> Some n + in + match n with + | None -> traverse accu todo + | Some n -> + let accu = LMap.add u n accu in + let next = get_next u in + let fold v lt todo = + let v = normalize v in + if lt then (v, n + 1) :: todo else (v, n) :: todo + in + let todo = LMap.fold fold next todo in + traverse accu todo + in + (* Only contains normalized nodes *) + let levels = traverse LMap.empty [normalize Level.set, 0] in + let max_level = LMap.fold (fun _ n accu -> max n accu) levels 0 in + let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] in + let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp i))) in + let ulevels = Array.cons Level.set ulevels in + (* Add the normal universes *) + let fold (cur, ans) u = + let ans = LMap.add cur (UGraph.Node (LMap.singleton u true)) ans in + (u, ans) + in + let _, ans = Array.fold_left fold (Level.prop, LMap.empty) ulevels in + (* Add alias pointers *) + let fold u _ ans = + if Level.is_small u then ans + else + let n = LMap.find (normalize u) levels in + LMap.add u (UGraph.Alias ulevels.(n)) ans + in + LMap.fold fold g ans + let print_universes ?loc ~sort ~subgraph dst = let univ = Global.universes () in let univ = match subgraph with | None -> univ | Some g -> universe_subgraph ?loc g univ in - let univ = if sort then UGraph.sort_universes univ else univ in + let univ = UGraph.repr univ in + let univ = if sort then sort_universes univ else univ in let pr_remaining = 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 +577,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 +612,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 +673,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 +693,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 +706,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 +793,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 +814,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 +852,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 +890,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 +915,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 +939,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 +953,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 = @@ -1611,6 +1692,7 @@ let () = } let vernac_set_strategy ~local l = + let open Tacred in let local = Option.default false local in let glob_ref r = match smart_global r with @@ -1622,6 +1704,7 @@ let vernac_set_strategy ~local l = Redexpr.set_strategy local l let vernac_set_opacity ~local (v,l) = + let open Tacred in let local = Option.default true local in let glob_ref r = match smart_global r with @@ -1829,11 +1912,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 +1950,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 e5971e1aaa..3a8a80d25a 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -82,7 +82,7 @@ let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = match !default_timeout, timeout with | _, Some n | Some n, None -> - (match Control.timeout n f x with + (match Control.timeout (float_of_int n) f x with | None -> Exninfo.iraise (Exninfo.capture CErrors.Timeout) | Some x -> x) | None, None -> |