diff options
178 files changed, 2869 insertions, 2192 deletions
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000000..f5527192e0 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,91 @@ +name: GitHub CI + +on: [push, pull_request] + +jobs: + Windows: + runs-on: windows-latest + + steps: + - uses: actions/checkout@v2 + + - name: Set up Cygwin + uses: egor-tensin/setup-cygwin@v1 + with: + packages: rsync patch diffutils make unzip m4 findutils time wget curl git mingw64-x86_64-binutils mingw64-x86_64-gcc-core mingw64-x86_64-gcc-g++ mingw64-x86_64-pkg-config mingw64-x86_64-windows_default_manifest mingw64-x86_64-headers mingw64-x86_64-runtime mingw64-x86_64-pthreads mingw64-x86_64-zlib mingw64-x86_64-gmp python3 + + - name: Create home dir + run: | + C:\tools\cygwin\bin\bash.exe --login -c 'env' + + - name: Install opam + run: | + C:\tools\cygwin\bin\bash.exe dev\ci\azure-opam.sh + + - name: Build Coq + run: | + C:\tools\cygwin\bin\bash.exe dev\ci\azure-build.sh + + macOS: + runs-on: macOS-10.15 + + steps: + - uses: actions/checkout@v2 + + - name: Install system dependencies + run: | + brew install gnu-time opam gtksourceview3 adwaita-icon-theme + pip3 install macpack + + - name: Install OCaml dependencies + run: | + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER + opam switch set ocaml-base-compiler.$COMPILER + eval $(opam env) + opam update + opam install -j "$NJOBS" ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.10 + opam list + env: + COMPILER: "4.11.1" + FINDLIB_VER: ".1.8.1" + OPAMYES: "true" + MACOSX_DEPLOYMENT_TARGET: "10.11" + NJOBS: "2" + + - name: Build Coq + run: | + eval $(opam env) + ./configure -prefix "$(pwd)/_install_ci" -warn-error yes -native-compiler no -coqide opt + make -j "$NJOBS" byte + make -j "$NJOBS" + env: + MACOSX_DEPLOYMENT_TARGET: "10.11" + NJOBS: "2" + + - name: Run Coq Test Suite + run: | + eval $(opam env) + export OCAMLPATH=$(pwd):"$OCAMLPATH" + make -j "$NJOBS" test-suite PRINT_LOGS=1 + env: + NJOBS: "2" + + - name: Install Coq + run: | + make install + + - name: Create the dmg bundle + run: | + eval $(opam env) + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + export OUTDIR="$(pwd)/_install_ci" + ./dev/build/osx/make-macos-dmg.sh + env: + MACOSX_DEPLOYMENT_TARGET: "10.11" + NJOBS: "2" + + - uses: actions/upload-artifact@v2 + with: + name: coq-macOS-installer + path: _build/*.dmg diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 749b74d584..bf3ac7a727 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,8 +18,9 @@ stages: # some default values variables: # Format: $IMAGE-V$DATE-$hash - # The $hash is the first 10 characters of the md5 of the dockerfile - CACHEKEY: "bionic_coq-V2020-11-26-50e9456f22" + # 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" 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/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 9964a474f8..54bf0b6a4e 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -298,7 +298,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 11f225bdb6..0000000000 --- a/azure-pipelines.yml +++ /dev/null @@ -1,116 +0,0 @@ - -# NB: image names can be found at -# https://docs.microsoft.com/en-us/azure/devops/pipelines/agents/hosted - -variables: - NJOBS: "2" - -jobs: -- job: Windows - pool: - vmImage: 'vs2017-win2016' - - # Equivalent to allow_failure: true - # continueOnError: true - - steps: - - checkout: self - fetchDepth: 10 - - # cygwin package list not checked for minimality - - script: | - powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" - SET CYGROOT=C:\cygwin64 - SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib,mingw64-x86_64-gmp -P python3 - - SET TARGET_ARCH=x86_64-w64-mingw32 - SET CD_MFMT=%cd:\=/% - SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% - C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh - displayName: 'Install cygwin' - env: - CYGMIRROR: "http://mirror.cs.vt.edu/pub/cygwin/cygwin" - - - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh - displayName: 'Install opam' - - - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh - displayName: 'Build Coq' - - # We are hitting a bug where Dune is rebuilding Coq to run the - # test-suite, also it seems to time out, so we just build for now - # - # - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh - # displayName: 'Test Coq' - - - publish: _build/log - artifact: Dune Build Log - condition: always() - -- job: macOS - pool: - vmImage: 'macOS-10.14' - - variables: - MACOSX_DEPLOYMENT_TARGET: '10.11' - - steps: - - - checkout: self - fetchDepth: 10 - - - script: | - set -e - brew install gnu-time opam gtksourceview3 adwaita-icon-theme - pip3 install macpack - displayName: 'Install system dependencies' - - - script: | - set -e - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER - opam switch set ocaml-base-compiler.$COMPILER - eval $(opam env) - opam update - opam install -j "$NJOBS" ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.10 - opam list - displayName: 'Install OCaml dependencies' - env: - COMPILER: "4.11.1" - FINDLIB_VER: ".1.8.1" - OPAMYES: "true" - - - script: | - set -e - - eval $(opam env) - ./configure -prefix '$(Build.BinariesDirectory)' -warn-error yes -native-compiler no -coqide opt - make -j "$NJOBS" byte - make -j "$NJOBS" - displayName: 'Build Coq' - - - script: | - eval $(opam env) - export OCAMLPATH=$(pwd):"$OCAMLPATH" - make -j "$NJOBS" test-suite PRINT_LOGS=1 - displayName: 'Run Coq Test Suite' - - - script: | - make install - displayName: 'Install Coq' - - - script: | - set -e - eval $(opam env) - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - ./dev/build/osx/make-macos-dmg.sh - mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" - displayName: 'Create the dmg bundle' - env: - OUTDIR: '$(Build.BinariesDirectory)' - - - task: PublishBuildArtifacts@1 - inputs: - pathtoPublish: '$(Build.ArtifactStagingDirectory)' - artifactName: coq-macOS-installer diff --git a/clib/cList.ml b/clib/cList.ml index 6b13fac48c..d5520aa2b7 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -23,6 +23,7 @@ sig val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val prefix_of : 'a eq -> 'a list -> 'a list -> bool + val same_length : 'a list -> 'b list -> bool val interval : int -> int -> int list val make : int -> 'a -> 'a list val addn : int -> 'a -> 'a list -> 'a list @@ -154,6 +155,11 @@ external cast : 'a cell -> 'a list = "%identity" (** {6 Equality, testing} *) +let rec same_length l1 l2 = match l1, l2 with +| [], [] -> true +| _ :: l1, _ :: l2 -> same_length l1 l2 +| ([], _ :: _) | (_ :: _, []) -> false + let rec compare cmp l1 l2 = if l1 == l2 then 0 else match l1,l2 with diff --git a/clib/cList.mli b/clib/cList.mli index c8e471f989..6c8df88767 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -42,6 +42,9 @@ sig (** [prefix_of eq l1 l2] returns [true] if [l1] is a prefix of [l2], [false] otherwise. It uses [eq] to compare elements *) + val same_length : 'a list -> 'b list -> bool + (** A more efficient variant of [for_all2eq (fun _ _ -> true)] *) + (** {6 Creating lists} *) val interval : int -> int -> int list diff --git a/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/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/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index ebbf10f548..beed8bc443 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -949,7 +949,7 @@ function make_arch_pkg_config { ##### OCAML ##### function make_ocaml { - if build_prep https://github.com/ocaml/ocaml/archive 4.08.1 tar.gz 1 ocaml-4.08.1 ; then + if build_prep https://github.com/ocaml/ocaml/archive 4.10.2 tar.gz 1 ocaml-4.10.2 ; then # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc # get flexdll sources into folder ./flexdll @@ -1047,8 +1047,7 @@ function make_ocamlbuild { 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 + if build_prep http://download.camlcity.org/download/ findlib-1.8.1 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 @@ -1153,7 +1152,7 @@ function make_lablgtk { 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 + if build_prep https://github.com/garrigue/lablgtk/archive 3.1.1 tar.gz 1 lablgtk-3.1.1 ; then make_arch_pkg_config # lablgtk3 includes more packages that are not relevant for Coq, @@ -1436,12 +1435,12 @@ function make_coq { # make clean # Copy these files somewhere the plugin builds can find them - logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ + #logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ build_post fi - load_overlay_data + #load_overlay_data } ##### GNU Make for MinGW ##### 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 18fdd83218..97d9537508 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -1,54 +1,71 @@ #!/usr/bin/env bash -# This is the basic overlay set for repositories in the CI. - -# Maybe we should just use Ruby to have real objects... - -# : "${foo:=bar}" sets foo to "bar" if it is unset or null +# This is the list of repositories used by the CI scripts, unless overridden +# by a call to the "overlay" function in ci-common + +declare -a projects # the list of project repos that can be be overlayed + +# checks if the given argument is a known project +function is_in_projects { + for x in "${projects[@]}"; do + if [ "$1" = "$x" ]; then return 0; fi; + done + return 1 +} + +# project <name> <giturl> <ref> [<archiveurl>] +# [<archiveurl>] defaults to <giturl>/archive on github.com +# and <giturl>/-/archive on gitlab +function project { + + local var_ref=${1}_CI_REF + local var_giturl=${1}_CI_GITURL + local var_archiveurl=${1}_CI_ARCHIVEURL + local giturl=$2 + local ref=$3 + local archiveurl=$4 + case $giturl in + *github.com*) archiveurl=${archiveurl:-$giturl/archive} ;; + *gitlab*) archiveurl=${archiveurl:-$giturl/-/archive} ;; + esac + + # register the project in the list of projects + projects[${#projects[*]}]=$1 + + # bash idiom for setting a variable if not already set + : "${!var_ref:=$ref}" + : "${!var_giturl:=$giturl}" + : "${!var_archiveurl:=$archiveurl}" + +} ######################################################################## # MathComp ######################################################################## -: "${mathcomp_CI_REF:=master}" -: "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp}" -: "${mathcomp_CI_ARCHIVEURL:=${mathcomp_CI_GITURL}/archive}" +project mathcomp "https://github.com/math-comp/math-comp" "master" -: "${fourcolor_CI_REF:=master}" -: "${fourcolor_CI_GITURL:=https://github.com/math-comp/fourcolor}" -: "${fourcolor_CI_ARCHIVEURL:=${fourcolor_CI_GITURL}/archive}" +project fourcolor "https://github.com/math-comp/fourcolor" "master" -: "${oddorder_CI_REF:=master}" -: "${oddorder_CI_GITURL:=https://github.com/math-comp/odd-order}" -: "${oddorder_CI_ARCHIVEURL:=${oddorder_CI_GITURL}/archive}" +project oddorder "https://github.com/math-comp/odd-order" "master" ######################################################################## # UniMath ######################################################################## -: "${unimath_CI_REF:=master}" -: "${unimath_CI_GITURL:=https://github.com/UniMath/UniMath}" -: "${unimath_CI_ARCHIVEURL:=${unimath_CI_GITURL}/archive}" +project unimath "https://github.com/UniMath/UniMath" "master" ######################################################################## # Unicoq + Mtac2 ######################################################################## -: "${unicoq_CI_REF:=master}" -: "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq}" -: "${unicoq_CI_ARCHIVEURL:=${unicoq_CI_GITURL}/archive}" +project unicoq "https://github.com/unicoq/unicoq" "master" -: "${mtac2_CI_REF:=master}" -: "${mtac2_CI_GITURL:=https://github.com/Mtac2/Mtac2}" -: "${mtac2_CI_ARCHIVEURL:=${mtac2_CI_GITURL}/archive}" +project mtac2 "https://github.com/Mtac2/Mtac2" "master" ######################################################################## # Mathclasses + Corn ######################################################################## -: "${math_classes_CI_REF:=master}" -: "${math_classes_CI_GITURL:=https://github.com/coq-community/math-classes}" -: "${math_classes_CI_ARCHIVEURL:=${math_classes_CI_GITURL}/archive}" +project math_classes "https://github.com/coq-community/math-classes" "master" -: "${corn_CI_REF:=master}" -: "${corn_CI_GITURL:=https://github.com/coq-community/corn}" -: "${corn_CI_ARCHIVEURL:=${corn_CI_GITURL}/archive}" +project corn "https://github.com/coq-community/corn" "master" ######################################################################## # Iris @@ -56,342 +73,238 @@ # NB: stdpp and Iris refs are gotten from the opam files in the Iris # and lambdaRust repos respectively. -: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" -: "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" +project stdpp "https://gitlab.mpi-sws.org/iris/stdpp" "" -: "${iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" -: "${iris_CI_ARCHIVEURL:=${iris_CI_GITURL}/-/archive}" +project iris "https://gitlab.mpi-sws.org/iris/iris" "" -: "${autosubst_CI_REF:=coq86-devel}" -: "${autosubst_CI_GITURL:=https://github.com/RalfJung/autosubst}" -: "${autosubst_CI_ARCHIVEURL:=${autosubst_CI_GITURL}/archive}" +project autosubst "https://github.com/coq-community/autosubst" "master" -: "${iris_string_ident_CI_REF:=master}" -: "${iris_string_ident_CI_GITURL:=https://gitlab.mpi-sws.org/iris/string-ident}" -: "${iris_string_ident_CI_ARCHIVEURL:=${iris_string_ident_CI_GITURL}/-/archive}" +project iris_string_ident "https://gitlab.mpi-sws.org/iris/string-ident" "master" -: "${iris_examples_CI_REF:=master}" -: "${iris_examples_CI_GITURL:=https://gitlab.mpi-sws.org/iris/examples}" -: "${iris_examples_CI_ARCHIVEURL:=${iris_examples_CI_GITURL}/-/archive}" +project iris_examples "https://gitlab.mpi-sws.org/iris/examples" "master" ######################################################################## # HoTT ######################################################################## -: "${hott_CI_REF:=master}" -: "${hott_CI_GITURL:=https://github.com/HoTT/HoTT}" -: "${hott_CI_ARCHIVEURL:=${hott_CI_GITURL}/archive}" +project hott "https://github.com/HoTT/HoTT" "master" ######################################################################## # CoqHammer ######################################################################## -: "${coqhammer_CI_REF:=master}" -: "${coqhammer_CI_GITURL:=https://github.com/lukaszcz/coqhammer}" -: "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" +project coqhammer "https://github.com/lukaszcz/coqhammer" "master" ######################################################################## # GeoCoq ######################################################################## -: "${geocoq_CI_REF:=master}" -: "${geocoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" -: "${geocoq_CI_ARCHIVEURL:=${geocoq_CI_GITURL}/archive}" +project geocoq "https://github.com/GeoCoq/GeoCoq" "master" ######################################################################## # Flocq ######################################################################## -: "${flocq_CI_REF:=master}" -: "${flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" -: "${flocq_CI_ARCHIVEURL:=${flocq_CI_GITURL}/-/archive}" +project flocq "https://gitlab.inria.fr/flocq/flocq" "master" ######################################################################## # coq-performance-tests ######################################################################## -: "${coq_performance_tests_CI_REF:=master}" -: "${coq_performance_tests_CI_GITURL:=https://github.com/coq-community/coq-performance-tests}" -: "${coq_performance_tests_CI_ARCHIVEURL:=${coq_performance_tests_CI_GITURL}/archive}" +project coq_performance_tests "https://github.com/coq-community/coq-performance-tests" "master" ######################################################################## # coq-tools ######################################################################## -: "${coq_tools_CI_REF:=master}" -: "${coq_tools_CI_GITURL:=https://github.com/JasonGross/coq-tools}" -: "${coq_tools_CI_ARCHIVEURL:=${coq_tools_CI_GITURL}/archive}" +project coq_tools "https://github.com/JasonGross/coq-tools" "master" ######################################################################## # Coquelicot ######################################################################## -: "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" -: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" +project coquelicot "https://gitlab.inria.fr/coquelicot/coquelicot" "master" ######################################################################## # Coq-interval ######################################################################## -: "${interval_CI_REF:=master}" -: "${interval_CI_GITURL:=https://gitlab.inria.fr/coqinterval/interval}" -: "${interval_CI_ARCHIVEURL:=${interval_CI_GITURL}/-/archive}" +project interval "https://gitlab.inria.fr/coqinterval/interval" "master" ######################################################################## # Gappa stand alone tool ######################################################################## -: "${gappa_tool_CI_REF:=master}" -: "${gappa_tool_CI_GITURL:=https://gitlab.inria.fr/gappa/gappa}" -: "${gappa_tool_CI_ARCHIVEURL:=${gappa_tool_CI_GITURL}/-/archive}" +project gappa_tool "https://gitlab.inria.fr/gappa/gappa" "master" ######################################################################## # Gappa plugin ######################################################################## -: "${gappa_plugin_CI_REF:=master}" -: "${gappa_plugin_CI_GITURL:=https://gitlab.inria.fr/gappa/coq}" -: "${gappa_plugin_CI_ARCHIVEURL:=${gappa_plugin_CI_GITURL}/-/archive}" +project gappa "https://gitlab.inria.fr/gappa/coq" "master" ######################################################################## # CompCert ######################################################################## -: "${compcert_CI_REF:=master}" -: "${compcert_CI_GITURL:=https://github.com/AbsInt/CompCert}" -: "${compcert_CI_ARCHIVEURL:=${compcert_CI_GITURL}/archive}" +project compcert "https://github.com/AbsInt/CompCert" "master" ######################################################################## # VST ######################################################################## -: "${vst_CI_REF:=master}" -: "${vst_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" -: "${vst_CI_ARCHIVEURL:=${vst_CI_GITURL}/archive}" +project vst "https://github.com/PrincetonUniversity/VST" "master" ######################################################################## # cross-crypto ######################################################################## -: "${cross_crypto_CI_REF:=master}" -: "${cross_crypto_CI_GITURL:=https://github.com/mit-plv/cross-crypto}" -: "${cross_crypto_CI_ARCHIVEURL:=${cross_crypto_CI_GITURL}/archive}" +project cross_crypto "https://github.com/mit-plv/cross-crypto" "master" ######################################################################## # rewriter ######################################################################## -: "${rewriter_CI_REF:=master}" -: "${rewriter_CI_GITURL:=https://github.com/mit-plv/rewriter}" -: "${rewriter_CI_ARCHIVEURL:=${rewriter_CI_GITURL}/archive}" +project rewriter "https://github.com/mit-plv/rewriter" "master" ######################################################################## # fiat_parsers ######################################################################## -: "${fiat_parsers_CI_REF:=master}" -: "${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat}" -: "${fiat_parsers_CI_ARCHIVEURL:=${fiat_parsers_CI_GITURL}/archive}" +project fiat_parsers "https://github.com/mit-plv/fiat" "master" ######################################################################## # fiat_crypto ######################################################################## -: "${fiat_crypto_CI_REF:=master}" -: "${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" -: "${fiat_crypto_CI_ARCHIVEURL:=${fiat_crypto_CI_GITURL}/archive}" +project fiat_crypto "https://github.com/mit-plv/fiat-crypto" "master" ######################################################################## # fiat_crypto_legacy ######################################################################## -: "${fiat_crypto_legacy_CI_REF:=sp2019latest}" -: "${fiat_crypto_legacy_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" -: "${fiat_crypto_legacy_CI_ARCHIVEURL:=${fiat_crypto_legacy_CI_GITURL}/archive}" +project fiat_crypto_legacy "https://github.com/mit-plv/fiat-crypto" "sp2019latest" ######################################################################## # coq_dpdgraph ######################################################################## -: "${coq_dpdgraph_CI_REF:=coq-master}" -: "${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph}" -: "${coq_dpdgraph_CI_ARCHIVEURL:=${coq_dpdgraph_CI_GITURL}/archive}" +project coq_dpdgraph "https://github.com/Karmaki/coq-dpdgraph" "coq-master" ######################################################################## # CoLoR ######################################################################## -: "${color_CI_REF:=master}" -: "${color_CI_GITURL:=https://github.com/fblanqui/color}" -: "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}" +project color "https://github.com/fblanqui/color" "master" ######################################################################## # TLC ######################################################################## -: "${tlc_CI_REF:=master-for-coq-ci}" -: "${tlc_CI_GITURL:=https://github.com/charguer/tlc}" -: "${tlc_CI_ARCHIVEURL:=${tlc_CI_GITURL}/archive}" +project tlc "https://github.com/charguer/tlc" "master-for-coq-ci" ######################################################################## # Bignums ######################################################################## -: "${bignums_CI_REF:=master}" -: "${bignums_CI_GITURL:=https://github.com/coq/bignums}" -: "${bignums_CI_ARCHIVEURL:=${bignums_CI_GITURL}/archive}" +project bignums "https://github.com/coq/bignums" "master" ######################################################################## # coqprime ######################################################################## -: "${coqprime_CI_REF:=master}" -: "${coqprime_CI_GITURL:=https://github.com/thery/coqprime}" -: "${coqprime_CI_ARCHIVEURL:=${coqprime_CI_GITURL}/archive}" +project coqprime "https://github.com/thery/coqprime" "master" ######################################################################## # bbv ######################################################################## -: "${bbv_CI_REF:=master}" -: "${bbv_CI_GITURL:=https://github.com/mit-plv/bbv}" -: "${bbv_CI_ARCHIVEURL:=${bbv_CI_GITURL}/archive}" +project bbv "https://github.com/mit-plv/bbv" "master" ######################################################################## # bedrock2 ######################################################################## -: "${bedrock2_CI_REF:=tested}" -: "${bedrock2_CI_GITURL:=https://github.com/mit-plv/bedrock2}" -: "${bedrock2_CI_ARCHIVEURL:=${bedrock2_CI_GITURL}/archive}" +project bedrock2 "https://github.com/mit-plv/bedrock2" "tested" ######################################################################## # Equations ######################################################################## -: "${equations_CI_REF:=master}" -: "${equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" -: "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}" +project equations "https://github.com/mattam82/Coq-Equations" "master" ######################################################################## # Elpi + Hierarchy Builder ######################################################################## -: "${elpi_CI_REF:=coq-master}" -: "${elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" -: "${elpi_CI_ARCHIVEURL:=${elpi_CI_GITURL}/archive}" +project elpi "https://github.com/LPCIC/coq-elpi" "coq-master" -: "${elpi_hb_CI_REF:=coq-master}" -: "${elpi_hb_CI_GITURL:=https://github.com/math-comp/hierarchy-builder}" -: "${elpi_hb_CI_ARCHIVEURL:=${elpi_hb_CI_GITURL}/archive}" +project hierarchy_builder "https://github.com/math-comp/hierarchy-builder" "coq-master" ######################################################################## # Engine-Bench ######################################################################## -: "${engine_bench_CI_REF:=master}" -: "${engine_bench_CI_GITURL:=https://github.com/mit-plv/engine-bench}" -: "${engine_bench_CI_ARCHIVEURL:=${engine_bench_CI_GITURL}/archive}" +project engine_bench "https://github.com/mit-plv/engine-bench" "master" ######################################################################## # fcsl-pcm ######################################################################## -: "${fcsl_pcm_CI_REF:=master}" -: "${fcsl_pcm_CI_GITURL:=https://github.com/imdea-software/fcsl-pcm}" -: "${fcsl_pcm_CI_ARCHIVEURL:=${fcsl_pcm_CI_GITURL}/archive}" +project fcsl_pcm "https://github.com/imdea-software/fcsl-pcm" "master" ######################################################################## # ext-lib ######################################################################## -: "${ext_lib_CI_REF:=master}" -: "${ext_lib_CI_GITURL:=https://github.com/coq-community/coq-ext-lib}" -: "${ext_lib_CI_ARCHIVEURL:=${ext_lib_CI_GITURL}/archive}" +project ext_lib "https://github.com/coq-community/coq-ext-lib" "master" ######################################################################## # simple-io ######################################################################## -: "${simple_io_CI_REF:=master}" -: "${simple_io_CI_GITURL:=https://github.com/Lysxia/coq-simple-io}" -: "${simple_io_CI_ARCHIVEURL:=${simple_io_CI_GITURL}/archive}" +project simple_io "https://github.com/Lysxia/coq-simple-io" "master" ######################################################################## # quickchick ######################################################################## -: "${quickchick_CI_REF:=master}" -: "${quickchick_CI_GITURL:=https://github.com/QuickChick/QuickChick}" -: "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" +project quickchick "https://github.com/QuickChick/QuickChick" "master" ######################################################################## # reduction-effects ######################################################################## -: "${reduction_effects_CI_REF:=master}" -: "${reduction_effects_CI_GITURL:=https://github.com/coq-community/reduction-effects}" -: "${reduction_effects_CI_ARCHIVEURL:=${reduction_effects_CI_GITURL}/archive}" +project reduction_effects "https://github.com/coq-community/reduction-effects" "master" ######################################################################## # menhirlib ######################################################################## # Note: menhirlib is now in subfolder coq-menhirlib of menhir -: "${menhirlib_CI_REF:=20201122}" -: "${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 1a4ebc0e90..8d8f78e10c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -49,24 +49,38 @@ 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-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-gappa.sh b/dev/ci/ci-gappa.sh index c346354b70..1af37aa7c1 100755 --- a/dev/ci/ci-gappa.sh +++ b/dev/ci/ci-gappa.sh @@ -7,6 +7,6 @@ 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_plugin +git_download gappa -( cd "${CI_BUILD_DIR}/gappa_plugin" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) +( cd "${CI_BUILD_DIR}/gappa" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake 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 1aefebb007..b4b6411d28 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -71,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/user-overlays/12218-proux01-numeral-notations-non-inductive.sh b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh deleted file mode 100644 index d9b49ad0d1..0000000000 --- a/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12218" ] || [ "$CI_BRANCH" = "numeral-notations-non-inductive" ]; then - - stdlib2_CI_REF=numeral-notations-non-inductive - stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 - - hott_CI_REF=numeral-notations-non-inductive - hott_CI_GITURL=https://github.com/proux01/HoTT - - paramcoq_CI_REF=numeral-notations-non-inductive - paramcoq_CI_GITURL=https://github.com/proux01/paramcoq - - quickchick_CI_REF=numeral-notations-non-inductive - quickchick_CI_GITURL=https://github.com/proux01/QuickChick - - metacoq_CI_REF=numeral-notations-non-inductive - metacoq_CI_GITURL=https://github.com/proux01/metacoq - -fi diff --git a/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh b/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh deleted file mode 100644 index fb5947d218..0000000000 --- a/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12449" ] || [ "$CI_BRANCH" = "minim-prop-toset" ]; then - - mtac2_CI_REF=janno/coq-12449 - mtac2_CI_GITURL=https://github.com/mtac2/mtac2 - -fi diff --git a/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh b/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh deleted file mode 100644 index b7d21ed59c..0000000000 --- a/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12611" ] || [ "$CI_BRANCH" = "record+refactor" ]; then - - elpi_CI_REF=record+refactor - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -# mtac2_CI_REF=record+refactor -# mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - -fi diff --git a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh deleted file mode 100644 index 1473f6df8b..0000000000 --- a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12653" ] || [ "$CI_BRANCH" = "cumul-syntax" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi cumul-syntax - - overlay equations https://github.com/SkySkimmer/Coq-Equations cumul-syntax - - overlay mtac2 https://github.com/SkySkimmer/Mtac2 cumul-syntax - - overlay paramcoq https://github.com/SkySkimmer/paramcoq cumul-syntax - - overlay rewriter https://github.com/SkySkimmer/rewriter cumul-syntax - - overlay metacoq https://github.com/SkySkimmer/metacoq cumul-syntax - -fi diff --git a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh deleted file mode 100644 index 7680e8da78..0000000000 --- a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12873" ] || [ "$CI_BRANCH" = "master+minifix-unification-error-reporting-recheck-applications" ]; then - - equations_CI_REF=master+fix12873-better-unification - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh deleted file mode 100644 index 8b223719ea..0000000000 --- a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13075" ] || [ "$CI_BRANCH" = "explicit-names-quotient" ]; then - - elpi_CI_REF=explicit-names-quotient - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - coq_dpdgraph_CI_REF=explicit-names-quotient - coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph - -fi diff --git a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh deleted file mode 100644 index f16cf1497e..0000000000 --- a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance - -fi diff --git a/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh b/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh deleted file mode 100644 index 2f70f43a2b..0000000000 --- a/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13139" ] || [ "$CI_BRANCH" = "clean-hint-constr" ]; then - - equations_CI_REF=clean-hint-constr - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - fiat_parsers_CI_REF=clean-hint-constr - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat - -fi diff --git a/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh b/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh deleted file mode 100644 index 7d55cf6883..0000000000 --- a/dev/ci/user-overlays/13166-herbelin-master+fixes13165-missing-impargs-defined-fields.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13166" ] || [ "$CI_BRANCH" = "master+fixes13165-missing-impargs-defined-fields" ]; then - - elpi_CI_REF=coq-master+adapt-coq-pr13166-impargs-record-fields - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh b/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh deleted file mode 100644 index 3bdbcf7d6e..0000000000 --- a/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13312" ] || [ "$CI_BRANCH" = "attributes+bool_single" ]; then - - overlay unicoq https://github.com/ejgallego/unicoq attributes+bool_single - overlay elpi https://github.com/ejgallego/coq-elpi attributes+bool_single - -fi diff --git a/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh deleted file mode 100644 index 95f0de2bd3..0000000000 --- a/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13386" ] || [ "$CI_BRANCH" = "master+fix9971-primproj-canonical-structure-on-evar-type" ]; then - - unicoq_CI_REF=master+adapting-coq-pr13386 - unicoq_CI_GITURL=https://github.com/herbelin/unicoq - - elpi_CI_REF=coq-master+adapting-coq-pr13386 - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/13415-SkySkimmer-intern-univs.sh b/dev/ci/user-overlays/13415-SkySkimmer-intern-univs.sh deleted file mode 100644 index 0bf806085e..0000000000 --- a/dev/ci/user-overlays/13415-SkySkimmer-intern-univs.sh +++ /dev/null @@ -1,8 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13415" ] || [ "$CI_BRANCH" = "intern-univs" ]; then - - overlay equations https://github.com/SkySkimmer/Coq-Equations intern-univs - - overlay paramcoq https://github.com/SkySkimmer/paramcoq intern-univs - - overlay elpi https://github.com/SkySkimmer/coq-elpi intern-univs -fi diff --git a/dev/ci/user-overlays/13481-elpi-1.12.sh b/dev/ci/user-overlays/13481-elpi-1.12.sh deleted file mode 100644 index a6be2e3a1a..0000000000 --- a/dev/ci/user-overlays/13481-elpi-1.12.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13481" ] || [ "$CI_BRANCH" = "elpi-1.12" ]; then - - elpi_CI_REF=coq-master+elpi.1.12 - elpi_hb_CI_REF=coq-master+coq-elpi-1.7.0+elpi-1.12 - -fi diff --git a/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh b/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh new file mode 100644 index 0000000000..aa686ea619 --- /dev/null +++ b/dev/ci/user-overlays/13537-ppedrot-lazy-subst-kernel.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "13537" ] || [ "$CI_BRANCH" = "lazy-subst-kernel" ]; then + + overlay mtac2 https://github.com/ppedrot/Mtac2 lazy-subst-kernel + +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 3f9ad5e878..cf1d71c1cd 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -5,30 +5,29 @@ have prepared a branch with the fix, you can add an "overlay" to your pull request to test it with the adapted version of the external project. An overlay is a file which defines where to look for the patched -version so that testing is possible. This is done by calling the -`overlay` command for each project with the project name (as used in -the variables in [`ci-basic-overlay.sh`](../ci-basic-overlay.sh)), the -location of your fork and the branch containing the patch on your -fork. - -Moreover, the file contains very simple logic to test the pull request number -or branch name and apply it only in this case. - +version so that testing is possible. The name of your overlay file should start with a five-digit pull request number, followed by a dash, anything (for instance your GitHub nickname and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). -Example: `13128-SkySkimmer-noinstance.sh` containing - +This file must contain one or more invocation of the `overlay` function: ``` -if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - - overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance +overlay <project> <giturl> <ref> <prnumber> [<prbranch>] +``` +Each call creates an overlay for `project` using a given `giturl` and +`ref` which is active for `prnumber` or `prbranch` (`prbranch` defaults +to `ref`). -fi +Example of an overlay for the project `elpi` that uses the branch `noinstance` +from the fork of `SkySkimmer` and is active for pull request `13128` +``` +overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance 13128 ``` -(`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](../ci-common.sh)) +Such a file can be created automatically using the scripts +[`create_overlays.sh`](../../dev/tools/create_overlays.sh). +See also the list of projects for which one can write an overlay in +the file [`ci-basic-overlay.sh`](../ci-basic-overlay.sh). ### Branching conventions diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 5adeafaa38..26c4b01c9f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -37,6 +37,11 @@ Dumpglob: plugins to temporarily change/pause the output of Dumpglob, and then restore it to the original setting. +Glob_term: + +- Removing useless `binding_kind` argument of `GLocalDef` in + `extended_glob_local_binder`. + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index e0271d8c62..19562b60a2 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -140,16 +140,16 @@ 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 ## @@ -171,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/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 index 37fe0cbcbf..ebf920b0f7 100755 --- a/dev/tools/notify-upstream-pins.sh +++ b/dev/tools/notify-upstream-pins.sh @@ -14,24 +14,6 @@ REASON="bundled in the Windows installer" 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 -# caveats: -# - dev/ci/gitlab.bat has \r (windows) -# - aactactics, gappa, HB, extlib have different names in ci -# - menhir is not pinned but figures as an addon -# - unicoq is not an addon -WINDOWS_ADDONS=$(grep addon= dev/ci/gitlab.bat \ - | cut -d = -f 2 \ - | cut -d ' ' -f 1 \ - | tr -d '\r' \ - | sed -e 's/^aactactics$/aac_tactics/' \ - -e 's/^gappa$/gappa_plugin/' \ - -e 's/^HB$/elpi_hb/' \ - -e 's/^extlib$/ext_lib/' \ - \ - -e '/^menhir$/d' \ - ) \ -WINDOWS_ADDONS="$WINDOWS_ADDONS unicoq" - # reads a variable value from a ci-basic-overlay.sh file function read_from() { ( . $1; varname="$2"; echo ${!varname} ) @@ -99,7 +81,10 @@ $CC esac } -for addon in $WINDOWS_ADDONS; do +# 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"` 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/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/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/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/07-commands-and-options/00000-title.rst b/doc/changelog/07-vernac-commands-and-options/00000-title.rst index fe50ae0e16..fe50ae0e16 100644 --- a/doc/changelog/07-commands-and-options/00000-title.rst +++ b/doc/changelog/07-vernac-commands-and-options/00000-title.rst diff --git a/doc/changelog/07-vernac-commands-and-options/13556-master.rst b/doc/changelog/07-vernac-commands-and-options/13556-master.rst new file mode 100644 index 0000000000..05a60026a3 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13556-master.rst @@ -0,0 +1,4 @@ +- **Changed:** + The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). + (`#13556 <https://github.com/coq/coq/pull/13556>`_, + by Simon Friis Vindum). diff --git a/doc/changelog/08-cli-tools/00000-title.rst b/doc/changelog/08-cli-tools/00000-title.rst new file mode 100644 index 0000000000..4c0de43f66 --- /dev/null +++ b/doc/changelog/08-cli-tools/00000-title.rst @@ -0,0 +1,4 @@ + +Command-line tools +^^^^^^^^^^^^^^^^^^ + diff --git a/doc/changelog/08-tools/00000-title.rst b/doc/changelog/08-tools/00000-title.rst deleted file mode 100644 index 581585a8a7..0000000000 --- a/doc/changelog/08-tools/00000-title.rst +++ /dev/null @@ -1,4 +0,0 @@ - -Tools -^^^^^ - 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/sphinx/changes.rst b/doc/sphinx/changes.rst index 8fb03879e8..fcb150e3da 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -370,7 +370,8 @@ Notations 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` + 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:** @@ -2017,6 +2018,25 @@ Changes in 8.12.1 fixes `#12332 <https://github.com/coq/coq/issues/12332>`_, by Théo Zimmermann and Jim Fehrle). +Changes in 8.12.2 +~~~~~~~~~~~~~~~~~ + +**Notations** + +- **Fixed:** + 8.12 regression causing notations mentioning a coercion to be ignored + (`#13436 <https://github.com/coq/coq/pull/13436>`_, + fixes `#13432 <https://github.com/coq/coq/issues/13432>`_, + by Hugo Herbelin). + +**Tactics** + +- **Fixed:** + 8.12 regression: incomplete inference of implicit arguments in :tacn:`exists` + (`#13468 <https://github.com/coq/coq/pull/13468>`_, + fixes `#13456 <https://github.com/coq/coq/issues/13456>`_, + by Hugo Herbelin). + Version 8.11 ------------ diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 246568d3c1..bce88cebde 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -220,7 +220,7 @@ html_context = { ("dev", "https://coq.github.io/doc/master/refman/"), ("stable", "https://coq.inria.fr/distrib/current/refman/"), ("v8.13", "https://coq.github.io/doc/v8.13/refman/"), - ("8.12", "https://coq.inria.fr/distrib/V8.12.1/refman/"), + ("8.12", "https://coq.inria.fr/distrib/V8.12.2/refman/"), ("8.11", "https://coq.inria.fr/distrib/V8.11.2/refman/"), ("8.10", "https://coq.inria.fr/distrib/V8.10.2/refman/"), ("8.9", "https://coq.inria.fr/distrib/V8.9.1/refman/"), diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 8f5c045929..b2ebd96607 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -264,17 +264,6 @@ These patterns can be used when the hypothesis is an equality: :n:`@simple_intropattern_closed`. :ref:`Example <intropattern_injection_ex>` -.. flag:: Bracketing Last Introduction Pattern - - For :n:`intros @intropattern_list`, controls how to handle a - conjunctive pattern that doesn't give enough simple patterns to match - all the arguments in the constructor. If set (the default), Coq generates - additional names to match the number of arguments. - Unsetting the flag will put the additional hypotheses in the goal instead, behavior that is more - similar to |SSR|'s intro patterns. - - .. deprecated:: 8.10 - .. _intropattern_cons_note: .. note:: @@ -1641,17 +1630,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 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/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index d271145af8..90404b7321 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -525,7 +525,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 4dbf3b150b..f454f4313d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -309,7 +309,7 @@ at the time of use of the notation. a notation should only be used for printing. If a notation to be used both for parsing and printing is - overriden, both the parsing and printing are invalided, even if the + overridden, both the parsing and printing are invalided, even if the overriding rule is only parsing. If a given notation string occurs only in ``only printing`` rules, @@ -857,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 @@ -1740,7 +1741,8 @@ Number notations Note that only fully-reduced ground terms (terms containing only function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + sorts, primitive integers, primitive floats, primitive arrays and type + constants for primitive types) will be considered for printing. .. _number-string-via: @@ -1904,7 +1906,8 @@ String notations Note that only fully-reduced ground terms (terms containing only function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + sorts, primitive integers, primitive floats, primitive arrays and type + constants for primitive types) will be considered for printing. :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` works as for :ref:`number notations above <number-string-via>`. diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 56464851ba..35243b5d7d 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): @@ -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/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/evd.ml b/engine/evd.ml index 59eea97ce9..706e51d4b3 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -983,6 +983,9 @@ let fresh_inductive_instance ?loc ?(rigid=univ_flexible) env evd i = let fresh_constructor_instance ?loc ?(rigid=univ_flexible) env evd c = with_context_set ?loc rigid evd (UnivGen.fresh_constructor_instance env c) +let fresh_array_instance ?loc ?(rigid=univ_flexible) env evd = + with_context_set ?loc rigid evd (UnivGen.fresh_array_instance env) + let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = with_context_set ?loc rigid evd (UnivGen.fresh_global_instance ?loc ?names env gr) diff --git a/engine/evd.mli b/engine/evd.mli index 911e00c23a..a6d55c2615 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -698,6 +698,8 @@ val fresh_inductive_instance : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> inductive -> evar_map * pinductive val fresh_constructor_instance : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_array_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> evar_map * Univ.Instance.t val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> GlobRef.t -> evar_map * econstr diff --git a/engine/proofview.ml b/engine/proofview.ml index 22863f451d..b3061eaa81 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -909,10 +909,11 @@ let tclPROGRESS t = in let test = quick_test || + (CList.same_length initial.comb final.comb && Util.List.for_all2eq begin fun i f -> Progress.goal_equal ~evd:initial.solution ~extended_evd:final.solution (drop_state i) (drop_state f) - end initial.comb final.comb + end initial.comb final.comb) in if not test then tclUNIT res 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/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..01dfed0067 100644 --- a/ide/coqide/wg_ProofView.ml +++ b/ide/coqide/wg_ProofView.ml @@ -70,7 +70,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat 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 @@ -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/constrextern.ml b/interp/constrextern.ml index 3969c7ea1f..f3ba884856 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -886,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) @@ -1217,7 +1218,7 @@ 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 (on_fst (Name.fold_right Id.Set.add na) vars) l in (assums,na::ids, diff --git a/interp/constrintern.ml b/interp/constrintern.ml index cf2f333596..70a4ea35e9 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -90,18 +90,6 @@ let for_grammar f x = a (**********************************************************************) -(* Locating reference, possibly via an abbreviation *) - -let locate_reference qid = - Smartlocate.global_of_extended_global (Nametab.locate_extended qid) - -let is_global id = - try - let _ = locate_reference (qualid_of_ident id) in true - with Not_found -> - false - -(**********************************************************************) (* Internalization errors *) type internalization_error = @@ -112,8 +100,7 @@ type internalization_error = | NonLinearPattern of Id.t | BadPatternsNumber of int * int | NotAProjection of qualid - | NotAProjectionOf of qualid * qualid - | ProjectionsOfDifferentRecords of qualid * qualid + | ProjectionsOfDifferentRecords of Recordops.struc_typ * Recordops.struc_typ exception InternalizationError of internalization_error @@ -139,13 +126,16 @@ let explain_bad_patterns_number n1 n2 = str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++ str " but found " ++ int n2 +let inductive_of_record record = + let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in + Nametab.shortest_qualid_of_global Id.Set.empty inductive + let explain_field_not_a_projection field_id = pr_qualid field_id ++ str ": Not a projection" -let explain_field_not_a_projection_of field_id inductive_id = - pr_qualid field_id ++ str ": Not a projection of inductive " ++ pr_qualid inductive_id - -let explain_projections_of_diff_records inductive1_id inductive2_id = +let explain_projections_of_diff_records record1 record2 = + let inductive1_id = inductive_of_record record1 in + let inductive2_id = inductive_of_record record2 in str "This record contains fields of both " ++ pr_qualid inductive1_id ++ str " and " ++ pr_qualid inductive2_id @@ -158,8 +148,6 @@ let explain_internalization_error e = | NonLinearPattern id -> explain_non_linear_pattern id | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 | NotAProjection field_id -> explain_field_not_a_projection field_id - | NotAProjectionOf (field_id, inductive_id) -> - explain_field_not_a_projection_of field_id inductive_id | ProjectionsOfDifferentRecords (inductive1_id, inductive2_id) -> explain_projections_of_diff_records inductive1_id inductive2_id in pp ++ str "." @@ -277,9 +265,9 @@ type pattern_intern_env = { (* Remembering the parsing scope of variables in notations *) let make_current_scope tmp scopes = match tmp, scopes with -| Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes -| Some tmp_scope, scopes -> tmp_scope :: scopes -| None, scopes -> scopes + | Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes + | Some tmp_scope, scopes -> tmp_scope :: scopes + | None, scopes -> scopes let pr_scope_stack = function | [] -> str "the empty scope stack" @@ -572,10 +560,10 @@ let intern_assumption intern ntnvars env nal bk ty = let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function | GLocalAssum (na,bk,t) -> (na,bk,None,t) - | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) - | GLocalDef (na,bk,c,None) -> + | GLocalDef (na,c,Some t) -> (na,Explicit,Some c,t) + | GLocalDef (na,c,None) -> let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,IntroAnonymous,None) in - (na,bk,Some c,t) + (na,Explicit,Some c,t) | GLocalPattern (_,_,_,_) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed here") ) @@ -587,7 +575,7 @@ let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = let ty = Option.map (intern (set_type_scope (restart_prod_binders env))) ty in let impls = impls_term_list 1 term in (push_name_env ntnvars impls env locna, - (na,Explicit,term,ty)) + (na,term,ty)) let intern_cases_pattern_as_binder intern test_kind ntnvars env bk (CAst.{v=p;loc} as pv) = let p,t = match p with @@ -618,8 +606,8 @@ let intern_local_binder_aux intern ntnvars (env,bl) = function let bl' = List.map (fun {loc;v=(na,c,t)} -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef( {loc; v=na} as locna,def,ty) -> - let env,(na,bk,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in - env, (DAst.make ?loc @@ GLocalDef (na,bk,def,ty)) :: bl + let env,(na,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in + env, (DAst.make ?loc @@ GLocalDef (na,def,ty)) :: bl | CLocalPattern p -> let env, ((disjpat,il),id),na,bk,t = intern_cases_pattern_as_binder intern test_kind_tolerant ntnvars env Explicit p in (env, (DAst.make ?loc:p.CAst.loc @@ GLocalPattern((disjpat,List.map (fun x -> x.v) il),id,bk,t)) :: bl) @@ -662,7 +650,7 @@ let rec expand_binders ?loc mk bl c = | [] -> c | b :: bl -> match DAst.get b with - | GLocalDef (n, bk, b, oty) -> + | GLocalDef (n, b, oty) -> expand_binders ?loc mk bl (DAst.make ?loc @@ GLetIn (n, b, oty, c)) | GLocalAssum (n, bk, t) -> expand_binders ?loc mk bl (mk ?loc (n,bk,t) c) @@ -736,9 +724,9 @@ let set_type ty1 ty2 = user_err ?loc:t2.CAst.loc Pp.(str "Unexpected type constraint in notation already providing a type constraint.") let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) na ty = - match na with - | Anonymous -> (renaming,env), None, Anonymous, Explicit, set_type ty None - | Name id -> + match na with + | Anonymous -> (renaming,env), None, Anonymous, Explicit, set_type ty None + | Name id -> let store,get = set_temporary_memory () in let test_kind = test_kind_tolerant in try @@ -778,10 +766,10 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam (renaming',env), None, Name id', Explicit, set_type ty None type binder_action = -| AddLetIn of lname * constr_expr * constr_expr option -| AddTermIter of (constr_expr * subscopes) Names.Id.Map.t -| AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) -| AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) + | AddLetIn of lname * constr_expr * constr_expr option + | AddTermIter of (constr_expr * subscopes) Names.Id.Map.t + | AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) + | AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) let dmap_with_loc f n = CAst.map_with_loc (fun ?loc c -> f ?loc (DAst.get_thunk c)) n @@ -806,8 +794,8 @@ let terms_of_binders bl = let loc = bnd.loc in begin match DAst.get bnd with | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None)) :: extract_variables l - | GLocalDef (Name id,_,_,_) -> extract_variables l - | GLocalDef (Anonymous,_,_,_) + | GLocalDef (Name id,_,_) -> extract_variables l + | GLocalDef (Anonymous,_,_) | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") | GLocalPattern (([u],_),_,_,_) -> term_of_pat u :: extract_variables l | GLocalPattern ((_,_),_,_,_) -> error_cannot_coerce_disjunctive_pattern_term ?loc () @@ -859,7 +847,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = | AddTermIter nterms::rest,terminator,iter -> aux (nterms,None,Some (rest,terminator,iter)) (renaming,env) iter | AddLetIn (na,c,t)::rest,terminator,iter -> - let env,(na,_,c,t) = intern_letin_binder intern ntnvars (adjust_env env iter) (na,c,t) in + let env,(na,c,t) = intern_letin_binder intern ntnvars (adjust_env env iter) (na,c,t) in DAst.make ?loc (GLetIn (na,c,t,aux_letin env (rest,terminator,iter))) in aux_letin env (Option.get iteropt) | NVar id -> subst_var subst' (renaming, env) id @@ -1063,35 +1051,35 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None | Some [] -> DAst.make ?loc @@ GVar id -| Some _ -> - user_err ?loc (str "Variable " ++ Id.print id ++ - str " cannot have a universe instance") + | None | Some [] -> DAst.make ?loc @@ GVar id + | Some _ -> + user_err ?loc (str "Variable " ++ Id.print id ++ + str " cannot have a universe instance") let intern_var env (ltacvars,ntnvars) namedctx loc id us = (* Is [id] a notation variable *) if Id.Map.mem id ntnvars then begin if not (Id.Map.mem id env.impls) then set_var_scope ?loc id true (env.tmp_scope,env.scopes) ntnvars; - gvar (loc,id) us, [], [] + gvar (loc,id) us end else (* Is [id] registered with implicit arguments *) try - let ty,impls,argsc,uid = Id.Map.find id env.impls in + let ty,_,_,uid = Id.Map.find id env.impls in let tys = string_of_ty ty in Dumpglob.dump_reference ?loc "<>" uid tys; - gvar (loc,id) us, make_implicits_list impls, argsc + gvar (loc,id) us with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) if Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars then - gvar (loc,id) us, [], [] + gvar (loc,id) us else if Id.equal id ldots_var (* Is [id] the special variable for recursive notations? *) then if Id.Map.is_empty ntnvars then error_ldots_var ?loc - else gvar (loc,id) us, [], [] + else gvar (loc,id) us else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) user_err ?loc ~hdr:"intern_var" @@ -1103,32 +1091,73 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) let ref = GlobRef.VarRef id in - let impls = implicits_of_global ref in - let scopes = find_arguments_scope ref in Dumpglob.dump_secvar ?loc id; (* this raises Not_found when not a section variable *) (* Someday we should stop relying on Dumglob raising exceptions *) - DAst.make ?loc @@ GRef (ref, us), impls, scopes + DAst.make ?loc @@ GRef (ref, us) with e when CErrors.noncritical e -> (* [id] a goal variable *) - gvar (loc,id) us, [], [] + gvar (loc,id) us + +(**********************************************************************) +(* Locating reference, possibly via an abbreviation *) + +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) + +let is_global id = + try + let _ = locate_reference (qualid_of_ident id) in true + with Not_found -> + false -let find_appl_head_data c = +let dump_extended_global loc = function + | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob ?loc ref + | SynDef sp -> Dumpglob.add_glob_kn ?loc sp + +let intern_extended_global_of_qualid qid = + let r = Nametab.locate_extended qid in dump_extended_global qid.CAst.loc r; r + +let intern_reference qid = + let r = + try intern_extended_global_of_qualid qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + in + Smartlocate.global_of_extended_global r + +let intern_projection qid = + try + let gr = Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) in + (gr, Recordops.find_projection gr) + with Not_found -> + Loc.raise ?loc:qid.loc (InternalizationError (NotAProjection qid)) + +(**********************************************************************) +(* Interpreting references *) + +let find_appl_head_data env (_,ntnvars) c = match DAst.get c with + | GVar id when not (Id.Map.mem id ntnvars) -> + (try + let _,impls,argsc,_ = Id.Map.find id env.impls in + make_implicits_list impls, argsc + with Not_found -> [], []) | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, impls, scopes + impls, scopes | GApp (r, l) -> begin match DAst.get r with | GRef (ref,_) -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, (if n = 0 then [] else List.map (drop_first_implicits n) impls), - List.skipn_at_least n scopes - | _ -> c,[],[] + (if n = 0 then [] else List.map (drop_first_implicits n) impls), + List.skipn_at_least n scopes + | _ -> [],[] end - | _ -> c,[],[] + | _ -> [],[] let error_not_enough_arguments ?loc = user_err ?loc (str "Abbreviation is not applied enough.") @@ -1142,22 +1171,6 @@ 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} @@ -1230,6 +1243,37 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = in c, None, args2 +let intern_qualid_for_pattern test_global intern_not qid pats = + match intern_extended_global_of_qualid qid with + | TrueGlobal g -> + test_global g; + (g, false, Some [], pats) + | SynDef kn -> + let filter (vars,a) = + match a with + | NRef g -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + test_global g; + let () = assert (List.is_empty vars) in + Some (g, Some [], pats) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) + test_global g; + let () = assert (List.is_empty vars) in + Some (g, None, pats) + | NApp (NRef g,args) -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + test_global g; + let nvars = List.length vars in + if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; + let pats1,pats2 = List.chop nvars pats in + let subst = split_by_type_pat vars (pats1,[]) in + let args = List.map (intern_not subst) args in + Some (g, Some args, pats2) + | _ -> None in + match Syntax_def.search_filtered_syntactic_definition filter kn with + | Some (g, pats1, pats2) -> (g, true, pats1, pats2) + | None -> raise Not_found + let warn_nonprimitive_projection = CWarnings.create ~name:"nonprimitive-projection-syntax" ~category:"syntax" ~default:CWarnings.Disabled Pp.(fun f -> pr_qualid f ++ str " used as a primitive projection but is not one.") @@ -1256,35 +1300,34 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us 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; local_univs = { bound=Id.Map.empty; unb_univs = false };(* <- doesn't matter here *) @@ -1297,17 +1340,18 @@ let interp_reference vars r = (**********************************************************************) (** {5 Cases } *) -(** Private internalization patterns *) +(** Intermediate type common to the patterns of the "in" and of the + "with" clause of "match" *) + type 'a raw_cases_pattern_expr_r = | RCPatAlias of 'a raw_cases_pattern_expr * lname - | RCPatCstr of GlobRef.t - * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list - (** [RCPatCstr (loc, c, l1, l2)] represents [((@ c l1) l2)] *) + | RCPatCstr of GlobRef.t * 'a raw_cases_pattern_expr list | RCPatAtom of (lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option | RCPatOr of 'a raw_cases_pattern_expr list and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t (** {6 Elementary bricks } *) + let apply_scope_env env = function | [] -> {env with tmp_scope = None}, [] | sc::scl -> {env with tmp_scope = sc}, scl @@ -1320,22 +1364,19 @@ let rec simple_adjust_scopes n scopes = | [] -> None :: simple_adjust_scopes (n-1) [] | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes -let find_remaining_scopes pl1 pl2 ref = - let impls_st = implicits_of_global ref in - let len_pl1 = List.length pl1 in - let len_pl2 = List.length pl2 in - let impl_list = if Int.equal len_pl1 0 - then select_impargs_size len_pl2 impls_st - else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in - let allscs = find_arguments_scope ref in - let scope_list = List.skipn_at_least len_pl1 allscs in - let rec aux = function - |[],l -> l - |_,[] -> [] - |h::t,_::tt when is_status_implicit h -> aux (t,tt) - |_::t,h::tt -> h :: aux (t,tt) - in ((try List.firstn len_pl1 allscs with Failure _ -> simple_adjust_scopes len_pl1 allscs), - simple_adjust_scopes len_pl2 (aux (impl_list,scope_list))) +let rec adjust_to_up l l' default = + match l, l' with + | l, [] -> [] + | [], l -> l + | true::l, l' -> default :: adjust_to_up l l' default + | false::l, y::l' -> y :: adjust_to_up l l' default + +let rec adjust_to_down l l' default = + match l, l' with + | [], l -> [] + | true::l, l' -> adjust_to_down l l' default + | false::l, [] -> default :: adjust_to_down l [] default + | false::l, y::l' -> y :: adjust_to_down l l' default (* @return the first variable that occurs twice in a pattern @@ -1378,85 +1419,16 @@ let check_or_pat_variables loc ids idsl = Id.print (List.hd ids'').v ++ strbrk " is not bound in all patterns).") | [] -> () -(** Use only when params were NOT asked to the user. - @return if letin are included *) -let check_constructor_length env loc cstr len_pl pl0 = - let n = len_pl + List.length pl0 in - if Int.equal n (Inductiveops.constructor_nallargs env cstr) then false else - (Int.equal n (Inductiveops.constructor_nalldecls env cstr) || - (error_wrong_numarg_constructor ?loc env cstr - (Inductiveops.constructor_nrealargs env cstr))) - -open Declarations - -(* Similar to Cases.adjust_local_defs but on RCPat *) -let insert_local_defs_in_pattern (ind,j) l = - let (mib,mip) = Global.lookup_inductive ind in - if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then - (* Optimisation *) l - else - let (ctx, _) = mip.mind_nf_lc.(j-1) in - let decls = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in - let rec aux decls args = - match decls, args with - | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args - | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) - | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args - | _ -> assert false in - aux decls l - -let add_local_defs_and_check_length loc env g pl args = - let open GlobRef in - match g with - | ConstructRef cstr -> - (* We consider that no variables corresponding to local binders - have been given in the "explicit" arguments, which come from a - "@C args" notation or from a custom user notation *) - let pl' = insert_local_defs_in_pattern cstr pl in - let maxargs = Inductiveops.constructor_nalldecls env cstr in - if List.length pl' + List.length args > maxargs then - error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); - (* Two possibilities: either the args are given with explicit - variables for local definitions, then we give the explicit args - extended with local defs, so that there is nothing more to be - added later on; or the args are not enough to have all arguments, - which a priori means local defs to add in the [args] part, so we - postpone the insertion of local defs in the explicit args *) - (* Note: further checks done later by check_constructor_length *) - if List.length pl' + List.length args = maxargs then pl' else pl - | _ -> pl - -let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = - let impl_list = if Int.equal len_pl1 0 - then select_impargs_size (List.length pl2) impls_st - else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in - let remaining_args = List.fold_left (fun i x -> if is_status_implicit x then i else succ i) in - let rec aux i = function - |[],l -> let args_len = List.length l + List.length impl_list + len_pl1 in - ((if Int.equal args_len nargs then false - else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) - ,l) - |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp - then let (b,out) = aux i (q,[]) in (b,(DAst.make @@ RCPatAtom None)::out) - else fail (remaining_args (len_pl1+i) il) - |imp::q,(hh::tt as l) -> if is_status_implicit imp - then let (b,out) = aux i (q,l) in (b,(DAst.make @@ RCPatAtom None)::out) - else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) - in aux 0 (impl_list,pl2) - -let add_implicits_check_constructor_length env loc c len_pl1 pl2 = - let nargs = Inductiveops.constructor_nallargs env c in - let nargs' = Inductiveops.constructor_nalldecls env c in - let impls_st = implicits_of_global (GlobRef.ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) - nargs nargs' impls_st len_pl1 pl2 - -let add_implicits_check_ind_length env loc c len_pl1 pl2 = - let nallargs = inductive_nallargs env c in - let nalldecls = inductive_nalldecls env c in - let impls_st = implicits_of_global (GlobRef.IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) - nallargs nalldecls impls_st len_pl1 pl2 +let check_has_letin ?loc g expanded nargs nimps tags = + let expected_ndecls = List.length tags - nimps in + let expected_nassums = List.count (fun x -> not x) tags - nimps in + if nargs = expected_nassums then false + else if nargs = expected_ndecls then true else + let env = Global.env() in + match g with + | GlobRef.ConstructRef cstr -> error_wrong_numarg_constructor ?loc env ~cstr ~expanded ~nargs ~expected_nassums ~expected_ndecls + | GlobRef.IndRef ind -> error_wrong_numarg_inductive ?loc env ~ind ~expanded ~nargs ~expected_nassums ~expected_ndecls + | _ -> assert false (** Do not raise NotEnoughArguments thanks to preconditions*) let chop_params_pattern loc ind args with_letin = @@ -1470,9 +1442,9 @@ let chop_params_pattern loc ind args with_letin = | PatVar _ | PatCstr(_,_,_) -> error_parameter_not_implicit ?loc:c.CAst.loc) params; args -let find_constructor loc add_params ref = +let find_constructor_head ?loc ref = let open GlobRef in - let (ind,_ as cstr) = match ref with + match ref with | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in @@ -1480,17 +1452,12 @@ let find_constructor loc add_params ref = | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in user_err ?loc ~hdr:"find_constructor" error - in - cstr, match add_params with - | Some nb_args -> - let env = Global.env () in - let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls env cstr) - then Inductiveops.inductive_nparamdecls env ind - else Inductiveops.inductive_nparams env ind - in - List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) - | None -> [] + +let find_inductive_head ?loc ref = + let open GlobRef in + match ref with + | IndRef ind -> ind + | _ -> error_bad_inductive_type ?loc () let find_pattern_variable qid = if qualid_is_ident qid then qualid_basename qid @@ -1505,10 +1472,6 @@ let check_duplicate ?loc fields = user_err ?loc (str "This record defines several times the field " ++ pr_qualid r ++ str ".") -let inductive_of_record loc record = - let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in - Nametab.shortest_qualid_of_global ?loc Id.Set.empty inductive - (** [sort_fields ~complete loc fields completer] expects a list [fields] of field assignments [f = e1; g = e2; ...], where [f, g] are fields of a record and [e1] are "values" (either terms, when @@ -1526,16 +1489,7 @@ let sort_fields ~complete loc fields completer = match fields with | [] -> None | (first_field_ref, _):: _ -> - let (first_field_glob_ref, record) = - try - let gr = locate_reference first_field_ref in - Dumpglob.add_glob ?loc:first_field_ref.CAst.loc gr; - (gr, Recordops.find_projection gr) - with Not_found as exn -> - let _, info = Exninfo.capture exn in - let info = Option.cata (Loc.add_loc info) info loc in - Exninfo.iraise (InternalizationError(NotAProjection first_field_ref), info) - in + let (first_field_glob_ref, record) = intern_projection first_field_ref in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in (* the reference constructor of the record *) @@ -1554,25 +1508,14 @@ let sort_fields ~complete loc fields completer = let rec index_fields fields remaining_projs acc = match fields with | (field_ref, field_value) :: fields -> - let field_glob_ref = try locate_reference field_ref - with Not_found -> - user_err ?loc:field_ref.CAst.loc ~hdr:"intern" - (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in + let field_glob_ref,this_field_record = intern_projection field_ref in let remaining_projs, (field_index, _, regular) = let the_proj = function | (idx, Some glob_id, _) -> GlobRef.equal field_glob_ref (GlobRef.ConstRef glob_id) | (idx, None, _) -> false in try CList.extract_first the_proj remaining_projs with Not_found -> - let floc = field_ref.CAst.loc in - let this_field_record = - try Recordops.find_projection field_glob_ref - with Not_found -> - let inductive_ref = inductive_of_record floc record in - Loc.raise ?loc:floc (InternalizationError(NotAProjectionOf (field_ref, inductive_ref))) in - let ind1 = inductive_of_record floc record in - let ind2 = inductive_of_record floc this_field_record in - Loc.raise ?loc (InternalizationError(ProjectionsOfDifferentRecords (ind1, ind2))) + Loc.raise ?loc (InternalizationError(ProjectionsOfDifferentRecords (record, this_field_record))) in if not regular && complete then (* "regular" is false when the field is defined @@ -1625,8 +1568,8 @@ let merge_aliases aliases {loc;v=na} = { alias_ids; alias_map; } let alias_of als = match als.alias_ids with -| [] -> Anonymous -| {v=id} :: _ -> Name id + | [] -> Anonymous + | {v=id} :: _ -> Name id (** {6 Expanding notations } @@ -1652,29 +1595,33 @@ let product_of_cases_patterns aliases idspl = let rec subst_pat_iterator y t = DAst.(map (function | RCPatAtom id as p -> begin match id with Some ({v=x},_) when Id.equal x y -> DAst.get t | _ -> p end - | RCPatCstr (id,l1,l2) -> - RCPatCstr (id,List.map (subst_pat_iterator y t) l1, - List.map (subst_pat_iterator y t) l2) + | RCPatCstr (id,l) -> + RCPatCstr (id,List.map (subst_pat_iterator y t) l) | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) -| _ -> false + | { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) + | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) -| _ -> false + | { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) + | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref ~depr:false ~key:["Asymmetric";"Patterns"] ~value:false +type global_reference_test = { + for_ind : bool; + test_kind : ?loc:Loc.t -> GlobRef.t -> unit +} + let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) - let ensure_kind test_kind ?loc g = + let ensure_kind {test_kind} ?loc g = try test_kind ?loc g with Not_found -> error_invalid_pattern_notation ?loc () @@ -1682,60 +1629,47 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) - | GHole (_,_,_) -> RCPatAtom (None) - | GRef (g,_) -> RCPatCstr (g,[],[]) + | GHole (_,_,_) -> RCPatAtom None + | GRef (g,_) -> RCPatCstr (g, []) | GApp (r, l) -> begin match DAst.get r with | GRef (g,_) -> let allscs = find_arguments_scope g in - let allscs = simple_adjust_scopes (List.length l) allscs in (* TO CHECK *) - RCPatCstr (g, List.map2 (fun sc a -> rcp_of_glob (sc,snd scopes) a) allscs l,[]) + let allscs = simple_adjust_scopes (List.length l) allscs in + RCPatCstr (g, List.map2 (fun sc a -> rcp_of_glob (sc,snd scopes) a) allscs l) | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") end | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in - let rec drop_syndef test_kind ?loc scopes qid pats = + let make_pars ?loc g = + let env = Global.env () in + let n = match g with + | GlobRef.ConstructRef (ind,_) -> Inductiveops.inductive_nparams env ind + | _ -> 0 in + List.make n (DAst.make ?loc @@ RCPatAtom None) + in + let rec drop_syndef {test_kind} ?loc scopes qid add_par_if_no_ntn_with_par no_impl pats = try - if qualid_is_ident qid && Option.cata (Id.Set.mem (qualid_basename qid)) false env.pat_ids then + if qualid_is_ident qid && Option.cata (Id.Set.mem (qualid_basename qid)) false env.pat_ids && List.is_empty pats then raise Not_found; - match Nametab.locate_extended qid with - | SynDef sp -> - let filter (vars,a) = - try match a with - | NRef g -> - (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind ?loc g; - let () = assert (List.is_empty vars) in - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g, [], List.map2 (in_pat_sc scopes) argscs pats) - | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) - test_kind ?loc g; - let () = assert (List.is_empty vars) in - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g, List.map2 (in_pat_sc scopes) argscs pats, []) - | NApp (NRef g,args) -> - (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind ?loc g; - let nvars = List.length vars in - if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; - let pats1,pats2 = List.chop nvars pats in - let subst = split_by_type_pat vars (pats1,[]) in - let idspl1 = List.map (in_not test_kind_inner qid.loc scopes subst []) args in - let (_,argscs) = find_remaining_scopes pats1 pats2 g in - Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) - | _ -> raise Not_found - with Not_found -> None in - Syntax_def.search_filtered_syntactic_definition filter sp - | TrueGlobal g -> - test_kind ?loc g; - Dumpglob.add_glob ?loc:qid.loc g; - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g,[],List.map2 (in_pat_sc scopes) argscs pats) + let intern_not subst pat = in_not test_kind_inner qid.loc scopes subst [] pat in + let g, expanded, ntnpats, pats = intern_qualid_for_pattern (test_kind ?loc) intern_not qid pats in + match ntnpats with + | None -> + (* deactivate implicit *) + let ntnpats = if add_par_if_no_ntn_with_par then make_pars ?loc g else [] in + Some (g, in_patargs ?loc scopes g expanded true ntnpats pats) + | Some ntnpats -> + let ntnpats = if add_par_if_no_ntn_with_par && ntnpats = [] then make_pars ?loc g else ntnpats in + Some (g, in_patargs ?loc scopes g expanded no_impl ntnpats pats) with Not_found -> None - and in_pat test_kind scopes pt = + and in_pat ({for_ind} as test_kind) scopes pt = let open CAst in let loc = pt.loc in + (* The two policies implied by asymmetric pattern mode *) + let add_par_if_no_ntn_with_par = get_asymmetric_patterns () && not for_ind in + let no_impl = get_asymmetric_patterns () && not for_ind in match pt.v with | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat test_kind scopes p, id) | CPatRecord l -> @@ -1744,36 +1678,22 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = begin match sorted_fields with | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> - let pl = - let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in - List.rev_append pars pl - in - let (_,argscs) = find_remaining_scopes [] pl head in - let pats = List.map2 (in_pat_sc scopes) argscs pl in - DAst.make ?loc @@ RCPatCstr(head, pats, []) + let pars = make_pars ?loc head in + let pats = in_patargs ?loc scopes head true true pars pl in + DAst.make ?loc @@ RCPatCstr(head, pats) end | CPatCstr (head, None, pl) -> begin - match drop_syndef test_kind ?loc scopes head pl with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) + match drop_syndef test_kind ?loc scopes head add_par_if_no_ntn_with_par no_impl pl with + | Some (g,pl) -> DAst.make ?loc @@ RCPatCstr(g, pl) + | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) end | CPatCstr (qid, Some expl_pl, pl) -> - let g = - try Nametab.locate qid - with Not_found as exn -> - let _, info = Exninfo.capture exn in - let info = Option.cata (Loc.add_loc info) info loc in - Exninfo.iraise (InternalizationError (NotAConstructor qid), info) - in - if expl_pl == [] then - (* Convention: (@r) deactivates all further implicit arguments and scopes *) - DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat test_kind_inner scopes) pl, []) - else - (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) - (* but not scopes in expl_pl *) - let (argscs1,_) = find_remaining_scopes expl_pl pl g in - DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat test_kind_inner scopes) pl, []) + begin + match drop_syndef test_kind ?loc scopes qid false true (expl_pl@pl) with + | Some (g,pl) -> DAst.make ?loc @@ RCPatCstr (g, pl) + | None -> Loc.raise ?loc (InternalizationError (NotAConstructor qid)) + end | CPatNotation (_,(InConstrEntry,"- _"),([a],[]),[]) when is_non_zero_pat a -> let p = match a.CAst.v with CPatPrim (Number (_, p)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind test_kind_inner) (Number (SMinus,p)) scopes in @@ -1789,20 +1709,20 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = | CPatDelimiters (key, e) -> in_pat test_kind (None,find_delimiters_scope ?loc key::snd scopes) e | CPatPrim p -> - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc test_kind_inner p scopes in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc test_kind_inner.test_kind p scopes in rcp_of_glob scopes pat | CPatAtom (Some id) -> begin - match drop_syndef test_kind ?loc scopes id [] with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) - | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) + match drop_syndef test_kind ?loc scopes id add_par_if_no_ntn_with_par no_impl [] with + | Some (g, pl) -> DAst.make ?loc @@ RCPatCstr (g, pl) + | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) end | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat test_kind scopes) pl) | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns - are supported only in local binders and only at top level. + are supported only in local binders and only at for_ind level. The only reason they are in the [cases_pattern_expr] type is that the parser needs to factor the "c : t" notation with user defined notations. In the long term, we will try to @@ -1812,7 +1732,46 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = duplicating the levels of the [pattern] rule. *) CErrors.user_err ?loc (Pp.strbrk "Casts are not supported in this pattern.") and in_pat_sc scopes x = in_pat test_kind_inner (x,snd scopes) - and in_not (test_kind:?loc:Loc.t->'a->'b) loc scopes (subst,substlist as fullsubst) args = function + and in_patargs ?loc scopes + gr (* head of the pattern *) + expanded (* tell if comes from a notation (for error reporting) *) + no_impl (* tell if implicit are not expected (for asymmetric patterns, or @, or {| |} *) + ntnpats (* prefix of patterns obtained by expansion of notations or parameter insertion *) + pats (* user given patterns *) + = + let default = DAst.make ?loc @@ RCPatAtom None in + let npats = List.length pats in + let n = List.length ntnpats in + let ntnpats_with_letin, tags = + let tags = match gr with + | GlobRef.ConstructRef cstr -> constructor_alltags (Global.env()) cstr + | GlobRef.IndRef ind -> inductive_alltags (Global.env()) ind + | _ -> assert false in + let ntnpats_with_letin = adjust_to_up tags ntnpats default in + ntnpats_with_letin, List.skipn (List.length ntnpats_with_letin) tags in + let imps = + let imps = + if no_impl then [] else + let impls_st = implicits_of_global gr in + if Int.equal n 0 then select_impargs_size npats impls_st + else List.skipn_at_least n (select_stronger_impargs impls_st) in + adjust_to_down tags imps None in + let subscopes = adjust_to_down tags (List.skipn_at_least n (find_arguments_scope gr)) None in + let has_letin = check_has_letin ?loc gr expanded npats (List.count is_status_implicit imps) tags in + let rec aux imps subscopes tags pats = + match imps, subscopes, tags, pats with + | _, _, true::tags, p::pats when has_letin -> + in_pat_sc scopes None p :: aux imps subscopes tags pats + | _, _, true::tags, _ -> + default :: aux imps subscopes tags pats + | imp::imps, sc::subscopes, false::tags, _ when is_status_implicit imp -> + default :: aux imps subscopes tags pats + | imp::imps, sc::subscopes, false::tags, p::pats -> + in_pat_sc scopes sc p :: aux imps subscopes tags pats + | _, _, [], [] -> [] + | _ -> assert false in + ntnpats_with_letin @ aux imps subscopes tags pats + and in_not test_kind loc scopes (subst,substlist as fullsubst) args = function | NVar id -> let () = assert (List.is_empty args) in begin @@ -1827,22 +1786,15 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = end | NRef g -> ensure_kind test_kind ?loc g; - let (_,argscs) = find_remaining_scopes [] args g in - DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) - | NApp (NRef g,pl) -> + DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true false [] args) + | NApp (NRef g,ntnpl) -> ensure_kind test_kind ?loc g; - let (argscs1,argscs2) = find_remaining_scopes pl args g in - let pl = List.map2 (fun x -> in_not test_kind_inner loc (x,snd scopes) fullsubst []) argscs1 pl in - let pl = add_local_defs_and_check_length loc genv g pl args in - let args = List.map2 (fun x -> in_pat test_kind_inner (x,snd scopes)) argscs2 args in - let pat = - if List.length pl = 0 then - (* Convention: if notation is @f, encoded as NApp(Nref g,[]), then - implicit arguments are not inherited *) - RCPatCstr (g, pl @ args, []) - else - RCPatCstr (g, pl, args) in - DAst.make ?loc @@ pat + let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in + let no_impl = + (* Convention: if notation is @f, encoded as NApp(Nref g,[]), then + implicit arguments are not inherited *) + ntnpl = [] in + DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true no_impl ntnpl args) | NList (x,y,iter,terminator,revert) -> if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); @@ -1875,23 +1827,14 @@ let rec intern_pat genv ntnvars aliases pat = | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in intern_pat genv ntnvars aliases' p - | RCPatCstr (head, expl_pl, pl) -> - if get_asymmetric_patterns () then - let len = if List.is_empty expl_pl then Some (List.length pl) else None in - let c,idslpl1 = find_constructor loc len head in - let with_letin = - check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl) - else - let c,idslpl1 = find_constructor loc None head in - let with_letin, pl2 = - add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) + | RCPatCstr (head, pl) -> + let c = find_constructor_head ?loc head in + intern_cstr_with_all_args loc c true [] pl | RCPatAtom (Some ({loc;v=id},scopes)) -> let aliases = merge_aliases aliases (make ?loc @@ Name id) in set_var_scope ?loc id false scopes ntnvars; (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) (* TO CHECK: aura-t-on id? *) - | RCPatAtom (None) -> + | RCPatAtom None -> let { alias_ids = ids; alias_map = asubst; } = aliases in (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatOr pl -> @@ -1903,8 +1846,9 @@ let rec intern_pat genv ntnvars aliases pat = (ids,List.flatten pl') let intern_cases_pattern test_kind genv ntnvars env aliases pat = + let test = {for_ind=false;test_kind} in intern_pat genv ntnvars aliases - (drop_notations_pattern (test_kind,test_kind) genv env pat) + (drop_notations_pattern (test,test) genv env pat) let _ = intern_cases_pattern_fwd := @@ -1924,21 +1868,21 @@ let intern_ind_pattern genv ntnvars env pat = raise Not_found in let no_not = try - drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat + let test_top = {for_ind=true;test_kind=test_kind_top} in + let test_inner = {for_ind=false;test_kind=test_kind_inner} in + drop_notations_pattern (test_top,test_inner) genv env pat with InternalizationError (NotAConstructor _) as exn -> let _, info = Exninfo.capture exn in error_bad_inductive_type ~info () in let loc = no_not.CAst.loc in match DAst.get no_not with - | RCPatCstr (head, expl_pl, pl) -> - let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc ()) head in - let with_letin, pl2 = add_implicits_check_ind_length genv loc c - (List.length expl_pl) pl in - let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in - (with_letin, + | RCPatCstr (head, pl) -> + let ind = find_inductive_head ?loc head in + let idslpl = List.map (intern_pat genv ntnvars empty_alias) pl in + (true, match product_of_cases_patterns empty_alias idslpl with - | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) + | ids,[asubst,pl] -> (ind,ids,asubst,chop_params_pattern loc ind pl true) | _ -> error_bad_inductive_type ?loc ()) | x -> error_bad_inductive_type ?loc () @@ -1999,17 +1943,22 @@ let extract_explicit_arg imps args = (Id.Map.add id (loc, a) eargs, rargs) in aux args +let extract_regular_arguments args = + List.map_filter (function + | (a,Some pos) -> user_err ?loc:pos.loc (str "Unexpected explicit argument.") + | (a,None) -> Some a) args + (**********************************************************************) (* Main loop *) let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> - let (c,imp,subscopes),_ = + let c,_ = intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) lvar us [] ref in - apply_impargs c env imp subscopes [] loc + apply_impargs env loc c [] | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in @@ -2108,8 +2057,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CNotation (_,(InConstrEntry,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in - let x, impl, scopes = find_appl_head_data c in - apply_impargs x env impl scopes [] loc + apply_impargs env loc c [] | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c | CPrim p -> @@ -2118,12 +2066,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern {env with tmp_scope = None; scopes = find_delimiters_scope ?loc key :: env.scopes} e | CAppExpl ((isproj,ref,us), args) -> - let (f,_,args_scopes),args = + let f,args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref in check_not_notation_variable f ntnvars; + let _,args_scopes = find_appl_head_data env lvar f in (* Rem: GApp(_,f,[]) stands for @f *) if args = [] then DAst.make ?loc @@ GApp (f,[]) else smart_gapp f loc (intern_args env args_scopes (List.map fst args)) @@ -2135,22 +2084,21 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in - let (c,impargs,args_scopes),args = - match f.CAst.v with + (match f.CAst.v with | CRef (ref,us) -> - intern_applied_reference ~isproj intern env - (Environ.named_context_val globalenv) lvar us args ref + let f, args = intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref in + apply_impargs env loc f args | CNotation (_,ntn,ntnargs) -> assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ntnargs in - find_appl_head_data c, args + apply_impargs env loc c args | _ -> - assert (Option.is_empty isproj); - let f = intern_no_implicit env f in - let f, _, args_scopes = find_appl_head_data f in - (f,[],args_scopes), args - in - apply_impargs c env impargs args_scopes args loc + assert (Option.is_empty isproj); + let f = intern_no_implicit env f in + let _, args_scopes = find_appl_head_data env lvar f in + let args = extract_regular_arguments args in + smart_gapp f loc (intern_args env args_scopes args)) | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in @@ -2445,10 +2393,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern_args env subscopes rargs in aux 1 l subscopes eargs rargs - and apply_impargs c env imp subscopes l loc = - let imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) l)) imp in - let l = intern_impargs c env imp subscopes l in - smart_gapp c loc l + and apply_impargs env loc c args = + let impl, subscopes = find_appl_head_data env lvar c in + let imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) args)) impl in + let args = intern_impargs c env imp subscopes args in + smart_gapp c loc args and smart_gapp f loc = function | [] -> f diff --git a/interp/notation.ml b/interp/notation.ml index c35ba44aa5..f2d113954b 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -640,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 @@ -692,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 @@ -712,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])) @@ -782,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 *) @@ -1041,7 +1048,7 @@ let interp_int63 ?loc n = let bigint_of_int63 c = match Constr.kind c with - | Int i -> Z.of_string (Uint63.to_string i) + | Int i -> Z.of_int64 (Uint63.to_int64 i) | _ -> raise NotAValidPrimToken let interp o ?loc n = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 036970ce37..0e7f085bde 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -863,7 +863,7 @@ let rec push_context_binders vars = function let vars = match DAst.get b with | GLocalAssum (na,_,_) -> Termops.add_vname vars na | GLocalPattern ((disjpat,ids),p,bk,t) -> List.fold_right Id.Set.add ids vars - | GLocalDef (na,_,_,_) -> Termops.add_vname vars na in + | GLocalDef (na,_,_) -> Termops.add_vname vars na in push_context_binders vars bl let is_term_meta id metas = @@ -1014,9 +1014,9 @@ let unify_binder_upto alp b b' = | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> let alp, na = unify_name_upto alp na na' in alp, DAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') - | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> + | GLocalDef (na,c,t), GLocalDef (na',c',t') -> let alp, na = unify_name_upto alp na na' in - alp, DAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + alp, DAst.make ?loc @@ GLocalDef (na, unify_term alp c c', unify_opt_term alp t t') | GLocalPattern ((disjpat,ids),id,bk,t), GLocalPattern ((disjpat',_),_,bk',t') when List.length disjpat = List.length disjpat' -> let alp, p = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') @@ -1061,7 +1061,7 @@ let rec unify_terms_binders alp cl bl' = | [], [] -> [] | c :: cl, b' :: bl' -> begin match DAst.get b' with - | GLocalDef ( _, _, _, t) -> unify_terms_binders alp cl bl' + | GLocalDef (_, _, t) -> unify_terms_binders alp cl bl' | _ -> unify_term_binder alp c b' :: unify_terms_binders alp cl bl' end | _ -> raise No_match @@ -1249,7 +1249,7 @@ let match_binderlist match_fun alp metas sigma rest x y iter termin revert = with No_match -> match DAst.get rest with | GLetIn (na,c,t,rest') when glue_inner_letin_with_decls -> - let b = DAst.make ?loc:rest.CAst.loc @@ GLocalDef (na,Explicit (*?*), c,t) in + let b = DAst.make ?loc:rest.CAst.loc @@ GLocalDef (na,c,t) in (* collect let-in *) (try aux true sigma (b::bl) rest' with OnlyTrailingLetIns diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d92bbe87eb..13568957c2 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -20,7 +20,7 @@ # define DECLARE_NULLOP(name) \ value uint63_##name() { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam0(); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(*cb); \ @@ -28,7 +28,7 @@ value uint63_##name() { \ # define DECLARE_UNOP(name) \ value uint63_##name##_ml(value x) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam1(x); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback(*cb, x)); \ @@ -53,7 +53,7 @@ value uint63_##name##_ml(value x) { \ # define DECLARE_BINOP(name) \ value uint63_##name##_ml(value x, value y) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam2(x, y); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback2(*cb, x, y)); \ @@ -79,7 +79,7 @@ value uint63_##name##_ml(value x, value y) { \ # define DECLARE_TEROP(name) \ value uint63_##name##_ml(value x, value y, value z) { \ - static value* cb = 0; \ + static value const *cb = 0; \ CAMLparam3(x, y, z); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback3(*cb, x, y, z)); \ diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index c9326615dc..d2256720c4 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -759,6 +759,10 @@ let get_nth_arg head n stk = | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk +let rec subs_consn v i n s = + if Int.equal i n then s + else subs_consn v (i + 1) n (subs_cons v.(i) s) + (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e = function @@ -770,14 +774,13 @@ let rec get_args n tys f e = function get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in - if n == na then (Inl (subs_cons(l,e)),s) + if n == na then (Inl (subs_consn l 0 na e), s) else if n < na then (* more arguments *) - let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in - (Inl (subs_cons(args,e)), Zapp eargs :: s) + (Inl (subs_consn l 0 n e), Zapp eargs :: s) else (* more lambdas *) let etys = List.skipn na tys in - get_args (n-na) etys f (subs_cons(l,e)) s + get_args (n-na) etys f (subs_consn l 0 na e) s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (Inr {mark=mark Cstr Unknown;term=FLambda(n,tys,f,e)}, stk) @@ -931,7 +934,11 @@ let contract_fix_vect fix = env, Array.length bds) | _ -> assert false in - (subs_cons(Array.init nfix make_body, env), thisbody) + let rec mk_subs env i = + if Int.equal i nfix then env + else mk_subs (subs_cons (make_body i) env) (i + 1) + in + (mk_subs env 0, thisbody) let unfold_projection info p = if red_projection info.i_flags p @@ -1367,7 +1374,7 @@ let rec knr info tab m stk = knit info tab fxe fxbd (args@stk') | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] as s)) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> - knit info tab (subs_cons([|v|],e)) bd stk + knit info tab (subs_cons v e) bd stk | FEvar(ev,env) -> (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk @@ -1417,7 +1424,7 @@ and case_inversion info tab ci (univs,args) v = let env = info_env info in let ind = ci.ci_ind in let params, indices = Array.chop ci.ci_npar args in - let psubst = subs_cons (params, subs_id 0) in + let psubst = subs_consn params 0 ci.ci_npar (subs_id 0) in let mib = Environ.lookup_mind (fst ind) env in let mip = mib.mind_packets.(snd ind) in (* indtyping enforces 1 ctor with no letins in the context *) diff --git a/kernel/environ.ml b/kernel/environ.ml index a5f81d1e59..6f2aeab203 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -571,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 900e2128ea..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} *) diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 3e8502b988..afd8e3ef67 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -60,127 +60,188 @@ let rec is_lift_id = function (* Substitutions *) (*********************) -(* (bounded) explicit substitutions of type 'a *) -type 'a subs = - | ESID of int (* ESID(n) = %n END bounded identity *) - | CONS of 'a array * 'a subs - (* CONS([|t1..tn|],S) = - (S.t1...tn) parallel substitution - beware of the order *) - | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) - (* with n vars *) - | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) - -(* operations of subs: collapses constructors when possible. - * Needn't be recursive if we always use these functions - *) - -let subs_id i = ESID i - -let subs_cons(x,s) = if Int.equal (Array.length x) 0 then s else CONS(x,s) - -let subs_liftn n = function - | ESID p -> ESID (p+n) (* bounded identity lifted extends by p *) - | LIFT (p,lenv) -> LIFT (p+n, lenv) - | lenv -> LIFT (n,lenv) - -let subs_lift a = subs_liftn 1 a -let subs_liftn n a = if Int.equal n 0 then a else subs_liftn n a - -let subs_shft = function - | (0, s) -> s - | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) - | (n, s) -> SHIFT (n,s) -let subs_shft s = if Int.equal (fst s) 0 then snd s else subs_shft s - -let subs_shift_cons = function - (0, s, t) -> CONS(t,s) -| (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1)) -| (k, s, t) -> CONS(t,SHIFT(k, s));; - -(* Tests whether a substitution is equal to the identity *) -let rec is_subs_id = function - ESID _ -> true - | LIFT(_,s) -> is_subs_id s - | SHIFT(0,s) -> is_subs_id s - | CONS(x,s) -> Int.equal (Array.length x) 0 && is_subs_id s - | _ -> false - -(* Expands de Bruijn k in the explicit substitution subs - * lams accumulates de shifts to perform when retrieving the i-th value - * the rules used are the following: - * - * [id]k --> k - * [S.t]1 --> t - * [S.t]k --> [S](k-1) if k > 1 - * [^n o S] k --> [^n]([S]k) - * [(%n S)] k --> k if k <= n - * [(%n S)] k --> [^n]([S](k-n)) - * - * the result is (Inr (k+lams,p)) when the variable is just relocated - * where p is None if the variable points inside subs and Some(k) if the - * variable points k bindings beyond subs. - *) -let rec exp_rel lams k subs = - match subs with - | CONS (def,_) when k <= Array.length def - -> Inl(lams,def.(Array.length def - k)) - | CONS (v,l) -> exp_rel lams (k - Array.length v) l - | LIFT (n,_) when k<=n -> Inr(lams+k,None) - | LIFT (n,l) -> exp_rel (n+lams) (k-n) l - | SHIFT (n,s) -> exp_rel (n+lams) k s - | ESID n when k<=n -> Inr(lams+k,None) - | ESID n -> Inr(lams+k,Some (k-n)) - -let expand_rel k subs = exp_rel 0 k subs - -let rec subs_map f = function -| ESID _ as s -> s -| CONS (x, s) -> CONS (Array.map f x, subs_map f s) -| SHIFT (n, s) -> SHIFT (n, subs_map f s) -| LIFT (n, s) -> LIFT (n, subs_map f s) - -let rec lift_subst mk_cl s1 s2 = match s1 with -| ELID -> subs_map (fun c -> mk_cl ELID c) s2 -| ELSHFT(s, k) -> subs_shft(k, lift_subst mk_cl s s2) -| ELLFT (k, s) -> - match s2 with - | CONS(x,s') -> - CONS(CArray.Fun1.map mk_cl s1 x, lift_subst mk_cl s1 s') - | ESID n -> lift_subst mk_cl s (ESID (n + k)) - | SHIFT(k',s') -> - if k<k' - then subs_shft(k, lift_subst mk_cl s (subs_shft(k'-k, s'))) - else subs_shft(k', lift_subst mk_cl (el_liftn (k-k') s) s') - | LIFT(k',s') -> - if k<k' - then subs_liftn k (lift_subst mk_cl s (subs_liftn (k'-k) s')) - else subs_liftn k' (lift_subst mk_cl (el_liftn (k-k') s) s') - -let rec comp mk_cl s1 s2 = - match (s1, s2) with - | _, ESID _ -> s1 - | ESID _, _ -> s2 - | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) - | _, CONS(x,s') -> - CONS(Array.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') - | CONS(x,s), SHIFT(k,s') -> - let lg = Array.length x in - if k == lg then comp mk_cl s s' - else if k > lg then comp mk_cl s (SHIFT(k-lg, s')) - else comp mk_cl (CONS(Array.sub x 0 (lg-k), s)) s' - | CONS(x,s), LIFT(k,s') -> - let lg = Array.length x in - if k == lg then CONS(x, comp mk_cl s s') - else if k > lg then CONS(x, comp mk_cl s (LIFT(k-lg, s'))) - else - CONS(Array.sub x (lg-k) k, - comp mk_cl (CONS(Array.sub x 0 (lg-k),s)) s') - | LIFT(k,s), SHIFT(k',s') -> - if k<k' - then subs_shft(k, comp mk_cl s (subs_shft(k'-k, s'))) - else subs_shft(k', comp mk_cl (subs_liftn (k-k') s) s') - | LIFT(k,s), LIFT(k',s') -> - if k<k' - then subs_liftn k (comp mk_cl s (subs_liftn (k'-k) s')) - else subs_liftn k' (comp mk_cl (subs_liftn (k-k') s) s') +(* Variant of skewed lists enriched w.r.t. a monoid. See the Range module. + + In addition to the indexed data, every node contains a monoid element, in our + case, integers. It corresponds to the number of partial shifts to apply when + reaching this subtree. The total shift is obtained by summing all the partial + shifts encountered in the tree traversal. For efficiency, we also cache the + sum of partial shifts of the whole subtree as the last argument of the [Node] + constructor. + + A more intuitive but inefficient representation of this data structure would + be a list of terms interspeded with shifts, as in + + type 'a subst = NIL | CONS of 'a or_var * 'a subst | SHIFT of 'a subst + + On this inefficient representation, the typing rules would be: + + · ⊢ NIL : · + Γ ⊢ σ : Δ and Γ ⊢ t : A{σ} implies Γ ⊢ CONS (t, σ) : Δ, A + Γ ⊢ σ : Δ implies Γ, A ⊢ SHIFT σ : Δ + + The efficient representation is isomorphic to this naive variant, except that + shifts are grouped together, and we use skewed lists instead of lists. + +*) + +type shf = int +let cmp n m = n + m +let idn = 0 + +type 'a or_var = Arg of 'a | Var of int + +type 'a tree = +| Leaf of shf * 'a or_var +| Node of shf * 'a or_var * 'a tree * 'a tree * shf +(* + Invariants: + - All trees are complete. + - Define get_shift inductively as [get_shift (Leaf (w, _)) := w] and + [get_shift (Node (w, _, t1, t2, _)) := w + t1 + t2] then for every tree + of the form Node (_, _, t1, t2, sub), we must have + sub = get_shift t1 + get_shift t2. + + In the naive semantics: + + Leaf (w, x) := SHIFT^w (CONS (x, NIL)) + Node (w, x, t1, t2, _) := SHIFT^w (CONS (x, t1 @ t2)) + +*) + +type 'a subs = Nil of shf * int | Cons of int * 'a tree * 'a subs +(* + In the naive semantics mentioned above, we have the following. + + Nil (w, n) stands for SHIFT^w (ID n) where ID n is a compact form of identity + substitution, defined inductively as + + ID 0 := NIL + ID (S n) := CONS (Var 1, SHIFT (ID n)) + + Cons (h, t, s) stands for (t @ s) and h is the total number of values in the + tree t. In particular, it is always of the form 2^n - 1 for some n. +*) + +(* Returns the number of shifts contained in the whole tree. *) +let eval = function +| Leaf (w, _) -> w +| Node (w1, _, _, _, w2) -> cmp w1 w2 + +let leaf x = Leaf (idn, x) +let node x t1 t2 = Node (idn, x, t1, t2, cmp (eval t1) (eval t2)) + +let rec tree_get h w t i = match t with +| Leaf (w', x) -> + let w = cmp w w' in + if i = 0 then w, Inl x else assert false +| Node (w', x, t1, t2, _) -> + let w = cmp w w' in + if i = 0 then w, Inl x + else + let h = h / 2 in + if i <= h then tree_get h w t1 (i - 1) + else tree_get h (cmp w (eval t1)) t2 (i - h - 1) + +let rec get w l i = match l with +| Nil (w', n) -> + let w = cmp w w' in + if i < n then w, Inl (Var (i + 1)) + else n + w, Inr (i - n) (* FIXME: double check *) +| Cons (h, t, rem) -> + if i < h then tree_get h w t i else get (cmp (eval t) w) rem (i - h) + +let get l i = get idn l i + +let tree_write w = function +| Leaf (w', x) -> Leaf (cmp w w', x) +| Node (w', x, t1, t2, wt) -> Node (cmp w w', x, t1, t2, wt) + +let write w l = match l with +| Nil (w', n) -> Nil (cmp w w', n) +| Cons (h, t, rem) -> Cons (h, tree_write w t, rem) + +let cons x l = match l with +| Cons (h1, t1, Cons (h2, t2, rem)) -> + if Int.equal h1 h2 then Cons (1 + h1 + h2, node x t1 t2, rem) + else Cons (1, leaf x, l) +| _ -> Cons (1, leaf x, l) + +let expand_rel n s = + let k, v = get s (n - 1) in + match v with + | Inl (Arg v) -> Inl (k, v) + | Inl (Var i) -> Inr (k + i, None) + | Inr i -> Inr (k + i + 1, Some (i + 1)) + +let is_subs_id = function +| Nil (w, _) -> Int.equal w 0 +| Cons (_, _, _) -> false + +let subs_cons v s = cons (Arg v) s + +let rec push_vars i s = + if Int.equal i 0 then s + else push_vars (pred i) (cons (Var i) s) + +let subs_liftn n s = + if Int.equal n 0 then s + else match s with + | Nil (0, m) -> Nil (0, m + n) (* Preserve identity substitutions *) + | Nil _ | Cons _ -> + let s = write n s in + push_vars n s + +let subs_lift s = match s with +| Nil (0, m) -> Nil (0, m + 1) (* Preserve identity substitutions *) +| Nil _ | Cons _ -> + cons (Var 1) (write 1 s) + +let subs_id n = Nil (0, n) + +let subs_shft (n, s) = write n s + +(* pop is the n-ary tailrec variant of a function whose typing rules would be + given as follows. Assume Γ ⊢ e : Δ, A, then + - Γ := Ξ, A, Ω for some Ξ and Ω with |Ω| := fst (pop e) + - Ξ ⊢ snd (pop e) : Δ +*) +let rec pop n i e = + if Int.equal n 0 then i, e + else match e with + | ELID -> i, e + | ELLFT (k, e) -> + if k <= n then pop (n - k) i e + else i, ELLFT (k - n, e) + | ELSHFT (e, k) -> pop n (i + k) e + +let apply mk e = function +| Var i -> Var (reloc_rel i e) +| Arg v -> Arg (mk e v) + +let rec tree_map mk e = function +| Leaf (w, x) -> + let (n, e) = pop w 0 e in + Leaf (w + n, apply mk e x), e +| Node (w, x, t1, t2, _) -> + let (n, e) = pop w 0 e in + let x = apply mk e x in + let t1, e = tree_map mk e t1 in + let t2, e = tree_map mk e t2 in + Node (w + n, x, t1, t2, cmp (eval t1) (eval t2)), e + +let rec lift_id e n = match e with +| ELID -> Nil (0, n) +| ELSHFT (e, k) -> write k (lift_id e n) +| ELLFT (k, e) -> + if k <= n then subs_liftn k (lift_id e (n - k)) + else assert false + +let rec lift_subst mk e s = match s with +| Nil (w, m) -> + let (n, e) = pop w 0 e in + write (w + n) (lift_id e m) +| Cons (h, t, rem) -> + let t, e = tree_map mk e t in + let rem = lift_subst mk e rem in + Cons (h, t, rem) diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 4239e42adc..8ff29ab07a 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -11,28 +11,38 @@ (** Explicit substitutions *) (** {6 Explicit substitutions } *) -(** Explicit substitutions of type ['a]. - - ESID(n) = %n END bounded identity - - CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution - (beware of the order: indice 1 is substituted by tn) - - SHIFT(n,S) = (^n o S) terms in S are relocated with n vars - - LIFT(n,S) = (%n S) stands for ((^n o S).n...1) - (corresponds to S crossing n binders) *) -type 'a subs = private - | ESID of int - | CONS of 'a array * 'a subs - | SHIFT of int * 'a subs - | LIFT of int * 'a subs +(** Explicit substitutions for some type of terms ['a]. + + Assuming terms enjoy a notion of typability Γ ⊢ t : A, where Γ is a + telescope and A a type, substitutions can be typed as Γ ⊢ σ : Δ, where + as a first approximation σ is a list of terms u₁; ...; uₙ s.t. + Δ := (x₁ : A₁), ..., (xₙ : Aₙ) and Γ ⊢ uᵢ : Aᵢ{u₁...uᵢ₋₁} for all 1 ≤ i ≤ n. + + Substitutions can be applied to terms as follows, and furthermore + if Γ ⊢ σ : Δ and Δ ⊢ t : A, then Γ ⊢ t{σ} : A{σ}. + + We make the typing rules explicit below, but we omit the explicit De Bruijn + fidgetting and leave relocations implicit in terms and types. + +*) +type 'a subs (** Derived constructors granting basic invariants *) + +(** Assuming |Γ| = n, Γ ⊢ subs_id n : Γ *) val subs_id : int -> 'a subs -val subs_cons: 'a array * 'a subs -> 'a subs + +(** Assuming Γ ⊢ σ : Δ and Γ ⊢ t : A{σ}, then Γ ⊢ subs_cons t σ : Δ, A *) +val subs_cons: 'a -> 'a subs -> 'a subs + +(** Assuming Γ ⊢ σ : Δ and |Ξ| = n, then Γ, Ξ ⊢ subs_shft (n, σ) : Δ *) val subs_shft: int * 'a subs -> 'a subs + +(** Unary variant of {!subst_liftn}. *) val subs_lift: 'a subs -> 'a subs -val subs_liftn: int -> 'a subs -> 'a subs -(** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) -val subs_shift_cons: int * 'a subs * 'a array -> 'a subs +(** Assuming Γ ⊢ σ : Δ and |Ξ| = n, then Γ, Ξ ⊢ subs_liftn n σ : Δ, Ξ *) +val subs_liftn: int -> 'a subs -> 'a subs (** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution [subs]. The result is either (Inl(lams,v)) when the variable is @@ -51,7 +61,6 @@ val is_subs_id: 'a subs -> bool mk_clos is used when a closure has to be created, i.e. when s1 is applied on an element of s2. *) -val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {6 Compact representation } *) (** Compact representation of explicit relocations @@ -60,6 +69,10 @@ val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs Invariant ensured by the private flag: no lift contains two consecutive [ELSHFT] nor two consecutive [ELLFT]. + + Relocations are a particular kind of substitutions that only contain + variables. In particular, [el_*] enjoys the same typing rules as the + equivalent substitution function [subs_*]. *) type lift = private | ELID @@ -77,5 +90,7 @@ val is_lift_id : lift -> bool substitution equivalent to applying el then s. Argument mk_clos is used when a closure has to be created, i.e. when el is applied on an element of s. + + That is, if Γ ⊢ e : Δ and Δ ⊢ σ : Ξ, then Γ ⊢ lift_subst mk e σ : Ξ. *) val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 18f16f427d..b27c53ef0f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -102,7 +102,7 @@ let decompose_Llam_Llet lam = let subst_id = subs_id 0 let lift = subs_lift let liftn = subs_liftn -let cons v subst = subs_cons([|v|], subst) +let cons v subst = subs_cons v subst let shift subst = subs_shft (1, subst) (* Linked code location utilities *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 85e24f87b7..802a32b0e7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -198,7 +198,7 @@ let type_of_apply env func funt argsv argstv = let argt = argstv.(i) in let c1 = term_of_fconstr c1 in begin match conv_leq false env argt c1 with - | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) + | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons (inject arg) e) c2) | exception NotConvertible -> error_cant_apply_bad_type env (i+1,c1,argt) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 6b47dfc61d..6b2519918a 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -17,6 +17,7 @@ val maxuint31 : t val of_int : int -> t val to_int2 : t -> int * int (* msb, lsb *) val of_int64 : Int64.t -> t +val to_int64 : t -> Int64.t (* val of_uint : int -> t *) @@ -32,7 +33,6 @@ val hash : t -> int (* conversion to a string *) val to_string : t -> string -val of_string : string -> t val compile : t -> string diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 5b2d934b5d..988611df3e 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -23,9 +23,10 @@ let one = Int64.one (* conversion from an int *) let mask63 i = Int64.logand i maxuint63 -let of_int i = Int64.of_int i +let of_int i = mask63 (Int64.of_int i) let to_int2 i = (Int64.to_int (Int64.shift_right_logical i 31), Int64.to_int i) -let of_int64 i = i +let of_int64 = mask63 +let to_int64 i = i let to_int_min n m = if Int64.(compare n (of_int m)) < 0 then Int64.to_int n else m @@ -41,13 +42,6 @@ let hash i = (* conversion of an uint63 to a string *) let to_string i = Int64.to_string i -let of_string s = - let i64 = Int64.of_string s in - if Int64.compare Int64.zero i64 <= 0 - && Int64.compare i64 maxuint63 <= 0 - then i64 - else raise (Failure "Int63.of_string") - (* Compiles an unsigned int to OCaml code *) let compile i = Printf.sprintf "Uint63.of_int64 (%LiL)" i @@ -72,12 +66,12 @@ let l_xor x y = Int64.logxor x y (* addition of int63 *) let add x y = mask63 (Int64.add x y) -let addcarry x y = add (add x y) Int64.one +let addcarry x y = mask63 Int64.(add (add x y) one) (* subtraction *) let sub x y = mask63 (Int64.sub x y) -let subcarry x y = sub (sub x y) Int64.one +let subcarry x y = mask63 Int64.(sub (sub x y) one) (* multiplication *) let mul x y = mask63 (Int64.mul x y) diff --git a/kernel/uint63_63.ml b/kernel/uint63_63.ml index 21f57e2bfb..8d052d6593 100644 --- a/kernel/uint63_63.ml +++ b/kernel/uint63_63.ml @@ -25,7 +25,8 @@ let of_int i = i let to_int2 i = (0,i) -let of_int64 _i = assert false +let of_int64 = Int64.to_int +let to_int64 = to_uint64 let of_float = int_of_float @@ -39,13 +40,6 @@ let hash i = i (* conversion of an uint63 to a string *) let to_string i = Int64.to_string (to_uint64 i) -let of_string s = - let i64 = Int64.of_string s in - if Int64.compare Int64.zero i64 <= 0 - && Int64.compare i64 maxuint63 <= 0 - then Int64.to_int i64 - else raise (Failure "Int64.of_string") - (* Compiles an unsigned int to OCaml code *) let compile i = Printf.sprintf "Uint63.of_int (%i)" i diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 9cca204e8c..390fa58883 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -179,7 +179,7 @@ let decompose_Llam lam = let subst_id = subs_id 0 let lift = subs_lift let liftn = subs_liftn -let cons v subst = subs_cons([|v|], subst) +let cons v subst = subs_cons v subst let shift subst = subs_shft (1, subst) (* A generic map function *) diff --git a/lib/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/parsing/pcoq.ml b/parsing/pcoq.ml index a482e044d8..cc9e1bb31d 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -175,7 +175,21 @@ let rec remove_grammars n = camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries; remove_grammars (n - 1) -(* Parse a string, does NOT check if the entire string was read *) +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 + let act = fun _ x loc -> 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) *) let parse_string f ?loc x = let strm = Stream.of_string x in @@ -289,6 +303,7 @@ module Constr = let constr = Entry.create "constr" let term = Entry.create "term" let operconstr = term + let constr_eoi = eoi_entry constr let lconstr = Entry.create "lconstr" let binder_constr = Entry.create "binder_constr" let ident = Entry.create "ident" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 8bff5cfd94..06d05a4797 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -120,6 +120,7 @@ end (** Parse a string *) val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a +val eoi_entry : 'a Entry.t -> 'a Entry.t type gram_universe [@@deprecated "Deprecated in 8.13"] [@@@ocaml.warning "-3"] @@ -180,6 +181,7 @@ module Prim : module Constr : sig val constr : constr_expr Entry.t + val constr_eoi : constr_expr Entry.t val lconstr : constr_expr Entry.t val binder_constr : constr_expr Entry.t val term : constr_expr Entry.t diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 23a7b89d2c..499c9684b2 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -429,55 +429,55 @@ let cc_tactic depth additionnal_terms = match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); - match reason with - Discrimination (i,ipac,j,jpac) -> - let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in - let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac cstr p - | Incomplete -> - let open Glob_term in - let env = Proofview.Goal.env gl in - let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in - let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in - let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env 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 ++ - 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/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0b5d36b845..4a2c298caa 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -608,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 -> @@ -628,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 diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 80c13a3698..196a68e67c 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -47,6 +47,8 @@ let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" (* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + let () = let open Stdarg in let open Tacarg in diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 73bce84d18..c0bf6b9f76 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -40,3 +40,4 @@ val tactic_expr : raw_tactic_expr Entry.t [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t +val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 77162ce89a..59533eb3e3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -855,26 +855,20 @@ let coerce env cstr res = let res = { res with rew_evars = evars } in apply_constraint env res.rew_car rel prf cstr res -let apply_rule unify loccs : int pure_strategy = - let (nowhere_except_in,occs) = convert_occs loccs in - let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) - in - { strategy = fun { state = occ ; env ; +let apply_rule unify : occurrences_count pure_strategy = + { strategy = fun { state = occs ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar (goalevars evars) t then None else unify env evars t in match unif with - | None -> (occ, Fail) + | None -> (occs, Fail) | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) + let b, occs = update_occurrence_counter occs in + if not b then (occs, Fail) + else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occs, Identity) else let res = { rew with rew_car = ty } in let res = Success (coerce env cstr res) in - (occ, res) + (occs, res) } let apply_lemma l2r flags oc by loccs : strategy = { strategy = @@ -890,9 +884,10 @@ let apply_lemma l2r flags oc by loccs : strategy = { strategy = | None -> None | Some rew -> Some rew in - let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; + let loccs, res = (apply_rule unify).strategy { input with + state = initialize_occurrence_counter loccs ; evars } in + check_used_occurrences loccs; (), res } @@ -1423,12 +1418,13 @@ let rewrite_with l2r flags c occs : strategy = { strategy = let (sigma, rew) = refresh_hypinfo env sigma c in unify_eqn rew l2r flags env (sigma, cstrs) None t in - let app = apply_rule unify occs in + let app = apply_rule unify in let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat.strategy { input with state = 0 } in + let occs, res = strat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; ((), res) } @@ -2076,11 +2072,12 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.enter begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in - let app = apply_rule unify occs in + let app = apply_rule unify in let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in let substrat = Strategies.fix recstrat in let strat = { strategy = fun ({ state = () } as input) -> - let _, res = substrat.strategy { input with state = 0 } in + let occs, res = substrat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; (), res } in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 4c1fe6417e..9abdc2ddbe 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -429,7 +429,15 @@ let pr_value env v = | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) -let error_ltac_variable ?loc id env v s = - CErrors.user_err ?loc (str "Ltac variable " ++ Id.print id ++ +exception CoercionError of Id.t * (Environ.env * Evd.evar_map) option * Val.t * string + +let () = CErrors.register_handler begin function +| CoercionError (id, env, v, s) -> + Some (str "Ltac variable " ++ Id.print id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") +| _ -> None +end + +let error_ltac_variable ?loc id env v s = + Loc.raise ?loc (CoercionError (id, env, v, s)) diff --git a/plugins/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 61643c2aa3..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' @@ -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 cd219838d5..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 @@ -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 fdfba48024..aeb6b3cf85 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -232,7 +232,7 @@ let rec get_evalref env sigma c = match EConstr.kind sigma c with (* 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 95c8024e89..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. *) 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/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 ea014250ca..2a21049c6e 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,10 +80,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 = '(' + | _ -> 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 = @@ -102,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 = @@ -153,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)) @@ -803,25 +775,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 +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 " ++ prl_term 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 " ++ 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 - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_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 @@ -834,16 +796,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). *) @@ -851,19 +850,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 @@ -891,8 +890,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) @@ -902,7 +901,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) @@ -910,23 +909,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 -> @@ -941,12 +941,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") @@ -974,17 +974,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 && @@ -1027,7 +1027,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 && @@ -1058,7 +1058,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) -> @@ -1072,9 +1072,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 @@ -1255,16 +1258,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/pretyping/cases.ml b/pretyping/cases.ml index a793e217d4..d2859b1b4e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -46,8 +46,10 @@ module NamedDecl = Context.Named.Declaration type pattern_matching_error = | BadPattern of constructor * constr | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int + | WrongNumargConstructor of + {cstr:constructor; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} + | WrongNumargInductive of + {ind:inductive; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} | UnusedClause of cases_pattern list | NonExhaustive of cases_pattern list | CannotInferPredicate of (constr * types) array @@ -65,11 +67,13 @@ let error_bad_constructor ?loc env cstr ind = raise_pattern_matching_error ?loc (env, Evd.empty, BadConstructor (cstr,ind)) -let error_wrong_numarg_constructor ?loc env c n = - raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargConstructor(c,n)) +let error_wrong_numarg_constructor ?loc env ~cstr ~expanded ~nargs ~expected_nassums ~expected_ndecls = + raise_pattern_matching_error ?loc (env, Evd.empty, + WrongNumargConstructor {cstr; expanded; nargs; expected_nassums; expected_ndecls}) -let error_wrong_numarg_inductive ?loc env c n = - raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargInductive(c,n)) +let error_wrong_numarg_inductive ?loc env ~ind ~expanded ~nargs ~expected_nassums ~expected_ndecls = + raise_pattern_matching_error ?loc (env, Evd.empty, + WrongNumargInductive {ind; expanded; nargs; expected_nassums; expected_ndecls}) let list_try_compile f l = let rec aux errors = function @@ -519,13 +523,18 @@ let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in - if Int.equal (List.length args) nb_args_constr then pat + let nargs = List.length args in + if Int.equal nargs nb_args_constr then pat else try let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) in DAst.make ?loc @@ PatCstr (cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor ?loc env cstr nb_args_constr + let nlet = List.count (function LocalDef _ -> true | _ -> false) ci.cs_args in + (* In practice, this is already checked at interning *) + error_wrong_numarg_constructor ?loc env ~cstr + (* as if not expanded: *) ~expanded:false ~nargs ~expected_nassums:nb_args_constr + ~expected_ndecls:(nb_args_constr + nlet) else (* Try to insert a coercion *) try diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9a986bc14c..ade1fbf3d3 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -23,17 +23,21 @@ open Evardefine type pattern_matching_error = | BadPattern of constructor * constr | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int + | WrongNumargConstructor of + {cstr:constructor; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} + | WrongNumargInductive of + {ind:inductive; expanded:bool; nargs:int; expected_nassums:int; expected_ndecls:int} | UnusedClause of cases_pattern list | NonExhaustive of cases_pattern list | CannotInferPredicate of (constr * types) array exception PatternMatchingError of env * evar_map * pattern_matching_error -val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a +val error_wrong_numarg_constructor : + ?loc:Loc.t -> env -> cstr:constructor -> expanded:bool -> nargs:int -> expected_nassums:int -> expected_ndecls:int -> 'a -val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a +val error_wrong_numarg_inductive : + ?loc:Loc.t -> env -> ind:inductive -> expanded:bool -> nargs:int -> expected_nassums:int -> expected_ndecls:int -> 'a val irrefutable : env -> cases_pattern -> bool diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 2661000a39..bada2c3a60 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -111,15 +111,20 @@ let shift_value n v = * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1})) * -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti) *) + +let rec mk_fix_subs make_body n env i = + if Int.equal i n then env + else mk_fix_subs make_body n (subs_cons (make_body i) env) (i + 1) + let contract_fixp env ((reci,i),(_,_,bds as bodies)) = let make_body j = FIXP(((reci,j),bodies), env, [||]) in let n = Array.length bds in - subs_cons(Array.init n make_body, env), bds.(i) + mk_fix_subs make_body n env 0, bds.(i) let contract_cofixp env (i,(_,_,bds as bodies)) = let make_body j = COFIXP((j,bodies), env, [||]) in let n = Array.length bds in - subs_cons(Array.init n make_body, env), bds.(i) + mk_fix_subs make_body n env 0, bds.(i) let make_constr_ref n k t = match k with @@ -401,6 +406,10 @@ let rec strip_app = function | APP (args,st) -> APP (args,strip_app st) | s -> TOP +let rec subs_consn v i n s = + if Int.equal i n then s + else subs_consn v (i + 1) n (subs_cons v.(i) s) + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -456,7 +465,7 @@ let rec norm_head info env t stack = (* New rule: for Cbv, Delta does not apply to locally bound variables or red_set info.reds fDELTA *) - let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in + let env' = subs_cons (cbv_stack_term info TOP env b) env in norm_head info env' c stack else (CBN(t,env), stack) (* Should we consider a commutative cut ? *) @@ -526,14 +535,14 @@ and cbv_stack_value info env = function when red_set info.reds fBETA -> let nargs = Array.length args in if nargs == nlams then - cbv_stack_term info stk (subs_cons(args,env)) b + cbv_stack_term info stk (subs_consn args 0 nargs env) b else if nlams < nargs then - let env' = subs_cons(Array.sub args 0 nlams, env) in + let env' = subs_consn args 0 nlams env in let eargs = Array.sub args nlams (nargs-nlams) in cbv_stack_term info (APP(eargs,stk)) env' b else let ctxt' = List.skipn nargs ctxt in - LAM(nlams-nargs,ctxt', b, subs_cons(args,env)) + LAM(nlams-nargs,ctxt', b, subs_consn args 0 nargs env) (* a Fix applied enough -> IOTA *) | (FIXP(fix,env,[||]), stk) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a3f1c0b004..0e69b814c7 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -528,10 +528,9 @@ let sub_match ?(closed=true) env sigma pat c = let sub = subargs env types @ subargs env' bodies in try_aux sub next_mk_ctx next | Proj (p,c') -> - begin try - let term = Retyping.expand_projection env sigma p c' [] in - aux env term mk_ctx next - with Retyping.RetypeError _ -> next () + begin match Retyping.expand_projection env sigma p c' [] with + | term -> aux env term mk_ctx next + | exception Retyping.RetypeError _ -> next () end | Array(u, t, def, ty) -> let next_mk_ctx = function diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index d0b724b755..4b0974ae03 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 = @@ -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,49 @@ 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) + 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 +400,51 @@ 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 -> 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 @@ -575,31 +582,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 @@ -617,32 +628,39 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty 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 @@ -663,8 +681,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 @@ -672,21 +690,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 *) @@ -716,6 +745,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' -> @@ -736,7 +766,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 *) @@ -764,7 +796,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 @@ -776,7 +808,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 @@ -976,10 +1018,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 @@ -1033,10 +1075,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 @@ -1131,7 +1173,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 diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 44414aa6a0..f9f6f74a66 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -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 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..52e3364109 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -21,42 +21,15 @@ module NamedDecl = Context.Named.Declaration (** Processing occurrences *) -type occurrence_error = - | InvalidOccurrence of int list - | IncorrectInValueOccurrence of Id.t - -let explain_invalid_occurrence l = - let l = List.sort_uniquize Int.compare l in - str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") - ++ prlist_with_sep spc int l ++ str "." - let explain_incorrect_in_value_occurrence id = Id.print id ++ str " has no value." -let explain_occurrence_error = function - | InvalidOccurrence l -> explain_invalid_occurrence l - | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id - -let error_occurrences_error e = - user_err (explain_occurrence_error e) - -let error_invalid_occurrence occ = - error_occurrences_error (InvalidOccurrence occ) - -let check_used_occurrences nbocc (nowhere_except_in,locs) = - let rest = List.filter (fun o -> o >= nbocc) locs in - match rest with - | [] -> () - | _ -> error_occurrences_error (InvalidOccurrence rest) - let proceed_with_occurrences f occs x = match occs with | NoOccurrences -> x | occs -> - let plocs = Locusops.convert_occs occs in - assert (List.for_all (fun x -> x >= 0) (snd plocs)); - let (nbocc,x) = f 1 x in - check_used_occurrences nbocc plocs; + let (occs,x) = f (Locusops.initialize_occurrence_counter occs) x in + Locusops.check_used_occurrences occs; x (** Applying a function over a named_declaration with an hypothesis @@ -70,7 +43,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> - error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) + user_err (explain_incorrect_in_value_occurrence id.Context.binder_name) | LocalAssum (id,typ), _ -> let acc,typ = f acc typ in acc, LocalAssum (id,typ) | LocalDef (id,body,typ), InHypTypeOnly -> @@ -101,43 +74,43 @@ type 'a testing_function = { means all occurrences except the ones in l *) let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref occ in + let count = ref (Locusops.initialize_occurrence_counter occs) in let nested = ref false in - let add_subst t subst = + let add_subst pos t subst = try test.testing_state <- test.merge_fun subst test.testing_state; - test.last_found <- Some ((cl,!pos),t) + test.last_found <- Some ((cl,pos),t) with NotUnifiable e when not like_first -> let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,e)) in let rec substrec k t = - if nowhere_except_in && !pos > maxocc then t else + if Locusops.occurrences_done !count then t else try let subst = test.match_fun test.testing_state t in - if Locusops.is_selected !pos occs then + let selected, count' = Locusops.update_occurrence_counter !count in count := count'; + if selected then + let pos = Locusops.current_occurrence !count in (if !nested then begin (* in case it is nested but not later detected as unconvertible, as when matching "id _" in "id (id 0)" *) let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,None)) + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,None)) end; - add_subst t subst; incr pos; + add_subst pos t subst; (* Check nested matching subterms *) - if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then + if Locusops.more_specific_occurrences !count then begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) else - (incr pos; subst_below k t) + subst_below k t with NotUnifiable _ -> subst_below k t and subst_below k t = map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in - (!pos, t') + (!count, t') let replace_term_occ_modulo evd occs test bywhat t = let occs',like_first = diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 436b730a88..1ddae01e2b 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -65,6 +65,3 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> constr -> named_declaration -> named_declaration * evar_map - -(** Miscellaneous *) -val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index a957bc0fcd..9f93e5e6c1 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -137,7 +137,7 @@ type cases_pattern_disjunction = [ `any ] cases_pattern_disjunction_g type 'a extended_glob_local_binder_r = | GLocalAssum of Name.t * binding_kind * 'a glob_constr_g - | GLocalDef of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g option + | GLocalDef of Name.t * 'a glob_constr_g * 'a glob_constr_g option | GLocalPattern of ('a cases_pattern_disjunction_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 23145b1629..bd875cf68b 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -245,6 +245,14 @@ let inductive_alldecls env (ind,u) = let inductive_alldecls_env env (ind,u) = inductive_alldecls env (ind,u) [@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] +let inductive_alltags env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.to_tags mip.mind_arity_ctxt + +let constructor_alltags env (ind,j) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.to_tags (fst mip.mind_nf_lc.(j-1)) + let constructor_has_local_defs env (indsp,j) = let (mib,mip) = Inductive.lookup_mind_specif env indsp in let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1e2bba9f73..3705d39280 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -138,6 +138,10 @@ val constructor_nrealdecls : env -> constructor -> int val constructor_nrealdecls_env : env -> constructor -> int [@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] +(** @return tags of all decls: true = assumption, false = letin *) +val inductive_alltags : env -> inductive -> bool list +val constructor_alltags : env -> constructor -> bool list + (** Is there local defs in params or args ? *) val constructor_has_local_defs : env -> constructor -> bool val inductive_has_local_defs : env -> inductive -> bool diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 86352eb79a..256d61a32b 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Locus (** Utilities on or_var *) @@ -27,12 +28,43 @@ let occurrences_map f = function if l' = [] then AllOccurrences else AllOccurrencesBut l' | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o -let convert_occs = function - | AtLeastOneOccurrence -> (false,[]) - | AllOccurrences -> (false,[]) - | AllOccurrencesBut l -> (false,l) - | NoOccurrences -> (true,[]) - | OnlyOccurrences l -> (true,l) +type occurrences_count = {current: int; remaining: int list; where: (bool * int)} + +let error_invalid_occurrence l = + CErrors.user_err Pp.(str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") + ++ prlist_with_sep spc int l ++ str ".") + +let initialize_occurrence_counter occs = + let (nowhere_except_in,occs) = + match occs with + | AtLeastOneOccurrence -> (false,[]) + | AllOccurrences -> (false,[]) + | AllOccurrencesBut l -> (false,List.sort_uniquize Int.compare l) + | NoOccurrences -> (true,[]) + | OnlyOccurrences l -> (true,List.sort_uniquize Int.compare l) in + let max = + match occs with + | n::_ when n <= 0 -> error_invalid_occurrence [n] + | [] -> 0 + | _ -> Util.List.last occs in + {current = 0; remaining = occs; where = (nowhere_except_in,max)} + +let update_occurrence_counter {current; remaining; where = (nowhere_except_in,_ as where)} = + let current = succ current in + match remaining with + | occ::remaining when Int.equal current occ -> (nowhere_except_in,{current;remaining;where}) + | _ -> (not nowhere_except_in,{current;remaining;where}) + +let check_used_occurrences {remaining} = + if not (Util.List.is_empty remaining) then error_invalid_occurrence remaining + +let occurrences_done {current; where = (nowhere_except_in,max)} = + nowhere_except_in && current > max + +let current_occurrence {current} = current + +let more_specific_occurrences {current; where = (_,max)} = + current <= max let is_selected occ = function | AtLeastOneOccurrence -> true diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 911ccc1a38..748bfbc252 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -20,13 +20,44 @@ val or_var_map : ('a -> 'b) -> 'a or_var -> 'b or_var val occurrences_map : ('a list -> 'b list) -> 'a occurrences_gen -> 'b occurrences_gen -(** From occurrences to a list of positions (or complement of positions) *) -val convert_occs : occurrences -> bool * int list +(** {6 Counting occurrences} *) + +type occurrences_count + (** A counter of occurrences associated to a list of occurrences *) + +(** Three basic functions to initialize, count, and conclude a loop + browsing over subterms *) + +val initialize_occurrence_counter : occurrences -> occurrences_count + (** Initialize an occurrence_counter *) + +val update_occurrence_counter : occurrences_count -> bool * occurrences_count + (** Increase the occurrence counter by one and tell if the current occurrence is selected *) + +val check_used_occurrences : occurrences_count -> unit + (** Increase the occurrence counter and tell if the current occurrence is selected *) + +(** Auxiliary functions about occurrence counters *) + +val current_occurrence : occurrences_count -> int + (** Tell the value of the current occurrence *) + +val occurrences_done : occurrences_count -> bool + (** Tell if there are no more occurrences to select and if the loop + can be shortcut *) + +val more_specific_occurrences : occurrences_count -> bool + (** Tell if there are no more occurrences to select (or unselect) + and if an inner loop can be shortcut *) + +(** {6 Miscellaneous} *) val is_selected : int -> occurrences -> bool val is_all_occurrences : 'a occurrences_gen -> bool +val error_invalid_occurrence : int list -> 'a + (** Usual clauses *) val allHypsAndConcl : 'a clause_expr diff --git a/pretyping/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..52f60fbc5e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -194,6 +194,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 +215,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) = @@ -267,12 +268,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 = @@ -293,7 +292,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 @@ -334,29 +333,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 +374,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 +386,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 @@ -930,14 +934,6 @@ let stack_red_of_state_red f = let f env sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f env sigma (x, Stack.empty))) in f -(* Drops the Cst_stack *) -let iterate_whd_gen flags env sigma s = - let rec aux t = - let (hd,sk) = whd_state_gen flags env sigma (t,Stack.empty) in - let whd_sk = Stack.map aux sk in - Stack.zip sigma (hd,whd_sk) - in aux s - let red_of_state_red f env sigma x = Stack.zip sigma (f env sigma (x,Stack.empty)) @@ -1192,11 +1188,15 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = let default_plain_instance_ident = Id.of_string "H" +type subst_fun = { sfun : metavariable -> EConstr.t } + (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) -let plain_instance sigma s c = +let plain_instance sigma s c = match s with +| None -> c +| Some s -> let rec irec n u = match EConstr.kind sigma u with - | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) + | Meta p -> (try lift n (s.sfun p) with Not_found -> u) | App (f,l) when isCast sigma f -> let (f,_,t) = destCast sigma f in let l' = Array.Fun1.Smart.map irec n l in @@ -1205,7 +1205,7 @@ let plain_instance sigma s c = (* Don't flatten application nodes: this is used to extract a proof-term from a proof-tree and we want to keep the structure of the proof-tree *) - (try let g = Metamap.find p s in + (try let g = s.sfun p in match EConstr.kind sigma g with | App _ -> let l' = Array.Fun1.Smart.map lift 1 l' in @@ -1216,12 +1216,11 @@ let plain_instance sigma s c = with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta sigma m -> - (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) + (try lift n (s.sfun (destMeta sigma m)) with Not_found -> u) | _ -> map_with_binders sigma succ irec n u in - if Metamap.is_empty s then c - else irec 0 c + irec 0 c (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] has (unfortunately) different subtle side effects: @@ -1423,23 +1422,41 @@ let is_arity env sigma c = (*************************************) (* Metas *) -let meta_value env evd mv = - let rec valrec mv = - match meta_opt_fvalue evd mv with - | Some (b,_) -> - let metas = Metamap.bind valrec b.freemetas in - instance env evd metas b.rebus - | None -> mkMeta mv +type meta_instance_subst = { + sigma : Evd.evar_map; + mutable cache : EConstr.t Metamap.t; +} + +let create_meta_instance_subst sigma = { + sigma; + cache = Metamap.empty; +} + +let eval_subst env subst = + let rec ans mv = + try Metamap.find mv subst.cache + with Not_found -> + match meta_opt_fvalue subst.sigma mv with + | None -> mkMeta mv + | Some (b, _) -> + let metas = + if Metaset.is_empty b.freemetas then None + else Some { sfun = ans } + in + let res = instance env subst.sigma metas b.rebus in + let () = subst.cache <- Metamap.add mv res subst.cache in + res in - valrec mv + { sfun = ans } -let meta_instance env sigma b = +let meta_instance env subst b = let fm = b.freemetas in if Metaset.is_empty fm then b.rebus else - let c_sigma = Metamap.bind (fun mv -> meta_value env sigma mv) fm in - instance env sigma c_sigma b.rebus + let sfun = eval_subst env subst in + instance env subst.sigma (Some sfun) b.rebus let nf_meta env sigma c = + let sigma = create_meta_instance_subst sigma in let cl = mk_freelisted c in meta_instance env sigma { cl with rebus = cl.rebus } diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index d404a7e414..ae93eb48b4 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -69,10 +69,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 +83,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 +140,6 @@ type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -type state_reduction_function = - env -> evar_map -> state -> state - -val pr_state : env -> evar_map -> state -> Pp.t - (** {6 Reduction Function Operators } *) val strong_with_flags : @@ -127,12 +147,6 @@ val strong_with_flags : (CClosure.RedFlags.reds -> reduction_function) val strong : reduction_function -> reduction_function -val whd_state_gen : - CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state - -val iterate_whd_gen : CClosure.RedFlags.reds -> - Environ.env -> Evd.evar_map -> constr -> constr - (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function @@ -166,24 +180,13 @@ val whd_all_stack : stack_reduction_function val whd_allnolet_stack : stack_reduction_function val whd_betalet_stack : stack_reduction_function -val whd_nored_state : state_reduction_function -val whd_beta_state : state_reduction_function -val whd_betaiota_state : state_reduction_function -val whd_betaiotazeta_state : state_reduction_function -val whd_all_state : state_reduction_function -val whd_allnolet_state : state_reduction_function -val whd_betalet_state : state_reduction_function - (** {6 Head normal forms } *) val whd_delta_stack : stack_reduction_function -val whd_delta_state : state_reduction_function val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function -val whd_betadeltazeta_state : state_reduction_function val whd_betadeltazeta : reduction_function val whd_zeta_stack : stack_reduction_function -val whd_zeta_state : state_reduction_function val whd_zeta : reduction_function val shrink_eta : Environ.env -> constr -> constr @@ -269,11 +272,24 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> (** {6 Heuristic for Conversion with Evar } *) +type state = constr * constr Stack.t + +type state_reduction_function = + env -> evar_map -> state -> state + +val pr_state : env -> evar_map -> state -> Pp.t + +val whd_nored_state : state_reduction_function + val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state + TransparentState.t -> state_reduction_function (** {6 Meta-related reduction functions } *) -val meta_instance : env -> evar_map -> constr freelisted -> constr +type meta_instance_subst + +val create_meta_instance_subst : Evd.evar_map -> meta_instance_subst + +val meta_instance : env -> meta_instance_subst -> constr freelisted -> constr val nf_meta : env -> evar_map -> constr -> constr exception AnomalyInConversion of exn diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9cf7119709..c705ac16e7 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1046,28 +1046,23 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref 1 in + let count = ref (Locusops.initialize_occurrence_counter occs) in (* FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = - if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t + if Locusops.occurrences_done !count then (* Shortcut *) t else try let subst = if byhead then matches_head env sigma c t else Constr_matching.matches env sigma c t in - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; + let ok, count' = Locusops.update_occurrence_counter !count in count := count'; if ok then begin if Option.has_some nested then - user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (Locusops.current_occurrence !count) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) - if locs != [] then - ignore (traverse_below (Some (!pos-1)) envc t); + if Locusops.more_specific_occurrences !count then + ignore (traverse_below (Some (Locusops.current_occurrence !count)) envc t); let (evm, t) = (f subst) env !evd t in (evd := evm; t) end @@ -1087,7 +1082,7 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> (traverse nested) envc sigma t in let t' = traverse None (env,c) t in - if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; + Locusops.check_used_occurrences !count; (!evd, t') end @@ -1105,28 +1100,25 @@ let match_constr_evaluable_ref sigma c evref = | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None -let substlin env sigma evalref n (nowhere_except_in,locs) c = - let maxocc = List.fold_right max locs 0 in - let pos = ref n in - assert (List.for_all (fun x -> x >= 0) locs); +let substlin env sigma evalref occs c = + let count = ref (Locusops.initialize_occurrence_counter occs) in let value u = value_of_evaluable_ref env evalref u in let rec substrec () c = - if nowhere_except_in && !pos > maxocc then c + if Locusops.occurrences_done !count then c else match match_constr_evaluable_ref sigma c evalref with | Some u -> - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value u else c + let ok, count' = Locusops.update_occurrence_counter !count in + count := count'; + if ok then value u else c | None -> map_constr_with_binders_left_to_right sigma (fun _ () -> ()) substrec () c in let t' = substrec () c in - (!pos, t') + Locusops.check_used_occurrences !count; + (Locusops.current_occurrence !count, t') let string_of_evaluable_ref env = function | EvalVarRef id -> Id.to_string id @@ -1154,23 +1146,14 @@ let unfold env sigma name c = * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = - let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in - if Int.equal nbocc 1 then + match occs with + | NoOccurrences -> c + | AllOccurrences -> unfold env sigma name c + | OnlyOccurrences _ | AllOccurrencesBut _ | AtLeastOneOccurrence -> + let (occ,uc) = substlin env sigma name occs c in + if Int.equal occ 0 then user_err Pp.(str ((string_of_evaluable_ref env name)^" does not occur.")); - let rest = List.filter (fun o -> o >= nbocc) locs in - let () = match rest with - | [] -> () - | _ -> error_invalid_occurrence rest - in nf_betaiotazeta env sigma uc - in - match occs with - | NoOccurrences -> c - | AllOccurrences -> unfold env sigma name c - | OnlyOccurrences l -> unfo true l - | AllOccurrencesBut l -> unfo false l - | AtLeastOneOccurrence -> unfo false [] (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = diff --git a/pretyping/typing.ml b/pretyping/typing.ml index aeb3873de7..e3e5244a8c 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -33,7 +33,7 @@ let meta_type env evd mv = let ty = try Evd.meta_ftype evd mv with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in - meta_instance env evd ty + meta_instance env (create_meta_instance_subst evd) ty let inductive_type_knowing_parameters env sigma (ind,u) jl = let u = Unsafe.to_instance u in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 1c24578a1c..3d3010d1a4 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1070,10 +1070,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - let f1l1 = whd_nored_state curenv sigma (cM,Stack.empty) in - if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state curenv sigma (cN,Stack.empty) in - solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn + if is_open_canonical_projection curenv sigma cM then + solve_canonical_projection curenvnb pb opt cM cN substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in @@ -1086,14 +1084,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else try f1 () with e when precatchable_exception e -> if isApp_or_Proj sigma cN then - let f2l2 = whd_nored_state curenv sigma (cN, Stack.empty) in - if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state curenv sigma (cM, Stack.empty) in - solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn + if is_open_canonical_projection curenv sigma cN then + solve_canonical_projection curenvnb pb opt cN cM substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) = + and solve_canonical_projection curenvnb pb opt cM cN (sigma,ms,es) = + let f1l1 = whd_nored_state (fst curenvnb) sigma (cM,Stack.empty) in + let f2l2 = whd_nored_state (fst curenvnb) sigma (cN,Stack.empty) in let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 387f0f6f5f..00ac5a0624 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -37,15 +37,28 @@ type clausenv = { env : env; evd : evar_map; templval : constr freelisted; - templtyp : constr freelisted } + templtyp : constr freelisted; + cache : Reductionops.meta_instance_subst; +} + +let mk_clausenv env evd templval templtyp = { + env; evd; templval; templtyp; cache = create_meta_instance_subst evd; +} + +let update_clenv_evd clenv evd = + mk_clausenv clenv.env evd clenv.templval clenv.templtyp let cl_env ce = ce.env let cl_sigma ce = ce.evd -let clenv_term clenv c = meta_instance clenv.env clenv.evd c -let clenv_meta_type clenv mv = Typing.meta_type clenv.env clenv.evd mv -let clenv_value clenv = meta_instance clenv.env clenv.evd clenv.templval -let clenv_type clenv = meta_instance clenv.env clenv.evd clenv.templtyp +let clenv_term clenv c = meta_instance clenv.env clenv.cache c +let clenv_meta_type clenv mv = + let ty = + try Evd.meta_ftype clenv.evd mv + with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in + meta_instance clenv.env clenv.cache ty +let clenv_value clenv = meta_instance clenv.env clenv.cache clenv.templval +let clenv_type clenv = meta_instance clenv.env clenv.cache clenv.templtyp let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -67,7 +80,8 @@ let clenv_push_prod cl = { templval = mk_freelisted def; templtyp = mk_freelisted concl; evd = e'; - env = cl.env } + env = cl.env; + cache = create_meta_instance_subst e' } | _ -> raise NotExtensibleClause in clrec typ @@ -109,7 +123,8 @@ let mk_clenv_from_env env sigma n (c,cty) = { templval = mk_freelisted (applist (c,args)); templtyp = mk_freelisted concl; evd = evd; - env = env } + env = env; + cache = create_meta_instance_subst evd } let mk_clenv_from_n gls n (c,cty) = let env = Proofview.Goal.env gls in @@ -158,7 +173,7 @@ let clenv_assign mv rhs clenv = clenv else let st = (Conv,TypeNotProcessed) in - {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} + update_clenv_evd clenv (meta_assign mv (rhs_fls.rebus,st) clenv.evd) with Not_found -> user_err Pp.(str "clenv_assign: undefined meta") @@ -202,19 +217,19 @@ let clenv_assign mv rhs clenv = In any case, we respect the order given in A. *) -let clenv_metas_in_type_of_meta env evd mv = - (mk_freelisted (meta_instance env evd (meta_ftype evd mv))).freemetas +let clenv_metas_in_type_of_meta clenv mv = + (mk_freelisted (meta_instance clenv.env clenv.cache (meta_ftype clenv.evd mv))).freemetas let dependent_in_type_of_metas clenv mvs = List.fold_right - (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.env clenv.evd mv)) + (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv mv)) mvs Metaset.empty let dependent_closure clenv mvs = let rec aux mvs acc = Metaset.fold (fun mv deps -> - let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.env clenv.evd mv in + let metas_of_meta_type = clenv_metas_in_type_of_meta clenv mv in aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) mvs acc in aux mvs mvs @@ -297,11 +312,10 @@ let meta_reducible_instance env evd b = else irec b.rebus let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = - { clenv with - evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } + update_clenv_evd clenv (w_unify ~flags clenv.env clenv.evd cv_pb t1 t2) let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv = - { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } + update_clenv_evd clenv (w_unify_meta_types ~flags:flags clenv.env clenv.evd) let clenv_unique_resolver_gen ?(flags=default_unify_flags ()) clenv concl = if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.env clenv.evd clenv.templtyp.rebus))) then @@ -414,11 +428,13 @@ let fchain_flags () = let clenv_fchain ?with_univs ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) + let evd = meta_merge ?with_univs nextclenv.evd clenv.evd in let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = meta_merge ?with_univs nextclenv.evd clenv.evd; - env = nextclenv.env } in + evd; + env = nextclenv.env; + cache = create_meta_instance_subst evd } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = clenv_unify ~flags CUMUL @@ -538,7 +554,7 @@ let clenv_assign_binding clenv k c = let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in let c_typ = nf_betaiota clenv.env clenv.evd (clenv_get_type_of clenv c) in let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in - { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd } + update_clenv_evd clenv' (meta_assign k (c,(Conv,status)) clenv'.evd) let clenv_match_args bl clenv = if List.is_empty bl then @@ -640,7 +656,7 @@ let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = Typeclasses.make_unresolvables (fun x -> true) evd' else clenv.evd in - let clenv = { clenv with evd = evd' } in + let clenv = update_clenv_evd clenv evd' in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS (Evd.clear_metas evd')) (refiner ~check:false EConstr.Unsafe.(to_constr (clenv_cast_meta clenv (clenv_value clenv)))) diff --git a/proofs/clenv.mli b/proofs/clenv.mli index a72c8c5e1f..6e472da452 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -22,14 +22,18 @@ open Tactypes (** {6 The Type of Constructions clausale environments.} *) -type clausenv = { +type clausenv = private { env : env; (** the typing context *) evd : evar_map; (** the mapping from metavar and evar numbers to their types and values *) templval : constr freelisted; (** the template which we are trying to fill out *) - templtyp : constr freelisted (** its type *)} + templtyp : constr freelisted; (** its type *) + cache : Reductionops.meta_instance_subst; (* Reductionops.create_meta_instance_subst evd) *) +} +val mk_clausenv : env -> evar_map -> constr freelisted -> types freelisted -> clausenv +val update_clenv_evd : clausenv -> evar_map -> clausenv (** subject of clenv (instantiated) *) val clenv_value : clausenv -> constr diff --git a/tactics/equality.ml b/tactics/equality.ml index fcdd23a9c1..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 = diff --git a/tactics/genredexpr.ml b/tactics/genredexpr.ml index 1f6b04c1d3..9939490e79 100644 --- a/tactics/genredexpr.ml +++ b/tactics/genredexpr.ml @@ -35,13 +35,13 @@ type 'a glob_red_flag = { (** Generic kinds of reductions *) -type ('a,'b,'c) red_expr_gen = +type ('a, 'b, 'c, 'flags) red_expr_gen0 = | Red of bool | Hnf - | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option - | Cbv of 'b glob_red_flag - | Cbn of 'b glob_red_flag - | Lazy of 'b glob_red_flag + | Simpl of 'flags * ('b, 'c) Util.union Locus.with_occurrences option + | Cbv of 'flags + | Cbn of 'flags + | Lazy of 'flags | Unfold of 'b Locus.with_occurrences list | Fold of 'a list | Pattern of 'a Locus.with_occurrences list @@ -49,6 +49,9 @@ type ('a,'b,'c) red_expr_gen = | CbvVm of ('b,'c) Util.union Locus.with_occurrences option | CbvNative of ('b,'c) Util.union Locus.with_occurrences option +type ('a, 'b, 'c) red_expr_gen = + ('a, 'b, 'c, 'b glob_red_flag) red_expr_gen0 + type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a diff --git a/tactics/hints.ml b/tactics/hints.ml index 6fab111e6f..ace51c40d4 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -340,10 +340,8 @@ let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = merge_context_set_opt sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in - let cl = {cl with templval = - { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; - env = empty_env} - in + let templval = { cl.templval with rebus = strip_params env sigma cl.templval.rebus } in + let cl = mk_clausenv empty_env cl.evd templval cl.templtyp in { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; } in let code = match p.code.obj with @@ -1649,14 +1647,17 @@ let connect_hint_clenv h gl = let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (* Only metas are mentioning the old universes. *) - { - templval = Evd.map_fl emap clenv.templval; - templtyp = Evd.map_fl emap clenv.templtyp; - evd = Evd.map_metas emap evd; - env = Proofview.Goal.env gl; - } + Clenv.mk_clausenv + (Proofview.Goal.env gl) + (Evd.map_metas emap evd) + (Evd.map_fl emap clenv.templval) + (Evd.map_fl emap clenv.templtyp) | None -> - { clenv with evd = evd ; env = Proofview.Goal.env gl } + Clenv.mk_clausenv + (Proofview.Goal.env gl) + evd + clenv.templval + clenv.templtyp let fresh_hint env sigma h = let { hint_term = c; hint_uctx = ctx } = h in diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index a8747e0a7c..9c2df71f82 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -129,6 +129,9 @@ let set_strategy local str = type red_expr = (constr, evaluable_global_reference, constr_pattern) red_expr_gen +type red_expr_val = + (constr, evaluable_global_reference, constr_pattern, CClosure.RedFlags.reds) red_expr_gen0 + let make_flag_constant = function | EvalVarRef id -> fVAR id | EvalConstRef sp -> fCONST sp @@ -221,38 +224,117 @@ let warn_simpl_unfolding_modifiers = (fun () -> Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.") -let reduction_of_red_expr env = - let make_flag = make_flag env in - let rec reduction_of_red_expr = function +let rec eval_red_expr env = function +| Simpl (f, o) -> + let () = + if not (simplIsCbn () || List.is_empty f.rConst) then + warn_simpl_unfolding_modifiers () in + let f = if simplIsCbn () then make_flag env f else CClosure.all (* dummy *) in + Simpl (f, o) +| Cbv f -> Cbv (make_flag env f) +| Cbn f -> Cbn (make_flag env f) +| Lazy f -> Lazy (make_flag env f) +| ExtraRedExpr s -> + begin match String.Map.find s !red_expr_tab with + | e -> eval_red_expr env e + | exception Not_found -> ExtraRedExpr s (* delay to runtime interpretation *) + end +| (Red _ | Hnf | Unfold _ | Fold _ | Pattern _ | CbvVm _ | CbvNative _) as e -> e + +let reduction_of_red_expr_val = function | Red internal -> if internal then (e_red try_red_product,DEFAULTcast) else (e_red red_product,DEFAULTcast) | Hnf -> (e_red hnf_constr,DEFAULTcast) | Simpl (f,o) -> - let whd_am = if simplIsCbn () then whd_cbn (make_flag f) else whd_simpl in - let am = if simplIsCbn () then strong_cbn (make_flag f) else simpl in - let () = - if not (simplIsCbn () || List.is_empty f.rConst) then - warn_simpl_unfolding_modifiers () in + let whd_am = if simplIsCbn () then whd_cbn f else whd_simpl in + let am = if simplIsCbn () then strong_cbn f else simpl in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) - | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) + | Cbv f -> (e_red (cbv_norm_flags f),DEFAULTcast) | Cbn f -> - (e_red (strong_cbn (make_flag f)), DEFAULTcast) - | Lazy f -> (e_red (clos_norm_flags (make_flag f)),DEFAULTcast) + (e_red (strong_cbn f), DEFAULTcast) + | Lazy f -> (e_red (clos_norm_flags f),DEFAULTcast) | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast) | Fold cl -> (e_red (fold_commands cl),DEFAULTcast) | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast) | ExtraRedExpr s -> (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast) with Not_found -> - (try reduction_of_red_expr (String.Map.find s !red_expr_tab) - with Not_found -> user_err ~hdr:"Redexpr.reduction_of_red_expr" - (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) + (str "unknown user-defined reduction \"" ++ str s ++ str "\"")) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) + +let reduction_of_red_expr env r = + reduction_of_red_expr_val (eval_red_expr env r) + +(* Possibly equip a reduction with the occurrences mentioned in an + occurrence clause *) + +let error_illegal_clause () = + CErrors.user_err Pp.(str "\"at\" clause not supported in presence of an occurrence clause.") + +let error_illegal_non_atomic_clause () = + CErrors.user_err Pp.(str "\"at\" clause not supported in presence of a non atomic \"in\" clause.") + +let error_occurrences_not_unsupported () = + CErrors.user_err Pp.(str "Occurrences not supported for this reduction tactic.") + +let bind_red_expr_occurrences occs nbcl redexp = + let open Locus in + let has_at_clause = function + | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Simpl (_,Some (occl,_)) -> occl != AllOccurrences + | _ -> false in + if occs == AllOccurrences then + if nbcl > 1 && has_at_clause redexp then + error_illegal_non_atomic_clause () + else + redexp + else + match redexp with + | Unfold (_::_::_) -> + error_illegal_clause () + | Unfold [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Unfold [(occs,c)] + | Pattern (_::_::_) -> + error_illegal_clause () + | Pattern [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Pattern [(occs,c)] + | Simpl (f,Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + Simpl (f,Some (occs,c)) + | CbvVm (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvVm (Some (occs,c)) + | CbvNative (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvNative (Some (occs,c)) + | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ + | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> + error_occurrences_not_unsupported () + | Unfold [] | Pattern [] -> + assert false + +let reduction_of_red_expr_val ?occs r = + let r = match occs with + | None -> r + | Some (occs, nbcl) -> bind_red_expr_occurrences occs nbcl r in - reduction_of_red_expr + reduction_of_red_expr_val r let subst_mps subst c = EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) diff --git a/tactics/redexpr.mli b/tactics/redexpr.mli index d43785218f..5f3a7b689b 100644 --- a/tactics/redexpr.mli +++ b/tactics/redexpr.mli @@ -19,10 +19,18 @@ open Reductionops open Locus type red_expr = - (constr, evaluable_global_reference, constr_pattern) red_expr_gen + (constr, evaluable_global_reference, constr_pattern) red_expr_gen + +type red_expr_val val out_with_occurrences : 'a with_occurrences -> occurrences * 'a +val eval_red_expr : Environ.env -> red_expr -> red_expr_val + +val reduction_of_red_expr_val : ?occs:(Locus.occurrences_expr * int) -> + red_expr_val -> e_reduction_function * cast_kind + +(** Composition of {!reduction_of_red_expr_val} with {!eval_red_expr} *) val reduction_of_red_expr : Environ.env -> red_expr -> e_reduction_function * cast_kind diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5aa31092e9..39c5c9562f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -85,24 +85,6 @@ let () = optread = (fun () -> !universal_lemma_under_conjunctions) ; optwrite = (fun b -> universal_lemma_under_conjunctions := b) } -(* The following boolean governs what "intros []" do on examples such - as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; - if false, it behaves as "intro H; case H; clear H" for fresh H. - Kept as false for compatibility. - *) - -let bracketing_last_or_and_intro_pattern = ref true - -let use_bracketing_last_or_and_intro_pattern () = - !bracketing_last_or_and_intro_pattern - -let () = - declare_bool_option - { optdepr = true; - optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; - optread = (fun () -> !bracketing_last_or_and_intro_pattern); - optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } - (*********************************************) (* Tactics *) (*********************************************) @@ -634,70 +616,10 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where env sigma dec in (sigma, LocalDef (id,b',ty')) -(* Possibly equip a reduction with the occurrences mentioned in an - occurrence clause *) - -let error_illegal_clause () = - error "\"at\" clause not supported in presence of an occurrence clause." - -let error_illegal_non_atomic_clause () = - error "\"at\" clause not supported in presence of a non atomic \"in\" clause." - -let error_occurrences_not_unsupported () = - error "Occurrences not supported for this reduction tactic." - let bind_change_occurrences occs = function | None -> None | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) -let bind_red_expr_occurrences occs nbcl redexp = - let has_at_clause = function - | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l - | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l - | Simpl (_,Some (occl,_)) -> occl != AllOccurrences - | _ -> false in - if occs == AllOccurrences then - if nbcl > 1 && has_at_clause redexp then - error_illegal_non_atomic_clause () - else - redexp - else - match redexp with - | Unfold (_::_::_) -> - error_illegal_clause () - | Unfold [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Unfold [(occs,c)] - | Pattern (_::_::_) -> - error_illegal_clause () - | Pattern [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Pattern [(occs,c)] - | Simpl (f,Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - Simpl (f,Some (occs,c)) - | CbvVm (Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - CbvVm (Some (occs,c)) - | CbvNative (Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - CbvNative (Some (occs,c)) - | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ - | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> - error_occurrences_not_unsupported () - | Unfold [] | Pattern [] -> - assert false - (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a certain hypothesis *) @@ -959,17 +881,16 @@ let reduce redexp cl = | Red _ | Hnf | CbvVm _ | CbvNative _ -> StableHypConv | ExtraRedExpr _ -> StableHypConv (* Should we be that lenient ?*) in + let redexp = Redexpr.eval_red_expr env redexp in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> - let redexp = bind_red_expr_occurrences occs nbcl redexp in - let redfun = Redexpr.reduction_of_red_expr env redexp in + let redfun = Redexpr.reduction_of_red_expr_val ~occs:(occs, nbcl) redexp in e_change_in_concl ~check (revert_cast redfun) end <*> let f (id, occs, where) = - let redexp = bind_red_expr_occurrences occs nbcl redexp in - let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr_val ~occs:(occs, nbcl) redexp in let redfun _ env sigma c = redfun env sigma c in let redfun env sigma d = e_pf_change_decl redfun where env sigma d in (id, redfun) @@ -1083,10 +1004,10 @@ let intros_using_then l tac = intros_using_then_helper tac [] l let intros = Tacticals.New.tclREPEAT intro -let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = +let intro_forthcoming_then_gen name_flag move_flag dep_flag bound n tac = let rec aux n ids = (* Note: we always use the bound when there is one for "*" and "**" *) - if (match bound with None -> true | Some (_,p) -> n < p) then + if (match bound with None -> true | Some p -> n < p) then Proofview.tclORELSE begin intro_then_gen name_flag move_flag false dep_flag @@ -1380,20 +1301,18 @@ let do_replace id = function let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = let clenv = Clenv.clenv_pose_dependent_evars ~with_evars clenv in - let clenv = - { clenv with evd = Typeclasses.resolve_typeclasses - ~fail:(not with_evars) clenv.env clenv.evd } - in + let evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd in + let clenv = Clenv.update_clenv_evd clenv evd in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; - if not with_evars && occur_meta clenv.evd new_hyp_typ then + if not with_evars && occur_meta evd new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Logic.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf) in let naming = NamingMustBe (CAst.make targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) + (Proofview.Unsafe.tclEVARS (clear_metas evd)) (Tacticals.New.tclTHENLAST (assert_after_then_gen ?err with_clear naming new_hyp_typ tac) exact_tac) @@ -2306,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" @@ -2339,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 @@ -2360,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 = @@ -2476,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 @@ -2501,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 @@ -2575,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] @@ -3271,7 +3187,7 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = (intros_move newlstatus) let dest_intro_patterns with_evars avoid thin dest pat tac = - intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat + intro_patterns_core with_evars avoid [] thin dest None 0 tac pat let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE diff --git a/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/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/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/ocaml_pwd.ml b/test-suite/ocaml_pwd.ml index afa3deea3a..054a921b93 100644 --- a/test-suite/ocaml_pwd.ml +++ b/test-suite/ocaml_pwd.ml @@ -1,7 +1,26 @@ +open Arg + +let quoted = ref false +let trailing_slash = ref false + +let arguments = [ + "-quoted",Set quoted, "Quote path"; + "-trailing-slash",Set trailing_slash, "End the path with a /"; +] +let subject = ref None +let set_subject x = + if !subject <> None then + failwith "only one path"; + subject := Some x + let _ = - let quoted = Sys.argv.(1) = "-quoted" in - let ch_dir = Sys.argv.(if quoted then 2 else 1) in - Sys.chdir ch_dir; + Arg.parse arguments set_subject "Usage:"; + let subject = + match !subject with + | None -> failwith "no path given"; + | Some x -> x in + Sys.chdir subject; let dir = Sys.getcwd () in - let dir = if quoted then Filename.quote dir else dir in + let dir = if !trailing_slash then dir ^ "/" else dir in + let dir = if !quoted then Filename.quote dir else dir in Format.printf "%s%!" dir diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 01564e7f25..984ac4e527 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -74,7 +74,9 @@ fun '{{n, m, p}} => n + m + p fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: -The constructor D (in type J) expects 3 arguments. +Once notations are expanded, the resulting constructor D (in type J) is +expected to be applied to no arguments while it is actually applied to +1 argument. lem1 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k @@ -181,3 +183,51 @@ end File "stdin", line 253, characters 4-5: Warning: Unused variable B catches more than one case. [unused-pattern-matching-variable,pattern-matching] +The command has indeed failed with message: +Application of arguments to a recursive notation not supported in patterns. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 3 arguments. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 1 argument. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 4 arguments (or +6 arguments when including variables for local definitions) while it is +actually applied to 5 arguments. +fun x : J' bool (true, true) => +match x with +| D' _ _ _ m _ e => existT (fun x0 : nat => x0 = x0) m e +end + : J' bool (true, true) -> {x0 : nat & x0 = x0} +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ n _ p _ => n + p +end + : J' bool (true, true) -> nat +The command has indeed failed with message: +Application of arguments to a recursive notation not supported in patterns. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 3 arguments. +The command has indeed failed with message: +The constructor cons (in type list) is expected to be applied to 2 arguments +while it is actually applied to 1 argument. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 3 arguments (or +4 arguments when including variables for local definitions) while it is +actually applied to 2 arguments. +The command has indeed failed with message: +The constructor D' (in type J') is expected to be applied to 3 arguments (or +4 arguments when including variables for local definitions) while it is +actually applied to 5 arguments. +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ _ m _ e => existT (fun x0 : nat => x0 = x0) m e +end + : J' bool (true, true) -> {x0 : nat & x0 = x0} +fun x : J' bool (true, true) => +match x with +| @D' _ _ _ _ n _ p _ => (n, p) +end + : J' bool (true, true) -> nat * nat diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 2d8a8b359c..0cb3ac3ddc 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -254,3 +254,33 @@ Definition bar (f : foo) := end. End Wish12762. + +Module ConstructorArgumentsNumber. + +Arguments cons {A} _ _. + +Inductive J' A {B} (C:=(A*B)%type) (c:C) := D' : forall n {m}, let p := n+m in m=m -> J' A c. + +Unset Asymmetric Patterns. + +Fail Check fun x => match x with (y,z) w => y+z+w end. +Fail Check fun x => match x with cons y z w => 0 | nil => 0 end. +Fail Check fun x => match x with cons y => 0 | nil => 0 end. + +(* Missing a let-in to be in let-in mode *) +Fail Check fun x => match x with D' _ _ n p e => 0 end. +Check fun x : J' bool (true,true) => match x with D' _ _ n e => existT (fun x => eq x x) _ e end. +Check fun x : J' bool (true,true) => match x with D' _ _ _ n p e => n+p end. + +Set Asymmetric Patterns. + +Fail Check fun x => match x with (y,z) w => y+z+w end. +Fail Check fun x => match x with cons y z w => 0 | nil => 0 end. +Fail Check fun x => match x with cons y => 0 | nil => 0 end. + +Fail Check fun x => match x with D' n _ => 0 end. +Fail Check fun x => match x with D' n m p e _ => 0 end. +Check fun x : J' bool (true,true) => match x with D' n m e => existT (fun x => eq x x) m e end. +Check fun x : J' bool (true,true) => match x with D' n m p e => (n,p) end. + +End ConstructorArgumentsNumber. diff --git a/test-suite/output/RecordFieldErrors.out b/test-suite/output/RecordFieldErrors.out index 5b67f632c9..b80345108e 100644 --- a/test-suite/output/RecordFieldErrors.out +++ b/test-suite/output/RecordFieldErrors.out @@ -11,4 +11,4 @@ This record defines several times the field foo. The command has indeed failed with message: This record defines several times the field unit. The command has indeed failed with message: -unit: Not a projection of inductive t. +unit: Not a projection. diff --git a/test-suite/output/RecordFieldErrors.v b/test-suite/output/RecordFieldErrors.v index 27aa07822b..ff817c31aa 100644 --- a/test-suite/output/RecordFieldErrors.v +++ b/test-suite/output/RecordFieldErrors.v @@ -35,4 +35,4 @@ acceptable and seems an unlikely mistake. *) Fail Check {| foo := tt; unit := tt |}. -(* unit: Not a projection of inductive t. *) +(* unit: Not a projection. *) diff --git a/test-suite/output/StringSyntaxPrimitive.out b/test-suite/output/StringSyntaxPrimitive.out new file mode 100644 index 0000000000..131975c760 --- /dev/null +++ b/test-suite/output/StringSyntaxPrimitive.out @@ -0,0 +1,20 @@ +"abc" + : intList +"abc" + : intList +mk_intList [97%int63; 98%int63; 99%int63] + : intList +"abc" + : intArray +"abc" + : intArray + = "abc" + : nestArray +"abc" + : nestArray +"100" + : floatList +"100" + : floatList +mk_floatList [1%float; 0%float; 0%float] + : floatList diff --git a/test-suite/output/StringSyntaxPrimitive.v b/test-suite/output/StringSyntaxPrimitive.v new file mode 100644 index 0000000000..23ef082013 --- /dev/null +++ b/test-suite/output/StringSyntaxPrimitive.v @@ -0,0 +1,139 @@ +Require Import Coq.Lists.List. +Require Import Coq.Strings.String Coq.Strings.Byte Coq.Strings.Ascii. +Require Coq.Array.PArray Coq.Floats.PrimFloat. +Require Import Coq.Numbers.BinNums Coq.Numbers.Cyclic.Int63.Int63. + +Set Printing Depth 100000. +Set Printing Width 1000. + +Close Scope char_scope. +Close Scope string_scope. + +(* Notations for primitive integers inside polymorphic datatypes *) +Module Test1. + Inductive intList := mk_intList (_ : list int). + Definition i63_from_byte (b : byte) : int := Int63.of_Z (BinInt.Z.of_N (Byte.to_N b)). + Definition i63_to_byte (i : int) : byte := + match Byte.of_N (BinInt.Z.to_N (Int63.to_Z i)) with Some x => x | None => x00%byte end. + + Definition to_byte_list '(mk_intList a) := List.map i63_to_byte a. + + Definition from_byte_list (xs : list byte) : intList:= + mk_intList (List.map i63_from_byte xs). + + Declare Scope intList_scope. + Delimit Scope intList_scope with intList. + + String Notation intList from_byte_list to_byte_list : intList_scope. + + Open Scope intList_scope. + Import List.ListNotations. + Check mk_intList [97; 98; 99]%int63%list. + Check "abc"%intList. + + Definition int' := int. + Check mk_intList (@cons int' 97 [98; 99])%int63%list. +End Test1. + +Import PArray. + +(* Notations for primitive arrays *) +Module Test2. + Inductive intArray := mk_intArray (_ : array int). + + Definition i63_from_byte (b : byte) : Int63.int := Int63.of_Z (BinInt.Z.of_N (Byte.to_N b)). + Definition i63_to_byte (i : Int63.int) : byte := + match Byte.of_N (BinInt.Z.to_N (Int63.to_Z i)) with Some x => x | None => x00%byte end. + + Definition i63_to_nat x := BinInt.Z.to_nat (Int63.to_Z x). + Local Definition nat_length {X} (x : array X) :nat := i63_to_nat (length x). + + Local Fixpoint list_length_i63 {A} (xs : list A) :int := + match xs with + | nil => 0 + | cons _ xs => 1 + list_length_i63 xs + end. + + Definition to_byte_list '(mk_intArray a) := + ((fix go (n : nat) (i : Int63.int) (acc : list byte) := + match n with + | 0 => acc + | S n => go n (i - 1) (cons (i63_to_byte a.[i]) acc) + end) (nat_length a) (length a - 1) nil)%int63. + + Definition from_byte_list (xs : list byte) := + (let arr := make (list_length_i63 xs) 0 in + mk_intArray ((fix go i xs acc := + match xs with + | nil => acc + | cons x xs => go (i + 1) xs (acc.[i <- i63_from_byte x]) + end) 0 xs arr))%int63. + + Declare Scope intArray_scope. + Delimit Scope intArray_scope with intArray. + + String Notation intArray from_byte_list to_byte_list : intArray_scope. + + Open Scope intArray_scope. + Check mk_intArray ( [| 97; 98; 99 | 0|])%int63%array. + Check "abc"%intArray. + +End Test2. + +(* Primitive arrays inside primitive arrays *) +Module Test3. + + Inductive nestArray := mk_nestArray (_ : array (array int)). + Definition to_byte_list '(mk_nestArray a) := + ((fix go (n : nat) (i : Int63.int) (acc : list byte) := + match n with + | 0 => acc + | S n => go n (i - 1) (cons (Test2.i63_to_byte a.[i].[0]) acc) + end) (Test2.nat_length a) (length a - 1) nil)%int63. + + Definition from_byte_list (xs : list byte) := + (let arr := make (Test2.list_length_i63 xs) (make 0 0) in + mk_nestArray ((fix go i xs acc := + match xs with + | nil => acc + | cons x xs => go (i + 1) xs (acc.[i <- make 1 (Test2.i63_from_byte x)]) + end) 0 xs arr))%int63. + + Declare Scope nestArray_scope. + Delimit Scope nestArray_scope with nestArray. + + String Notation nestArray from_byte_list to_byte_list : nestArray_scope. + + Open Scope nestArray_scope. + Eval cbv in mk_nestArray ( [| make 1 97; make 1 98; make 1 99 | make 0 0|])%int63%array. + Check "abc"%nestArray. +End Test3. + + + +(* Notations for primitive floats inside polymorphic datatypes *) +Module Test4. + Import PrimFloat. + Inductive floatList := mk_floatList (_ : list float). + Definition float_from_byte (b : byte) : float := + if Byte.eqb b "0"%byte then PrimFloat.zero else PrimFloat.one. + Definition float_to_byte (f : float) : byte := + if PrimFloat.is_zero f then "0" else "1". + Definition to_byte_list '(mk_floatList a) := List.map float_to_byte a. + + Definition from_byte_list (xs : list byte) : floatList:= + mk_floatList (List.map float_from_byte xs). + + Declare Scope floatList_scope. + Delimit Scope floatList_scope with floatList. + + String Notation floatList from_byte_list to_byte_list : floatList_scope. + + Open Scope floatList_scope. + Import List.ListNotations. + Check mk_floatList [97; 0; 0]%float%list. + Check "100"%floatList. + + Definition float' := float. + Check mk_floatList (@cons float' 1 [0; 0])%float%list. +End Test4. diff --git a/test-suite/output/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/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/cbv_let.v b/test-suite/success/cbv_let.v new file mode 100644 index 0000000000..861a73a64e --- /dev/null +++ b/test-suite/success/cbv_let.v @@ -0,0 +1,34 @@ +Record T : Type := Build_T { f : unit; g := pair f f; }. + +Definition t : T := {| f := tt; |}. + +Goal match t return unit with Build_T f g => f end = tt. +Proof. +cbv. +reflexivity. +Qed. + +Goal match t return prod unit unit with Build_T f g => g end = pair tt tt. +Proof. +cbv. +reflexivity. +Qed. + +Goal forall (x : T), + match x return prod unit unit with Build_T f g => g end = + pair match x return unit with Build_T f g => fst g end match x return unit with Build_T f g => snd g end. +Proof. +cbv. +destruct x. +reflexivity. +Qed. + +Record U : Type := Build_U { h := tt }. + +Definition u : U := Build_U. + +Goal match u with Build_U h => h end = tt. +Proof. +cbv. +reflexivity. +Qed. diff --git a/test-suite/success/change_case.v b/test-suite/success/change_case.v new file mode 100644 index 0000000000..490e4f4b6c --- /dev/null +++ b/test-suite/success/change_case.v @@ -0,0 +1,20 @@ +Inductive box (A : Type) := Box : A -> box A. + +Axiom PRED : unit -> Prop. +Axiom FUN : forall (u : unit), box (PRED u). + +Axiom U : unit. +Definition V := U. + +Goal match FUN U with Box _ _ => True end. +Proof. +repeat match goal with +| [ |- context G[ U ] ] => + let e := context G [ V ] in + change e +end. +set (Z := V). +clearbody Z. (* This fails if change misses the case parameters *) +destruct (FUN Z). +constructor. +Qed. diff --git a/test-suite/success/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/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 c489d82d0b..561822ef0c 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -352,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/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/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/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index c469a49903..f324bbf52b 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -226,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. @@ -489,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. @@ -509,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. @@ -651,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]. @@ -727,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). @@ -805,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. @@ -973,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. @@ -1078,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. @@ -1360,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. @@ -1390,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). 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/Tauto.v b/theories/micromega/Tauto.v index 515372466a..e4129f8382 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -1371,13 +1371,13 @@ Section S. destruct pol;auto. generalize (is_cnf_tt_inv (xcnf (negb true) f1)). destruct (is_cnf_tt (xcnf (negb true) f1)). - + intros. + + 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. + * intros H. rewrite H by auto. unfold or_cnf_opt. simpl. diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 1616b5a2a4..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. @@ -343,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. @@ -365,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]. @@ -375,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. @@ -396,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. @@ -430,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. @@ -458,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. @@ -489,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. @@ -519,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. @@ -533,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. @@ -569,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). @@ -642,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. @@ -682,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. @@ -702,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). @@ -715,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. @@ -725,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. @@ -744,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. @@ -765,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. @@ -783,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 *) @@ -793,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. @@ -873,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. @@ -915,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. @@ -929,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. @@ -942,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. @@ -951,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. @@ -980,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. @@ -993,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. @@ -1006,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. @@ -1128,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. @@ -1180,8 +1181,8 @@ 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. @@ -1193,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. (**) @@ -1201,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. @@ -1213,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, @@ -1222,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. @@ -1259,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). @@ -1273,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 *. @@ -1282,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. @@ -1304,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. @@ -1359,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. @@ -1369,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. @@ -1382,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. @@ -1393,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. @@ -1415,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. } @@ -1446,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. @@ -1463,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. @@ -1491,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 := @@ -1520,7 +1524,7 @@ 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)). + 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. @@ -1529,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. @@ -1553,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. @@ -1565,13 +1569,13 @@ 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 *) @@ -1581,18 +1585,20 @@ Proof. 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 H with (env:=env) in H0. + + 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 with (f:= (p,NonStrict)) ; auto. + apply (cutting_plane_sound _ (p,NonStrict)) ; auto. apply ltof_bdepth_split_l. - + apply H with (env:=env) in H1. + + 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 with (f:= (popp p,NonStrict)) ; auto. + apply (cutting_plane_sound _ (popp p,NonStrict)) ; auto. apply ltof_bdepth_split_r. - (* EnumProof *) intros l. @@ -1601,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. @@ -1628,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. @@ -1647,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). @@ -1655,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. @@ -1676,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. @@ -1690,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. @@ -1708,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. * @@ -1729,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. @@ -1749,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'. @@ -1758,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. @@ -1776,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. @@ -1796,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. 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/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/vernac/himsg.ml b/vernac/himsg.ml index d35e13c4ef..bff0359782 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1325,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." @@ -1357,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 -> diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 06eb330958..e6244ee3b5 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1822,9 +1822,9 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing (* Declaration of custom entry *) let warn_custom_entry = - CWarnings.create ~name:"custom-entry-overriden" ~category:"parsing" + CWarnings.create ~name:"custom-entry-overridden" ~category:"parsing" (fun s -> - strbrk "Custom entry " ++ str s ++ strbrk " has been overriden.") + strbrk "Custom entry " ++ str s ++ strbrk " has been overridden.") let load_custom_entry _ _ = () |