diff options
737 files changed, 16373 insertions, 24102 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 000000000..441d89d42 --- /dev/null +++ b/.circleci/config.yml @@ -0,0 +1,415 @@ +defaults: + params: ¶ms + # Following parameters are used in Coq CircleCI Job (using yaml + # reference syntax) + working_directory: ~/coq + docker: + - image: ocaml/opam:ubuntu + + environment: &envvars + # required by some of the targets, e.g. compcert, passed for + # instance to opam to configure the number of parallel jobs + # allowed + NJOBS: 2 + COMPILER: "system" + CAMLP5_VER: "6.14" + NATIVE_COMP: "yes" + + # some useful values + COMPILER_32BIT: &compiler-32bit "4.02.3+32bit" + + COMPILER_BLEEDING_EDGE: &compiler-be "4.06.0" + CAMLP5_VER_BLEEDING_EDGE: &camlp5-ver-be "7.03" + + TIMING_PACKAGES: &timing-packages "time python" + + COQIDE_PACKAGES: &coqide-packages "libgtk2.0-dev libgtksourceview2.0-dev" + #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" + COQIDE_OPAM: &coqide-opam "lablgtk-extras" + COQIDE_OPAM_BE: &coqide-opam-be "num lablgtk.2.18.6 lablgtk-extras.1.6" + COQDOC_PACKAGES: &coqdoc-packages "texlive-latex-base texlive-latex-recommended texlive-latex-extra texlive-math-extra texlive-fonts-recommended texlive-fonts-extra latex-xcolor ghostscript transfig imagemagick tipa" + COQDOC_OPAM: &coqdoc-opam "hevea" + +version: 2 + +before_script: &before_script + name: Install system packages + command: | + echo export TERM=xterm >> ~/.profile + source ~/.profile + printenv + #if [ "$COMPILER" = "$COMPILER_32BIT" ]; then sudo dpkg --add-architecture i386; fi + if [ -n "${EXTRA_PACKAGES}" ]; then sudo apt-get update -yq && sudo apt-get install -yq --no-install-recommends ${EXTRA_PACKAGES}; fi + +opam-switch: &opam-switch + name: Select opam switch + command: | + source ~/.profile + opam switch ${COMPILER} + opam config list + opam list + +.opam-boot-template: &opam-boot-template + <<: *params + steps: + - checkout + - run: *before_script + - run: + name: Cache selection + command: | + source ~/.profile + # We can't use environment variables in cache names + # So put it in a file and use the checksum + echo "$COMPILER" > COMPILER + - restore_cache: + keys: + - coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}-{{ checksum ".circleci/config.yml" }}- + - coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}- # this grabs old cache if checksum doesn't match + - run: + name: Update opam lists + command: | + source ~/.profile + opam repository set-url default https://opam.ocaml.org + opam update + - run: + name: Install opam packages + command: | + source ~/.profile + opam switch -j ${NJOBS} ${COMPILER} + opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${COQIDE_OPAM} ${COQDOC_OPAM} ${EXTRA_OPAM} + - run: + name: Clean cache + command: | + source ~/.profile + rm -rf ~/.opam/log/ + - save_cache: + key: coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}-{{ checksum ".circleci/config.yml" }}- + paths: + - ~/.opam + - persist_to_workspace: + root: &workspace ~/ + paths: + - .opam/ + +.build-template: &build-template + <<: *params + steps: + - checkout + - run: *before_script + - attach_workspace: &attach_workspace + at: *workspace + - run: *opam-switch + - run: &build-configure + name: Configure + command: | + source ~/.profile + + ./configure -local -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} + - run: &build-build + name: Build + command: | + source ~/.profile + make -j ${NJOBS} byte + make -j ${NJOBS} + make test-suite/misc/universes/all_stdlib.v + - persist_to_workspace: + root: *workspace + paths: + - coq/ + + environment: &build-variables + <<: *envvars + EXTRA_CONF: "-coqide opt" + EXTRA_PACKAGES: *coqide-packages + +.validate-template: &validate-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Validate + command: | + source ~/.profile + make validate + environment: *envvars + +.documentation-template: &documentation-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Documentation + command: | + source ~/.profile + make -j ${NJOBS} doc + environment: &documentation-variables + <<: *envvars + EXTRA_PACKAGES: *coqdoc-packages + +.test-suite-template: &test-suite-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Test + command: | + source ~/.profile + cd test-suite + make clean + make -j ${NJOBS} all + environment: &test-suite-variables + <<: *envvars + EXTRA_PACKAGES: *timing-packages + +.ci-template: &ci-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Test + command: | + source ~/.profile + dev/ci/ci-wrapper.sh ${CIRCLE_JOB} + - persist_to_workspace: + root: *workspace + paths: + - coq/ + environment: &ci-template-vars + <<: *envvars + EXTRA_PACKAGES: *timing-packages + +# Defines individual jobs, see the workflows section below for job orchestration +jobs: + # TODO: linter + + opam-boot: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: *coqide-packages + EXTRA_OPAM: "ocamlgraph ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" + + opam-boot-32bit: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: "gcc-multilib" + COMPILER: *compiler-32bit + COQIDE_OPAM: "" + COQDOC_OPAM: "" + + opam-boot-be: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: *coqide-packages + COMPILER: *compiler-be + CAMLP5_VER: *camlp5-ver-be + COQIDE_OPAM: *coqide-opam-be + + # Build and prepare test environment + build: *build-template + + build-32bit: + <<: *build-template + environment: + <<: *envvars # no coqide for 32bit + EXTRA_PACKAGES: "gcc-multilib" + COMPILER: *compiler-32bit + + build-be: + <<: *build-template + environment: + <<: *build-variables + COMPILER: *compiler-be + + validate: *validate-template + + validate-32bit: + <<: *validate-template + environment: + <<: *envvars + COMPILER: *compiler-32bit + EXTRA_PACKAGES: "gcc-multilib" + + documentation: *documentation-template + + documentation-be: + <<: *documentation-template + environment: + <<: *documentation-variables + COMPILER: *compiler-be + CAMLP5_VER: *camlp5-ver-be + + test-suite: + <<: *test-suite-template + + test-suite-32bit: + <<: *test-suite-template + environment: + <<: *test-suite-variables + COMPILER: *compiler-32bit + EXTRA_PACKAGES: "gcc-multilib time python" + + test-suite-be: + <<: *test-suite-template + environment: + <<: *test-suite-variables + COMPILER: *compiler-be + EXTRA_PACKAGES: *timing-packages + + bignums: + <<: *ci-template + + color: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: *timing-packages + + compcert: + <<: *ci-template + + coq-dpdgraph: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + coquelicot: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + elpi: + <<: *ci-template + + equations: + <<: *ci-template + + geocoq: + <<: *ci-template + + fiat-crypto: + <<: *ci-template + + fiat-parsers: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: *timing-packages + + flocq: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + math-classes: + <<: *ci-template + + corn: + <<: *ci-template + + formal-topology: + <<: *ci-template + + hott: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + iris-lambda-rust: + <<: *ci-template + + ltac2: + <<: *ci-template + + math-comp: + <<: *ci-template + + sf: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python wget" + + unimath: + <<: *ci-template + + vst: + <<: *ci-template + +workflows: + version: 2 + # Run on each push + main: + jobs: + - opam-boot + - opam-boot-32bit + - opam-boot-be + + - build: + requires: + - opam-boot + - validate: &req-main + requires: + - build + - test-suite: *req-main + - documentation: *req-main + + - bignums: *req-main + - color: + requires: + - build + - bignums + - compcert: *req-main + - coq-dpdgraph: *req-main + - coquelicot: *req-main + - elpi: *req-main + - equations: *req-main + - geocoq: *req-main + - fiat-crypto: *req-main + - fiat-parsers: *req-main + - flocq: *req-main + - math-classes: + requires: + - build + - bignums + - corn: + requires: + - build + - math-classes + - formal-topology: + requires: + - build + - corn + - hott: *req-main + - iris-lambda-rust: *req-main + - ltac2: *req-main + - math-comp: *req-main + - sf: *req-main + - unimath: *req-main + - vst: *req-main + + - build-32bit: + requires: + - opam-boot-32bit + - validate-32bit: &req-32bit + requires: + - build-32bit + - test-suite-32bit: *req-32bit + + - build-be: + requires: + - opam-boot-be + - test-suite-be: &req-be + requires: + - build-be + - documentation-be: *req-be diff --git a/.dir-locals.el b/.dir-locals.el deleted file mode 100644 index e32ce14a4..000000000 --- a/.dir-locals.el +++ /dev/null @@ -1,37 +0,0 @@ -;; EMACS CONFIGURATION FOR COQ DEVELOPPERS This configuration will be -;; executed for each opened file under coq root directory. -((nil - . ((eval - . (progn - ;; coq root directory (ending with slash) - (let ((coq-root-directory (when buffer-file-name - (locate-dominating-file - buffer-file-name - ".dir-locals.el"))) - (coq-project-find-file - (and (boundp 'coq-project-find-file) coq-project-find-file))) - ;; coq tags file and coq debugger executable - (set (make-local-variable 'tags-file-name) - (concat coq-root-directory "TAGS")) - (setq camldebug-command-name (concat coq-root-directory - "dev/ocamldebug-coq")) - - ;; Setting the compilation directory to coq root. This is - ;; mutually exclusive with the setting of default-directory - ;; below. Also setting the path for next error. - (unless coq-project-find-file - (set (make-local-variable 'compile-command) - (concat "make -C " coq-root-directory)) - (set (make-local-variable 'compilation-search-path) - (cons coq-root-directory nil))) - - ;; Set default directory to coq root ONLY IF variable - ;; coq-project-find-file is non nil. This should remain a - ;; user preference and not be set by default. This setting - ;; is redundant with compile-command above as M-x compile - ;; always CD's to default directory. To enable it add this - ;; to your emacs config: (setq coq-project-find-file t) - (when coq-project-find-file - (setq default-directory coq-root-directory)))) - )) - )) diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 000000000..a9230042a --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,16 @@ +<!-- Thank you for your contribution. + Make sure you read the contributing guide and fill this template. --> + + +<!-- Keep what applies --> +**Kind:** documentation / bug fix / feature / performance / infrastructure. + + +<!-- If this is a bug fix, make sure the bug was reported beforehand. --> +Fixes / closes #???? + + +<!-- If this is a feature pull request / breaks compatibility: --> +<!-- (Otherwise, remove these lines.) --> +- [ ] Corresponding documentation was added / updated. +- [ ] Entry added in CHANGES. diff --git a/.gitignore b/.gitignore index 36536ec96..b857b754a 100644 --- a/.gitignore +++ b/.gitignore @@ -55,7 +55,7 @@ config/Makefile config/coq_config.ml config/Info-*.plist dev/ocamldebug-coq -dev/camlp4.dbg +dev/camlp5.dbg plugins/micromega/csdpcert plugins/micromega/.micromega.ml.generated kernel/byterun/dllcoqrun.so @@ -82,11 +82,10 @@ test-suite/coq-makefile/*/html test-suite/coq-makefile/*/mlihtml test-suite/coq-makefile/*/subdir/done test-suite/coq-makefile/merlin1/.merlin -test-suite/coq-makefile/plugin-reach-outside-API-and-fail/_CoqProject -test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/_CoqProject test-suite/coqdoc/Coqdoc.* test-suite/coqdoc/index.html test-suite/coqdoc/coqdoc.css +test-suite/output/MExtraction.out # documentation @@ -157,7 +156,6 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_jumptbl.h kernel/copcodes.ml -tools/tolink.ml ide/index_urls.txt .lia.cache checker/names.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c0a01f3fd..5dd376079 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -105,7 +105,7 @@ before_script: - set +e variables: &warnings-variables - EXTRA_CONF: "-native-compiler yes -coqide opt" + EXTRA_CONF: "-native-compiler yes -coqide byte -byte-only" EXTRA_PACKAGES: "$COQIDE_PACKAGES" EXTRA_OPAM: "$COQIDE_OPAM" @@ -136,7 +136,6 @@ before_script: stage: test script: - INSTALLDIR=$(readlink -f _install_ci) - - ./configure -prefix "$INSTALLDIR" ${EXTRA_CONF} - cp "$INSTALLDIR/lib/coq/tools/coqdoc/coqdoc.sty" . - LIB="$INSTALLDIR/lib/coq" @@ -268,7 +267,7 @@ ci-color: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES subversion" + EXTRA_PACKAGES: "$TIMING_PACKAGES" ci-compcert: <<: *ci-template @@ -286,6 +285,12 @@ ci-coquelicot: <<: *ci-template-vars EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" +ci-elpi: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_OPAM: "ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" + ci-equations: <<: *ci-template @@ -1,17 +1,17 @@ FLG -rectypes -thread -safe-string -w +a-4-9-27-41-42-44-45-48-50 +S clib +B clib S config B config -S ide -B ide S lib B lib -S intf -B intf S kernel B kernel S kernel/byterun B kernel/byterun +S intf +B intf S library B library S engine @@ -30,14 +30,16 @@ S parsing B parsing S stm B stm -S toplevel -B toplevel S vernac B vernac +S toplevel +B toplevel S plugins/ltac B plugins/ltac S API B API +S ide +B ide S tools B tools diff --git a/.travis.yml b/.travis.yml index 1f6bb11e0..f4f01d2f0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,10 +20,19 @@ addons: apt: sources: - avsm - packages: - - opam - - aspcud - - gcc-multilib +## Due to issues like +## https://github.com/travis-ci/travis-ci/issues/8507 , +## https://github.com/travis-ci/travis-ci/issues/9000 , +## https://github.com/travis-ci/travis-ci/issues/9081 , and +## https://github.com/travis-ci/travis-ci/issues/9126 , we get frequent +## failures with using `packages`. Therefore, for most targets, we +## instead invoke `apt-get update` manually with `travis_retry` before +## invoking `apt-get install`, manually, below in the `install:` +## target. +# packages: +# - opam +# - aspcud +# - gcc-multilib env: global: @@ -35,43 +44,82 @@ env: - CAMLP5_VER_BE="7.03" - FINDLIB_VER="1.4.1" - FINDLIB_VER_BE="1.7.3" - - LABLGTK="lablgtk.2.16.0 lablgtk-extras.1.5" + - LABLGTK="lablgtk.2.18.3 lablgtk-extras.1.6" - LABLGTK_BE="lablgtk.2.18.6 lablgtk-extras.1.6" - NATIVE_COMP="yes" - COQ_DEST="-local" + - MAIN_TARGET="world" # Main test suites matrix: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" EXTRA_OPAM="num" FINDLIB_VER="${FINDLIB_VER_BE}" - - TEST_TARGET="ci-bignums TIMED=1" - - TEST_TARGET="ci-color TIMED=1" - - TEST_TARGET="ci-compcert TIMED=1" - - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - - TEST_TARGET="ci-coquelicot TIMED=1" - - TEST_TARGET="ci-equations TIMED=1" - - TEST_TARGET="ci-geocoq TIMED=1" - - TEST_TARGET="ci-fiat-crypto TIMED=1" - - TEST_TARGET="ci-fiat-parsers TIMED=1" - - TEST_TARGET="ci-flocq TIMED=1" - - TEST_TARGET="ci-formal-topology TIMED=1" - - TEST_TARGET="ci-hott TIMED=1" - - TEST_TARGET="ci-iris-lambda-rust TIMED=1" - - TEST_TARGET="ci-ltac2 TIMED=1" - - TEST_TARGET="ci-math-classes TIMED=1" - - TEST_TARGET="ci-math-comp TIMED=1" - - TEST_TARGET="ci-sf TIMED=1" - - TEST_TARGET="ci-unimath TIMED=1" - - TEST_TARGET="ci-vst TIMED=1" - # Not ready yet for 8.7 - # - TEST_TARGET="ci-cpdt TIMED=1" - # - TEST_TARGET="ci-metacoq TIMED=1" - # - TEST_TARGET="ci-tlc TIMED=1" matrix: include: + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-bignums" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-color" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-compcert" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-coquelicot" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-elpi" EXTRA_OPAM="ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-equations" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-geocoq" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-fiat-crypto" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-fiat-parsers" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-flocq" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-formal-topology" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-hott" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-iris-lambda-rust" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-ltac2" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-math-classes" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-math-comp" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-sf" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-unimath" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="ci-vst" + - env: - TEST_TARGET="lint" install: [] @@ -139,8 +187,8 @@ matrix: # Ocaml warnings with two compilers - env: - - TEST_TARGET="coqocaml" - - EXTRA_CONF="-coqide opt -warn-error" + - MAIN_TARGET="coqocaml" + - EXTRA_CONF="-byte-only -coqide byte -warn-error" - EXTRA_OPAM="hevea ${LABLGTK}" # dummy target - BUILD_TARGET="clean" @@ -155,11 +203,11 @@ matrix: - libgtksourceview2.0-dev - env: - - TEST_TARGET="coqocaml" + - MAIN_TARGET="coqocaml" - COMPILER="${COMPILER_BE}" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - EXTRA_CONF="-coqide opt -warn-error" + - EXTRA_CONF="-byte-only -coqide byte -warn-error" - EXTRA_OPAM="num hevea ${LABLGTK_BE}" # dummy target - BUILD_TARGET="clean" @@ -182,6 +230,7 @@ matrix: - if: NOT (type = pull_request) os: osx + osx_image: xcode7.3 env: - TEST_TARGET="" - COMPILER="4.02.3" @@ -210,6 +259,8 @@ before_install: - if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi install: +- if [ "${TRAVIS_OS_NAME}" == "linux" ]; then travis_retry ./dev/tools/sudo-apt-get-update.sh -q; fi +- if [ "${TRAVIS_OS_NAME}" == "linux" ]; then sudo apt-get install -y opam aspcud gcc-multilib; fi - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y - eval $(opam config env) - opam config list @@ -224,11 +275,11 @@ script: - echo -en 'travis_fold:end:coq.config\\r' - echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' -- make -j ${NJOBS} +- make -j ${NJOBS} ${MAIN_TARGET} - echo -en 'travis_fold:end:coq.build\\r' - echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' -- ${TW} make -j ${NJOBS} ${TEST_TARGET} +- if [ -n "${TEST_TARGET}" ]; then ${TW} make -j ${NJOBS} ${TEST_TARGET}; fi - echo -en 'travis_fold:end:coq.test\\r' - set +e diff --git a/API/API.ml b/API/API.ml deleted file mode 100644 index 378c03ee4..000000000 --- a/API/API.ml +++ /dev/null @@ -1,284 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Warning, this file respects the dependency order established in Coq. - - To see such order issue the comand: - - ``` - bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link - ``` - *) - -(******************************************************************************) -(* config *) -(******************************************************************************) -module Coq_config = Coq_config - -(******************************************************************************) -(* Kernel *) -(******************************************************************************) -(* "mli" files *) -module Declarations = Declarations -module Entries = Entries - -module Names = Names -(* module Uint31 *) -module Univ = Univ -module UGraph = UGraph -module Esubst = Esubst -module Sorts = Sorts -module Evar = Evar -module Constr = Constr -module Context = Context -module Vars = Vars -module Term = Term -module Mod_subst = Mod_subst -module Cbytecodes = Cbytecodes -(* module Copcodes *) -module Cemitcodes = Cemitcodes -(* module Nativevalues *) -(* module CPrimitives *) -module Opaqueproof = Opaqueproof -module Declareops = Declareops -module Retroknowledge = Retroknowledge -module Conv_oracle = Conv_oracle -(* module Pre_env *) -(* module Cbytegen *) -(* module Nativelambda *) -(* module Nativecode *) -(* module Nativelib *) -module Environ = Environ -module CClosure = CClosure -module Reduction = Reduction -(* module Nativeconv *) -module Type_errors = Type_errors -module Modops = Modops -module Inductive = Inductive -module Typeops = Typeops -(* module Indtypes *) -(* module Cooking *) -(* module Term_typing *) -(* module Subtyping *) -module Mod_typing = Mod_typing -(* module Nativelibrary *) -module Safe_typing = Safe_typing -(* module Vm *) -(* module Csymtable *) -(* module Vconv *) - -(******************************************************************************) -(* Intf *) -(******************************************************************************) -module Constrexpr = Constrexpr -module Locus = Locus -module Glob_term = Glob_term -module Extend = Extend -module Misctypes = Misctypes -module Pattern = Pattern -module Decl_kinds = Decl_kinds -module Vernacexpr = Vernacexpr -module Notation_term = Notation_term -module Evar_kinds = Evar_kinds -module Genredexpr = Genredexpr - -(******************************************************************************) -(* Library *) -(******************************************************************************) -module Univops = Univops -module Nameops = Nameops -module Libnames = Libnames -module Globnames = Globnames -module Libobject = Libobject -module Summary = Summary -module Nametab = Nametab -module Global = Global -module Lib = Lib -module Declaremods = Declaremods -(* module Loadpath *) -module Library = Library -module States = States -module Kindops = Kindops -(* module Dischargedhypsmap *) -module Goptions = Goptions -(* module Decls *) -(* module Heads *) -module Keys = Keys -module Coqlib = Coqlib - -(******************************************************************************) -(* Engine *) -(******************************************************************************) -(* module Logic_monad *) -module Universes = Universes -module UState = UState -module Evd = Evd -module EConstr = EConstr -module Namegen = Namegen -module Termops = Termops -module Proofview_monad = Proofview_monad -module Evarutil = Evarutil -module Proofview = Proofview -module Ftactic = Ftactic -module Geninterp = Geninterp - -(******************************************************************************) -(* Pretyping *) -(******************************************************************************) -module Ltac_pretype = Ltac_pretype -module Locusops = Locusops -module Pretype_errors = Pretype_errors -module Reductionops = Reductionops -module Inductiveops = Inductiveops -(* module Vnorm *) -(* module Arguments_renaming *) -module Impargs = Impargs -(* module Nativenorm *) -module Retyping = Retyping -(* module Cbv *) -module Find_subterm = Find_subterm -(* module Evardefine *) -module Evarsolve = Evarsolve -module Recordops = Recordops -module Evarconv = Evarconv -module Typing = Typing -module Miscops = Miscops -module Glob_ops = Glob_ops -module Redops = Redops -module Patternops = Patternops -module Constr_matching = Constr_matching -module Tacred = Tacred -module Typeclasses = Typeclasses -module Classops = Classops -(* module Program *) -(* module Coercion *) -module Detyping = Detyping -module Indrec = Indrec -(* module Cases *) -module Pretyping = Pretyping -module Unification = Unification -module Univdecls = Univdecls -(******************************************************************************) -(* interp *) -(******************************************************************************) -module Tactypes = Tactypes -module Stdarg = Stdarg -module Genintern = Genintern -module Constrexpr_ops = Constrexpr_ops -module Notation_ops = Notation_ops -module Notation = Notation -module Dumpglob = Dumpglob -(* module Syntax_def *) -module Smartlocate = Smartlocate -module Topconstr = Topconstr -(* module Reserve *) -(* module Implicit_quantifiers *) -module Constrintern = Constrintern -(* module Modintern *) -module Constrextern = Constrextern -(* module Discharge *) -module Declare = Declare - -(******************************************************************************) -(* Proofs *) -(******************************************************************************) -module Miscprint = Miscprint -module Goal = Goal -module Evar_refiner = Evar_refiner -(* module Proof_using *) -module Proof_type = Proof_type -module Logic = Logic -module Refine = Refine -module Proof = Proof -module Proof_bullet = Proof_bullet -module Proof_global = Proof_global -module Redexpr = Redexpr -module Refiner = Refiner -module Tacmach = Tacmach -module Pfedit = Pfedit -module Clenv = Clenv -(* module Clenvtac *) -(* "mli" file *) - -(******************************************************************************) -(* Printing *) -(******************************************************************************) -module Genprint = Genprint -module Pputils = Pputils -module Ppconstr = Ppconstr -module Printer = Printer -(* module Printmod *) -module Prettyp = Prettyp -module Ppvernac = Ppvernac - -(******************************************************************************) -(* Parsing *) -(******************************************************************************) -module Tok = Tok -module CLexer = CLexer -module Pcoq = Pcoq -module Egramml = Egramml -(* Egramcoq *) - -module G_vernac = G_vernac -module G_proofs = G_proofs - -(******************************************************************************) -(* Tactics *) -(******************************************************************************) -(* module Dnet *) -(* module Dn *) -(* module Btermdn *) -module Tacticals = Tacticals -module Hipattern = Hipattern -module Ind_tables = Ind_tables -(* module Eqschemes *) -module Elimschemes = Elimschemes -module Tactics = Tactics -module Elim = Elim -module Equality = Equality -module Contradiction = Contradiction -module Inv = Inv -module Leminv = Leminv -module Hints = Hints -module Auto = Auto -module Eauto = Eauto -module Class_tactics = Class_tactics -(* module Term_dnet *) -module Eqdecide = Eqdecide -module Autorewrite = Autorewrite - -(******************************************************************************) -(* Vernac *) -(******************************************************************************) -(* module Vernacprop *) -module Lemmas = Lemmas -module Himsg = Himsg -module ExplainErr = ExplainErr -(* module Class *) -module Locality = Locality -module Metasyntax = Metasyntax -(* module Auto_ind_decl *) -module Search = Search -(* module Indschemes *) -module Obligations = Obligations -module Command = Command -module Classes = Classes -(* module Record *) -(* module Assumptions *) -module Vernacstate = Vernacstate -module Vernacinterp = Vernacinterp -module Mltop = Mltop -module Topfmt = Topfmt -module Vernacentries = Vernacentries - -(******************************************************************************) -(* Stm *) -(******************************************************************************) -module Vernac_classifier = Vernac_classifier -module Stm = Stm diff --git a/API/API.mli b/API/API.mli deleted file mode 100644 index 1a84600ec..000000000 --- a/API/API.mli +++ /dev/null @@ -1,6196 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Warning, this file should respect the dependency order established - in Coq. To see such order issue the comand: - - ``` - bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link - ``` - - Note however that files in intf/ are located manually now as their - conceptual linking order in the Coq codebase is incorrect (but it - works due to these files being implementation-free. - - See below in the file for their concrete position. -*) - -(************************************************************************) -(* Modules from config/ *) -(************************************************************************) -module Coq_config : -sig - val exec_extension : string -end - -(************************************************************************) -(* Modules from kernel/ *) -(************************************************************************) -module Names : -sig - - open Util - - module Id : - sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val is_valid : string -> bool - val of_bytes : bytes -> t - val of_string : string -> t - val of_string_soft : string -> t - val to_string : t -> string - val print : t -> Pp.t - - module Set : Set.S with type elt = t - module Map : Map.ExtS with type key = t and module Set := Set - module Pred : Predicate.S with type elt = t - module List : List.MonoS with type elt = t - val hcons : t -> t - end - - module Name : - sig - type t = Anonymous (** anonymous identifier *) - | Name of Id.t (** non-anonymous identifier *) - val mk_name : Id.t -> t - val is_anonymous : t -> bool - val is_name : t -> bool - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - val hcons : t -> t - val print : t -> Pp.t - end - - type name = Name.t = - | Anonymous - | Name of Id.t - [@@ocaml.deprecated "alias of API.Name.t"] - - module DirPath : - sig - type t - val empty : t - val make : Id.t list -> t - val repr : t -> Id.t list - val equal : t -> t -> bool - val to_string : t -> string - val print : t -> Pp.t - end - - module MBId : sig - type t - val equal : t -> t -> bool - val to_id : t -> Id.t - val repr : t -> int * Id.t * DirPath.t - val debug_to_string : t -> string - end - - module Label : - sig - type t - val make : string -> t - val equal : t -> t -> bool - val compare : t -> t -> int - val of_id : Id.t -> t - val to_id : t -> Id.t - val to_string : t -> string - end - - module ModPath : - sig - type t = - | MPfile of DirPath.t - | MPbound of MBId.t - | MPdot of t * Label.t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - val initial : t - val to_string : t -> string - val debug_to_string : t -> string - end - - module KerName : - sig - type t - val make : ModPath.t -> DirPath.t -> Label.t -> t - val make2 : ModPath.t -> Label.t -> t - val modpath : t -> ModPath.t - val equal : t -> t -> bool - val compare : t -> t -> int - val label : t -> Label.t - val repr : t -> ModPath.t * DirPath.t * Label.t - val print : t -> Pp.t - val to_string : t -> string - end - - type kernel_name = KerName.t - [@@ocaml.deprecated "alias of API.Names.KerName.t"] - - module Constant : - sig - type t - val equal : t -> t -> bool - val make1 : KerName.t -> t - val make2 : ModPath.t -> Label.t -> t - val make3 : ModPath.t -> DirPath.t -> Label.t -> t - val repr3 : t -> ModPath.t * DirPath.t * Label.t - val canonical : t -> KerName.t - val user : t -> KerName.t - val label : t -> Label.t - end - - module MutInd : - sig - type t - val make1 : KerName.t -> t - val make2 : ModPath.t -> Label.t -> t - val equal : t -> t -> bool - val repr3 : t -> ModPath.t * DirPath.t * Label.t - val canonical : t -> KerName.t - val modpath : t -> ModPath.t - val label : t -> Label.t - val user : t -> KerName.t - val print : t -> Pp.t - end - - module Projection : - sig - type t - val make : Constant.t -> bool -> t - val map : (Constant.t -> Constant.t) -> t -> t - val constant : t -> Constant.t - val equal : t -> t -> bool - val unfolded : t -> bool - val unfold : t -> t - end - - type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - - type inductive = MutInd.t * int - val eq_ind : inductive -> inductive -> bool - - type constructor = inductive * int - val eq_constructor : constructor -> constructor -> bool - val constructor_hash : constructor -> int - - module MPset : Set.S with type elt = ModPath.t - module MPmap : Map.ExtS with type key = ModPath.t and module Set := MPset - - module KNset : CSig.SetS with type elt = KerName.t - module KNpred : Predicate.S with type elt = KerName.t - module KNmap : Map.ExtS with type key = KerName.t and module Set := KNset - - module Cpred : Predicate.S with type elt = Constant.t - module Cset : CSig.SetS with type elt = Constant.t - module Cset_env : CSig.SetS with type elt = Constant.t - - module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset - module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env - - module Mindset : CSig.SetS with type elt = MutInd.t - module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset - module Mindmap_env : CSig.MapS with type key = MutInd.t - - module Indmap : CSig.MapS with type key = inductive - module Constrmap : CSig.MapS with type key = constructor - module Indmap_env : CSig.MapS with type key = inductive - module Constrmap_env : CSig.MapS with type key = constructor - - type transparent_state = Id.Pred.t * Cpred.t - - val empty_transparent_state : transparent_state - val full_transparent_state : transparent_state - val var_full_transparent_state : transparent_state - val cst_full_transparent_state : transparent_state - - val pr_kn : KerName.t -> Pp.t - [@@ocaml.deprecated "alias of API.Names.KerName.print"] - - val eq_constant : Constant.t -> Constant.t -> bool - [@@ocaml.deprecated "alias of API.Names.Constant.equal"] - - type module_path = ModPath.t = - | MPfile of DirPath.t - | MPbound of MBId.t - | MPdot of ModPath.t * Label.t - [@@ocaml.deprecated "alias of API.Names.ModPath.t"] - - type variable = Id.t - - type 'a tableKey = - | ConstKey of 'a - | VarKey of Id.t - | RelKey of Int.t - - val id_of_string : string -> Id.t - [@@ocaml.deprecated "alias of API.Names.Id.of_string"] - - val string_of_id : Id.t -> string - [@@ocaml.deprecated "alias of API.Names.Id.to_string"] - - type mutual_inductive = MutInd.t - [@@ocaml.deprecated "alias of API.Names.MutInd.t"] - - val eq_mind : MutInd.t -> MutInd.t -> bool - [@@ocaml.deprecated "alias of API.Names.MutInd.equal"] - - val repr_con : Constant.t -> ModPath.t * DirPath.t * Label.t - [@@ocaml.deprecated "alias of API.Names.Constant.repr3"] - - val repr_mind : MutInd.t -> ModPath.t * DirPath.t * Label.t - [@@ocaml.deprecated "alias of API.Names.MutInd.repr3"] - - val initial_path : ModPath.t - [@@ocaml.deprecated "alias of API.Names.ModPath.initial"] - - val con_label : Constant.t -> Label.t - [@@ocaml.deprecated "alias of API.Names.Constant.label"] - - val mind_label : MutInd.t -> Label.t - [@@ocaml.deprecated "alias of API.Names.MutInd.label"] - - val string_of_mp : ModPath.t -> string - [@@ocaml.deprecated "alias of API.Names.ModPath.to_string"] - - val mind_of_kn : KerName.t -> MutInd.t - [@@ocaml.deprecated "alias of API.Names.MutInd.make1"] - - type constant = Constant.t - [@@ocaml.deprecated "alias of API.Names.Constant.t"] - - val mind_modpath : MutInd.t -> ModPath.t - [@@ocaml.deprecated "alias of API.Names.MutInd.modpath"] - - val canonical_mind : MutInd.t -> KerName.t - [@@ocaml.deprecated "alias of API.Names.MutInd.canonical"] - - val user_mind : MutInd.t -> KerName.t - [@@ocaml.deprecated "alias of API.Names.MutInd.user"] - - val repr_kn : KerName.t -> ModPath.t * DirPath.t * Label.t - [@@ocaml.deprecated "alias of API.Names.KerName.repr"] - - val constant_of_kn : KerName.t -> Constant.t - [@@ocaml.deprecated "alias of API.Names.Constant.make1"] - - val user_con : Constant.t -> KerName.t - [@@ocaml.deprecated "alias of API.Names.Constant.user"] - - val modpath : KerName.t -> ModPath.t - [@@ocaml.deprecated "alias of API.Names.KerName.modpath"] - - val canonical_con : Constant.t -> KerName.t - [@@ocaml.deprecated "alias of API.Names.Constant.canonical"] - - val make_kn : ModPath.t -> DirPath.t -> Label.t -> KerName.t - [@@ocaml.deprecated "alias of API.Names.KerName.make"] - - val make_con : ModPath.t -> DirPath.t -> Label.t -> Constant.t - [@@ocaml.deprecated "alias of API.Names.Constant.make3"] - - val debug_pr_con : Constant.t -> Pp.t - [@@ocaml.deprecated "Alias of Names"] - - val debug_pr_mind : MutInd.t -> Pp.t - [@@ocaml.deprecated "Alias of Names"] - - val pr_con : Constant.t -> Pp.t - [@@ocaml.deprecated "Alias of Names"] - - val string_of_con : Constant.t -> string - [@@ocaml.deprecated "Alias of Names"] - - val string_of_mind : MutInd.t -> string - [@@ocaml.deprecated "Alias of Names"] - - val debug_string_of_mind : MutInd.t -> string - [@@ocaml.deprecated "Alias of Names"] - - val debug_string_of_con : Constant.t -> string - [@@ocaml.deprecated "Alias of Names"] - - type identifier = Id.t - [@@ocaml.deprecated "Alias of Names"] - - module Idset : Set.S with type elt = Id.t and type t = Id.Set.t - [@@ocaml.deprecated "Alias of Id.Set.t"] - -end - -module Univ : -sig - - module Level : - sig - type t - val set : t - val pr : t -> Pp.t - end - - type universe_level = Level.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module LSet : - sig - include CSig.SetS with type elt = Level.t - val pr : (Level.t -> Pp.t) -> t -> Pp.t - end - - module Universe : - sig - type t - val pr : t -> Pp.t - end - - type universe = Universe.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module Instance : - sig - type t - val empty : t - val of_array : Level.t array -> t - val to_array : t -> Level.t array - val pr : (Level.t -> Pp.t) -> t -> Pp.t - end - - type 'a puniverses = 'a * Instance.t - - val out_punivs : 'a puniverses -> 'a - - type constraint_type = Lt | Le | Eq - - type univ_constraint = Level.t * constraint_type * Level.t - - module Constraint : sig - include Set.S with type elt = univ_constraint - end - - type 'a constrained = 'a * Constraint.t - - module UContext : - sig - type t - val empty : t - end - - type universe_context = UContext.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module AUContext : - sig - type t - val empty : t - end - - type abstract_universe_context = AUContext.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module CumulativityInfo : - sig - type t - end - - type cumulativity_info = CumulativityInfo.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module ACumulativityInfo : - sig - type t - end - type abstract_cumulativity_info = ACumulativityInfo.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - module ContextSet : - sig - type t - val empty : t - val of_context : UContext.t -> t - val to_context : t -> UContext.t - end - - type 'a in_universe_context_set = 'a * ContextSet.t - type 'a in_universe_context = 'a * UContext.t - - type universe_context_set = ContextSet.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - type universe_set = LSet.t - [@@ocaml.deprecated "Deprecated form, see univ.ml"] - - type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t - - module LMap : - sig - include CMap.ExtS with type key = Level.t and module Set := LSet - - val union : 'a t -> 'a t -> 'a t - val diff : 'a t -> 'a t -> 'a t - val subst_union : 'a option t -> 'a option t -> 'a option t - val pr : ('a -> Pp.t) -> 'a t -> Pp.t - end - - type 'a universe_map = 'a LMap.t - type universe_subst = Universe.t universe_map - type universe_level_subst = Level.t universe_map - - val enforce_leq : Universe.t constraint_function - val pr_uni : Universe.t -> Pp.t - val pr_universe_context : (Level.t -> Pp.t) -> UContext.t -> Pp.t - val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t - val pr_universe_subst : universe_subst -> Pp.t - val pr_universe_level_subst : universe_level_subst -> Pp.t - val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t -end - -module UGraph : -sig - type t - val pr_universes : (Univ.Level.t -> Pp.t) -> t -> Pp.t -end - -module Esubst : -sig - type 'a subs - val subs_id : int -> 'a subs -end - -module Sorts : -sig - type contents = Pos | Null - type t = - | Prop of contents - | Type of Univ.Universe.t - val is_prop : t -> bool - val hash : t -> int - - type family = InProp | InSet | InType - val family : t -> family - val univ_of_sort : t -> Univ.Universe.t -end - -module Evar : -sig - (** Unique identifier of some {i evar} *) - type t - - (** Recover the underlying integer. *) - val repr : t -> int - - val equal : t -> t -> bool - - val print : t -> Pp.t - - (** a set of unique identifiers of some {i evars} *) - module Set : Set.S with type elt = t - module Map : CMap.ExtS with type key = t and module Set := Set - -end - -module Constr : -sig - - open Names - - type t - - type constr = t - type types = t - - type cast_kind = - | VMcast - | NATIVEcast - | DEFAULTcast - | REVERTcast - - type metavariable = int - - type existential_key = Evar.t - [@@ocaml.deprecated "use Evar.t"] - - type 'constr pexistential = Evar.t * 'constr array - - type 'a puniverses = 'a Univ.puniverses - [@@ocaml.deprecated "use Univ.puniverses"] - - type pconstant = Constant.t Univ.puniverses - type pinductive = inductive Univ.puniverses - type pconstructor = constructor Univ.puniverses - - type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array - - type ('constr, 'types) pfixpoint = - (int array * int) * ('constr, 'types) prec_declaration - - type ('constr, 'types) pcofixpoint = - int * ('constr, 'types) prec_declaration - - type case_style = - LetStyle | IfStyle | LetPatternStyle | MatchStyle - | RegularStyle (** infer printing form from number of constructor *) - - type case_printing = - { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) - cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *) - style : case_style } - - type case_info = - { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) - ci_npar : int; (* number of parameters of the above inductive type *) - ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines - the number of values that can be bound in a match-construct. - NOTE: parameters of the inductive type are therefore excluded from the count *) - ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines - the number of values that can be applied to the constructor, - in addition to the parameters of the related inductive type - NOTE: "lets" are therefore excluded from the count - NOTE: parameters of the inductive type are also excluded from the count *) - ci_pp_info : case_printing (* not interpreted by the kernel *) - } - - type ('constr, 'types, 'sort, 'univs) kind_of_term = - | Rel of int - | Var of Id.t - | Meta of metavariable - | Evar of 'constr pexistential - | Sort of 'sort - | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array - | Const of (Constant.t * 'univs) - | Ind of (inductive * 'univs) - | Construct of (constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint - | Proj of Projection.t * 'constr - - val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term - val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr - - val map_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr - val map : (constr -> constr) -> constr -> constr - - val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a - val iter : (constr -> unit) -> constr -> unit - val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool - - val equal : t -> t -> bool - val eq_constr_nounivs : t -> t -> bool - val compare : t -> t -> int - - val hash : t -> int - - val mkRel : int -> t - val mkVar : Id.t -> t - val mkMeta : metavariable -> t - type existential = Evar.t * constr array - val mkEvar : existential -> t - val mkSort : Sorts.t -> t - val mkProp : t - val mkSet : t - val mkType : Univ.Universe.t -> t - val mkCast : t * cast_kind * t -> t - val mkProd : Name.t * types * types -> types - val mkLambda : Name.t * types * t -> t - val mkLetIn : Name.t * t * types * t -> t - val mkApp : t * t array -> t - val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses - - type rec_declaration = Name.t array * types array * constr array - type fixpoint = (int array * int) * rec_declaration - val mkFix : fixpoint -> constr - - val mkConst : Constant.t -> t - val mkConstU : pconstant -> t - - val mkProj : (Projection.t * t) -> t - - val mkInd : inductive -> t - val mkIndU : pinductive -> t - - val mkConstruct : constructor -> t - val mkConstructU : pconstructor -> t - val mkConstructUi : pinductive * int -> t - - val mkCase : case_info * t * t * t array -> t - - (** {6 Simple case analysis} *) - val isRel : constr -> bool - val isRelN : int -> constr -> bool - val isVar : constr -> bool - val isVarId : Id.t -> constr -> bool - val isInd : constr -> bool - val isEvar : constr -> bool - val isMeta : constr -> bool - val isEvar_or_Meta : constr -> bool - val isSort : constr -> bool - val isCast : constr -> bool - val isApp : constr -> bool - val isLambda : constr -> bool - val isLetIn : constr -> bool - val isProd : constr -> bool - val isConst : constr -> bool - val isConstruct : constr -> bool - val isFix : constr -> bool - val isCoFix : constr -> bool - val isCase : constr -> bool - val isProj : constr -> bool - - val is_Prop : constr -> bool - val is_Set : constr -> bool - val isprop : constr -> bool - val is_Type : constr -> bool - val iskind : constr -> bool - val is_small : Sorts.t -> bool - - (** {6 Term destructors } *) - (** Destructor operations are partial functions and - @raise DestKO if the term has not the expected form. *) - - exception DestKO - - (** Destructs a de Bruijn index *) - val destRel : constr -> int - - (** Destructs an existential variable *) - val destMeta : constr -> metavariable - - (** Destructs a variable *) - val destVar : constr -> Id.t - - (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether - [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) - val destSort : constr -> Sorts.t - - (** Destructs a casted term *) - val destCast : constr -> constr * cast_kind * constr - - (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) - val destProd : types -> Name.t * types * types - - (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) - val destLambda : constr -> Name.t * types * constr - - (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) - val destLetIn : constr -> Name.t * constr * types * constr - - (** Destructs an application *) - val destApp : constr -> constr * constr array - - (** Decompose any term as an applicative term; the list of args can be empty *) - val decompose_app : constr -> constr * constr list - - (** Same as [decompose_app], but returns an array. *) - val decompose_appvect : constr -> constr * constr array - - (** Destructs a constant *) - val destConst : constr -> Constant.t Univ.puniverses - - (** Destructs an existential variable *) - val destEvar : constr -> existential - - (** Destructs a (co)inductive type *) - val destInd : constr -> inductive Univ.puniverses - - (** Destructs a constructor *) - val destConstruct : constr -> constructor Univ.puniverses - - (** Destructs a [match c as x in I args return P with ... | - Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args - return P in t1], or [if c then t1 else t2]) - @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] - where [info] is pretty-printing information *) - val destCase : constr -> case_info * constr * constr * constr array - - (** Destructs a projection *) - val destProj : constr -> Projection.t * constr - - (** Destructs the {% $ %}i{% $ %}th function of the block - [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} - with f{_ 2} ctx{_ 2} = b{_ 2} - ... - with f{_ n} ctx{_ n} = b{_ n}], - where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. - *) - val destFix : constr -> fixpoint - - type cofixpoint = int * rec_declaration - val destCoFix : constr -> cofixpoint - -end - -module Context : -sig - module Rel : - sig - module Declaration : - sig - (* local declaration *) - (* local declaration *) - type ('constr, 'types) pt = - | LocalAssum of Names.Name.t * 'types (** name, type *) - | LocalDef of Names.Name.t * 'constr * 'types (** name, value, type *) - - type t = (Constr.constr, Constr.types) pt - - (** Return the name bound by a given declaration. *) - val get_name : ('c, 't) pt -> Names.Name.t - - (** Return the type of the name bound by a given declaration. *) - val get_type : ('c, 't) pt -> 't - - (** Set the name that is bound by a given declaration. *) - val set_name : Names.Name.t -> ('c, 't) pt -> ('c, 't) pt - - (** Set the type of the bound variable in a given declaration. *) - val set_type : 't -> ('c, 't) pt -> ('c, 't) pt - - (** Return [true] iff a given declaration is a local assumption. *) - val is_local_assum : ('c, 't) pt -> bool - - (** Return [true] iff a given declaration is a local definition. *) - val is_local_def : ('c, 't) pt -> bool - - (** Check whether the two given declarations are equal. *) - val equal : ('c -> 'c -> bool) -> ('c, 'c) pt -> ('c, 'c) pt -> bool - - (** Map the name bound by a given declaration. *) - val map_name : (Names.Name.t -> Names.Name.t) -> ('c, 't) pt -> ('c, 't) pt - - (** For local assumptions, this function returns the original local assumptions. - For local definitions, this function maps the value in the local definition. *) - val map_value : ('c -> 'c) -> ('c, 't) pt -> ('c, 't) pt - - (** Map the type of the name bound by a given declaration. *) - val map_type : ('t -> 't) -> ('c, 't) pt -> ('c, 't) pt - - (** Map all terms in a given declaration. *) - val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt - - (** Perform a given action on all terms in a given declaration. *) - val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit - - (** Reduce all terms in a given declaration to a single value. *) - val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - end - - (** Rel-context is represented as a list of declarations. - Inner-most declarations are at the beginning of the list. - Outer-most declarations are at the end of the list. *) - type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list - - (** empty rel-context *) - val empty : ('c, 't) pt - - (** Return a new rel-context enriched by with a given inner-most declaration. *) - val add : ('c, 't) Declaration.pt -> ('c, 't) pt -> ('c, 't) pt - - (** Return the number of {e local declarations} in a given context. *) - val length : ('c, 't) pt -> int - - (** Check whether given two rel-contexts are equal. *) - val equal : ('c -> 'c -> bool) -> ('c, 'c) pt -> ('c, 'c) pt -> bool - - (** Return the number of {e local assumptions} in a given rel-context. *) - val nhyps : ('c, 't) pt -> int - - (** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated de Bruijn index outside the range. *) - val lookup : int -> ('c, 't) pt -> ('c, 't) Declaration.pt - - (** Map all terms in a given rel-context. *) - val map : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt - - (** Perform a given action on every declaration in a given rel-context. *) - val iter : ('c -> unit) -> ('c, 'c) pt -> unit - - (** Reduce all terms in a given rel-context to a single value. - Innermost declarations are processed first. *) - val fold_inside : ('a -> ('c, 't) Declaration.pt -> 'a) -> init:'a -> ('c, 't) pt -> 'a - - (** Reduce all terms in a given rel-context to a single value. - Outermost declarations are processed first. *) - val fold_outside : (('c, 't) Declaration.pt -> 'a -> 'a) -> ('c, 't) pt -> init:'a -> 'a - - (** [extended_vect n Γ] does the same, returning instead an array. *) - val to_extended_vect : (int -> 'r) -> int -> ('c, 't) pt -> 'r array - end - module Named : - sig - module Declaration : - sig - (** local declaration *) - type ('constr, 'types) pt = - | LocalAssum of Names.Id.t * 'types (** identifier, type *) - | LocalDef of Names.Id.t * 'constr * 'types (** identifier, value, type *) - - type t = (Constr.constr, Constr.types) pt - - (** Return the identifier bound by a given declaration. *) - val get_id : ('c, 't) pt -> Names.Id.t - - (** Return the type of the name bound by a given declaration. *) - val get_type : ('c, 't) pt -> 't - - (** Set the identifier that is bound by a given declaration. *) - val set_id : Names.Id.t -> ('c, 't) pt -> ('c, 't) pt - - (** Set the type of the bound variable in a given declaration. *) - val set_type : 't -> ('c, 't) pt -> ('c, 't) pt - - (** Return [true] iff a given declaration is a local assumption. *) - val is_local_assum : ('c, 't) pt -> bool - - (** Return [true] iff a given declaration is a local definition. *) - val is_local_def : ('c, 't) pt -> bool - - (** Check whether any term in a given declaration satisfies a given predicate. *) - val exists : ('c -> bool) -> ('c, 'c) pt -> bool - - (** Check whether all terms in a given declaration satisfy a given predicate. *) - val for_all : ('c -> bool) -> ('c, 'c) pt -> bool - - (** Check whether the two given declarations are equal. *) - val equal : ('c -> 'c -> bool) -> ('c, 'c) pt -> ('c, 'c) pt -> bool - - (** Map the identifier bound by a given declaration. *) - val map_id : (Names.Id.t -> Names.Id.t) -> ('c, 't) pt -> ('c, 't) pt - - (** For local assumptions, this function returns the original local assumptions. - For local definitions, this function maps the value in the local definition. *) - val map_value : ('c -> 'c) -> ('c, 't) pt -> ('c, 't) pt - - (** Map the type of the name bound by a given declaration. *) - val map_type : ('t -> 't) -> ('c, 't) pt -> ('c, 't) pt - - (** Map all terms in a given declaration. *) - val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt - - (** Perform a given action on all terms in a given declaration. *) - val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit - - (** Reduce all terms in a given declaration to a single value. *) - val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - - val to_rel_decl : ('c, 't) pt -> ('c, 't) Rel.Declaration.pt - end - (** Named-context is represented as a list of declarations. - Inner-most declarations are at the beginning of the list. - Outer-most declarations are at the end of the list. *) - type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list - - (** empty named-context *) - val empty : ('c, 't) pt - - (** Return a new named-context enriched by with a given inner-most declaration. *) - val add : ('c, 't) Declaration.pt -> ('c, 't) pt -> ('c, 't) pt - - (** Return the number of {e local declarations} in a given named-context. *) - val length : ('c, 't) pt -> int - - (** Return a declaration designated by an identifier of the variable bound in that declaration. - @raise Not_found if the designated identifier is not bound in a given named-context. *) - val lookup : Names.Id.t -> ('c, 't) pt -> ('c, 't) Declaration.pt - - (** Check whether given two named-contexts are equal. *) - val equal : ('c -> 'c -> bool) -> ('c, 'c) pt -> ('c, 'c) pt -> bool - - (** Map all terms in a given named-context. *) - val map : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt - - (** Perform a given action on every declaration in a given named-context. *) - val iter : ('c -> unit) -> ('c, 'c) pt -> unit - - (** Reduce all terms in a given named-context to a single value. - Innermost declarations are processed first. *) - val fold_inside : ('a -> ('c, 't) Declaration.pt -> 'a) -> init:'a -> ('c, 't) pt -> 'a - - (** Reduce all terms in a given named-context to a single value. - Outermost declarations are processed first. *) - val fold_outside : (('c, 't) Declaration.pt -> 'a -> 'a) -> ('c, 't) pt -> init:'a -> 'a - - (** Return the set of all identifiers bound in a given named-context. *) - val to_vars : ('c, 't) pt -> Names.Id.Set.t - - (** [to_instance Ω] builds an instance [args] such - that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local - definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it - gives [Var id1, Var id3]. All [idj] are supposed distinct. *) - val to_instance : (Names.Id.t -> 'r) -> ('c, 't) pt -> 'r list - end -end - -module Vars : -sig - type substl = Constr.t list - - val substl : substl -> Constr.t -> Constr.t - - val subst1 : Constr.t -> Constr.t -> Constr.t - - val lift : int -> Constr.t -> Constr.t - - val closed0 : Constr.t -> bool - - val closedn : int -> Constr.t -> bool - - val replace_vars : (Names.Id.t * Constr.t) list -> Constr.t -> Constr.t - - val noccurn : int -> Constr.t -> bool - val subst_var : Names.Id.t -> Constr.t -> Constr.t - val subst_vars : Names.Id.t list -> Constr.t -> Constr.t - val substnl : substl -> int -> Constr.t -> Constr.t -end - -module Term : -sig - - open Constr - type sorts_family = Sorts.family = InProp | InSet | InType - [@@ocaml.deprecated "Alias of Sorts.family"] - - type contents = Sorts.contents = Pos | Null - [@@ocaml.deprecated "Alias of Sorts.contents"] - - type sorts = Sorts.t = - | Prop of Sorts.contents - | Type of Univ.Universe.t - [@@ocaml.deprecated "alias of API.Sorts.t"] - - type metavariable = int - [@@ocaml.deprecated "Alias of Constr.metavariable"] - - type ('constr, 'types) prec_declaration = Names.Name.t array * 'types array * 'constr array - [@@ocaml.deprecated "Alias of Constr.prec_declaration"] - - type 'constr pexistential = 'constr Constr.pexistential - [@@ocaml.deprecated "Alias of Constr.pexistential"] - - type cast_kind = Constr.cast_kind = - | VMcast - | NATIVEcast - | DEFAULTcast - | REVERTcast - [@@ocaml.deprecated "Alias of Constr.cast_kind"] - - type 'a puniverses = 'a Univ.puniverses - [@@ocaml.deprecated "Alias of Constr.puniverses"] - type pconstant = Names.Constant.t Univ.puniverses - [@@ocaml.deprecated "Alias of Constr.pconstant"] - type pinductive = Names.inductive Univ.puniverses - [@@ocaml.deprecated "Alias of Constr.pinductive"] - type pconstructor = Names.constructor Univ.puniverses - [@@ocaml.deprecated "Alias of Constr.pconstructor"] - type case_style = Constr.case_style = - | LetStyle - | IfStyle - | LetPatternStyle - | MatchStyle - | RegularStyle - [@@ocaml.deprecated "Alias of Constr.case_style"] - - type case_printing = Constr.case_printing = - { ind_tags : bool list; - cstr_tags : bool list array; - style : Constr.case_style - } - [@@ocaml.deprecated "Alias of Constr.case_printing"] - - type case_info = Constr.case_info = - { ci_ind : Names.inductive; - ci_npar : int; - ci_cstr_ndecls: int array; - ci_cstr_nargs : int array; - ci_pp_info : Constr.case_printing - } - [@@ocaml.deprecated "Alias of Constr.case_info"] - - type ('constr, 'types) pfixpoint = - (int array * int) * ('constr, 'types) Constr.prec_declaration - [@@ocaml.deprecated "Alias of Constr.pfixpoint"] - - type ('constr, 'types) pcofixpoint = - int * ('constr, 'types) Constr.prec_declaration - [@@ocaml.deprecated "Alias of Constr.pcofixpoint"] - - type ('constr, 'types, 'sort, 'univs) kind_of_term = ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = - | Rel of int - | Var of Names.Id.t - | Meta of Constr.metavariable - | Evar of 'constr Constr.pexistential - | Sort of 'sort - | Cast of 'constr * Constr.cast_kind * 'types - | Prod of Names.Name.t * 'types * 'types - | Lambda of Names.Name.t * 'types * 'constr - | LetIn of Names.Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array - | Const of (Names.Constant.t * 'univs) - | Ind of (Names.inductive * 'univs) - | Construct of (Names.constructor * 'univs) - | Case of Constr.case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) Constr.pfixpoint - | CoFix of ('constr, 'types) Constr.pcofixpoint - | Proj of Names.Projection.t * 'constr - [@@ocaml.deprecated "Alias of Constr.kind_of_term"] - type existential = Evar.t * Constr.constr array - [@@ocaml.deprecated "Alias of Constr.existential"] - type rec_declaration = Names.Name.t array * Constr.constr array * Constr.constr array - [@@ocaml.deprecated "Alias of Constr.rec_declaration"] - val kind_of_term : Constr.constr -> (Constr.constr, Constr.types, Sorts.t, Univ.Instance.t) Constr.kind_of_term - [@@ocaml.deprecated "Alias of Constr.kind"] - val applistc : Constr.constr -> Constr.constr list -> Constr.constr - - val applist : constr * constr list -> constr - [@@ocaml.deprecated "(sort of an) alias of API.Term.applistc"] - - val mkArrow : types -> types -> constr - val mkRel : int -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkVar : Names.Id.t -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - - val mkMeta : Constr.metavariable -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - - val mkEvar : Constr.existential -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkSort : Sorts.t -> types - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkProp : types - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkSet : types - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkType : Univ.Universe.t -> types - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCast : constr * Constr.cast_kind * constr -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkProd : Names.Name.t * types * types -> types - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkLambda : Names.Name.t * types * constr -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkLetIn : Names.Name.t * constr * types * constr -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkApp : constr * constr array -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConst : Names.Constant.t -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkProj : Names.Projection.t * constr -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkInd : Names.inductive -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstruct : Names.constructor -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructU : Names.constructor Univ.puniverses -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructUi : (Constr.pinductive * int) -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCase : Constr.case_info * constr * constr * constr array -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkFix : fixpoint -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCoFix : cofixpoint -> constr - [@@ocaml.deprecated "Alias of similarly named Constr function"] - - val mkNamedLambda : Names.Id.t -> types -> constr -> constr - val mkNamedLetIn : Names.Id.t -> constr -> types -> constr -> constr - val mkNamedProd : Names.Id.t -> types -> types -> types - - val decompose_app : constr -> constr * constr list - [@@ocaml.deprecated "Alias for the function in [Constr]"] - - val decompose_prod : constr -> (Names.Name.t*constr) list * constr - val decompose_prod_n : int -> constr -> (Names.Name.t * constr) list * constr - val decompose_prod_assum : types -> Context.Rel.t * types - val decompose_lam : constr -> (Names.Name.t * constr) list * constr - val decompose_lam_n : int -> constr -> (Names.Name.t * constr) list * constr - val decompose_prod_n_assum : int -> types -> Context.Rel.t * types - - val compose_prod : (Names.Name.t * constr) list -> constr -> constr - val compose_lam : (Names.Name.t * constr) list -> constr -> constr - - val destSort : constr -> Sorts.t - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destVar : constr -> Names.Id.t - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destApp : constr -> constr * constr array - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destProd : types -> Names.Name.t * types * types - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destLetIn : constr -> Names.Name.t * constr * types * constr - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destEvar : constr -> Constr.existential - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destRel : constr -> int - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destConst : constr -> Names.Constant.t Univ.puniverses - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destCast : constr -> constr * Constr.cast_kind * constr - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val destLambda : constr -> Names.Name.t * types * constr - [@@ocaml.deprecated "Alias for the function in [Constr]"] - - val isRel : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isVar : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isEvar : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isLetIn : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isLambda : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isConst : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isEvar_or_Meta : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isCast : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isMeta : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val isApp : constr -> bool - [@@ocaml.deprecated "Alias for the function in [Constr]"] - - val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a - [@@ocaml.deprecated "Alias of Constr.fold"] - - val eq_constr : constr -> constr -> bool - [@@ocaml.deprecated "Alias of Constr.equal"] - - val hash_constr : constr -> int - [@@ocaml.deprecated "Alias of Constr.hash"] - - val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr - val it_mkProd_or_LetIn : types -> Context.Rel.t -> types - val prod_applist : constr -> constr list -> constr - - val map_constr : (constr -> constr) -> constr -> constr - [@@ocaml.deprecated "Alias of Constr.map"] - - val mkIndU : Constr.pinductive -> constr - [@@ocaml.deprecated "Alias of Constr.mkIndU"] - val mkConstU : Constr.pconstant -> constr - [@@ocaml.deprecated "Alias of Constr.mkConstU"] - val map_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr - [@@ocaml.deprecated "Alias of Constr.map_with_binders"] - - val iter_constr : (constr -> unit) -> constr -> unit - [@@ocaml.deprecated "Alias of Constr.iter."] - - (* Quotients away universes: really needed? - * Can't we just call eq_c_univs_infer and discard the inferred csts? - *) - val eq_constr_nounivs : constr -> constr -> bool - [@@ocaml.deprecated "Alias of Constr.qe_constr_nounivs."] - - type ('constr, 'types) kind_of_type = - | SortType of Sorts.t - | CastType of 'types * 'types - | ProdType of Names.Name.t * 'types * 'types - | LetInType of Names.Name.t * 'constr * 'types * 'types - | AtomicType of 'constr * 'constr array - - val kind_of_type : types -> (constr, types) kind_of_type - - val is_prop_sort : Sorts.t -> bool - [@@ocaml.deprecated "alias of API.Sorts.is_prop"] - - type existential_key = Evar.t - [@@ocaml.deprecated "Alias of Constr.existential_key"] - - val family_of_sort : Sorts.t -> Sorts.family - [@@ocaml.deprecated "Alias of Sorts.family"] - - val compare : constr -> constr -> int - [@@ocaml.deprecated "Alias of Constr.compare."] - - val constr_ord : constr -> constr -> int - [@@ocaml.deprecated "alias of Term.compare"] - - val destInd : constr -> Names.inductive Univ.puniverses - [@@ocaml.deprecated "Alias for the function in [Constr]"] - val univ_of_sort : Sorts.t -> Univ.Universe.t - [@@ocaml.deprecated "Alias for the function in [Constr]"] - - val strip_lam : constr -> constr - val strip_prod_assum : types -> types - - val decompose_lam_assum : constr -> Context.Rel.t * constr - val destFix : constr -> fixpoint - [@@ocaml.deprecated "Alias for the function in [Constr]"] - - val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool - [@@ocaml.deprecated "Alias of Constr.compare_head."] - - type constr = Constr.t - [@@ocaml.deprecated "Alias of Constr.t"] - type types = Constr.t - [@@ocaml.deprecated "Alias of Constr.types"] - - type fixpoint = (int array * int) * Constr.rec_declaration - [@@ocaml.deprecated "Alias of Constr.Constr.fixpoint"] - type cofixpoint = int * Constr.rec_declaration - [@@ocaml.deprecated "Alias of Constr.cofixpoint"] - -end - -module Mod_subst : -sig - type delta_resolver - type substitution - type 'a substituted - - val force_constr : Constr.t substituted -> Constr.t - - val empty_delta_resolver : delta_resolver - val constant_of_delta_kn : delta_resolver -> Names.KerName.t -> Names.Constant.t - val mind_of_delta_kn : delta_resolver -> Names.KerName.t -> Names.MutInd.t - val subst_kn : substitution -> Names.KerName.t -> Names.KerName.t - val subst_evaluable_reference : - substitution -> Names.evaluable_global_reference -> Names.evaluable_global_reference - val subst_mps : substitution -> Constr.t -> Constr.t - val subst_constant : substitution -> Names.Constant.t -> Names.Constant.t - val subst_ind : substitution -> Names.inductive -> Names.inductive - val debug_pr_subst : substitution -> Pp.t - val debug_pr_delta : delta_resolver -> Pp.t -end - -module Opaqueproof : -sig - type opaquetab - type opaque - val empty_opaquetab : opaquetab - val force_proof : opaquetab -> opaque -> Constr.t -end - -module Cbytecodes : -sig - type tag = int - type reloc_table = (tag * int) array -end - -module Cemitcodes : -sig - type to_patch_substituted -end - -module Decl_kinds : -sig - type polymorphic = bool - type cumulative_inductive_flag = bool - type recursivity_kind = - | Finite - | CoFinite - | BiFinite - - type locality = - | Discharge - | Local - | Global - - type definition_object_kind = - | Definition - | Coercion - | SubClass - | CanonicalStructure - | Example - | Fixpoint - | CoFixpoint - | Scheme - | StructureComponent - | IdentityCoercion - | Instance - | Method - type theorem_kind = - | Theorem - | Lemma - | Fact - | Remark - | Property - | Proposition - | Corollary - type goal_object_kind = - | DefinitionBody of definition_object_kind - | Proof of theorem_kind - type goal_kind = locality * polymorphic * goal_object_kind - type assumption_object_kind = - | Definitional - | Logical - | Conjectural - type logical_kind = - | IsAssumption of assumption_object_kind - | IsDefinition of definition_object_kind - | IsProof of theorem_kind - type binding_kind = - | Explicit - | Implicit - type private_flag = bool - type definition_kind = locality * polymorphic * definition_object_kind -end - -module Retroknowledge : -sig - type action - type nat_field = - | NatType - | NatPlus - | NatTimes - type n_field = - | NPositive - | NType - | NTwice - | NTwicePlusOne - | NPhi - | NPhiInv - | NPlus - | NTimes - type int31_field = - | Int31Bits - | Int31Type - | Int31Constructor - | Int31Twice - | Int31TwicePlusOne - | Int31Phi - | Int31PhiInv - | Int31Plus - | Int31PlusC - | Int31PlusCarryC - | Int31Minus - | Int31MinusC - | Int31MinusCarryC - | Int31Times - | Int31TimesC - | Int31Div21 - | Int31Div - | Int31Diveucl - | Int31AddMulDiv - | Int31Compare - | Int31Head0 - | Int31Tail0 - | Int31Lor - | Int31Land - | Int31Lxor - type field = - | KInt31 of string * int31_field -end - -module Conv_oracle : -sig - type level -end - -module Declarations : -sig - - open Names - - type recarg = - | Norec - | Mrec of Names.inductive - | Imbr of Names.inductive - type wf_paths = recarg Rtree.t - type inline = int option - type constant_def = - | Undef of inline - | Def of Constr.t Mod_subst.substituted - | OpaqueDef of Opaqueproof.opaque - type template_arity = { - template_param_levels : Univ.Level.t option list; - template_level : Univ.Universe.t; - } - - type ('a, 'b) declaration_arity = - | RegularArity of 'a - | TemplateArity of 'b - - type constant_universes = - | Monomorphic_const of Univ.ContextSet.t - | Polymorphic_const of Univ.AUContext.t - - type projection_body = { - proj_ind : Names.MutInd.t; - proj_npars : int; - proj_arg : int; - proj_type : Constr.types; - proj_eta : Constr.t * Constr.types; - proj_body : Constr.t; - } - - type typing_flags = { - check_guarded : bool; - check_universes : bool; - } - - type constant_body = { - const_hyps : Context.Named.t; - const_body : constant_def; - const_type : Constr.types; - const_body_code : Cemitcodes.to_patch_substituted option; - const_universes : constant_universes; - const_proj : projection_body option; - const_inline_code : bool; - const_typing_flags : typing_flags; - } - - type regular_inductive_arity = { - mind_user_arity : Constr.types; - mind_sort : Sorts.t; - } - - type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity - - type one_inductive_body = { - mind_typename : Names.Id.t; - mind_arity_ctxt : Context.Rel.t; - mind_arity : inductive_arity; - mind_consnames : Names.Id.t array; - mind_user_lc : Constr.types array; - mind_nrealargs : int; - mind_nrealdecls : int; - mind_kelim : Sorts.family list; - mind_nf_lc : Constr.types array; - mind_consnrealargs : int array; - mind_consnrealdecls : int array; - mind_recargs : wf_paths; - mind_nb_constant : int; - mind_nb_args : int; - mind_reloc_tbl : Cbytecodes.reloc_table; - } - - type ('ty,'a) functorize = - | NoFunctor of 'a - | MoreFunctor of Names.MBId.t * 'ty * ('ty,'a) functorize - - type with_declaration = - | WithMod of Names.Id.t list * Names.ModPath.t - | WithDef of Names.Id.t list * Constr.t Univ.in_universe_context - - type module_alg_expr = - | MEident of Names.ModPath.t - | MEapply of module_alg_expr * Names.ModPath.t - | MEwith of module_alg_expr * with_declaration - - type abstract_inductive_universes = - | Monomorphic_ind of Univ.ContextSet.t - | Polymorphic_ind of Univ.AUContext.t - | Cumulative_ind of Univ.ACumulativityInfo.t - - type record_body = (Id.t * Constant.t array * projection_body array) option - - type mutual_inductive_body = { - mind_packets : one_inductive_body array; - mind_record : record_body option; - mind_finite : Decl_kinds.recursivity_kind; - mind_ntypes : int; - mind_hyps : Context.Named.t; - mind_nparams : int; - mind_nparams_rec : int; - mind_params_ctxt : Context.Rel.t; - mind_universes : abstract_inductive_universes; - mind_private : bool option; - mind_typing_flags : typing_flags; - } - and module_expression = (module_type_body,module_alg_expr) functorize - and module_implementation = - | Abstract - | Algebraic of module_expression - | Struct of module_signature - | FullStruct - and 'a generic_module_body = - { mod_mp : Names.ModPath.t; - mod_expr : 'a; - mod_type : module_signature; - mod_type_alg : module_expression option; - mod_constraints : Univ.ContextSet.t; - mod_delta : Mod_subst.delta_resolver; - mod_retroknowledge : 'a module_retroknowledge; - } - and module_signature = (module_type_body,structure_body) functorize - and module_body = module_implementation generic_module_body - and module_type_body = unit generic_module_body - and structure_body = (Names.Label.t * structure_field_body) list - and structure_field_body = - | SFBconst of constant_body - | SFBmind of mutual_inductive_body - | SFBmodule of module_body - | SFBmodtype of module_type_body - and _ module_retroknowledge = - | ModBodyRK : - Retroknowledge.action list -> module_implementation module_retroknowledge - | ModTypeRK : unit module_retroknowledge -end - -module Declareops : -sig - val constant_has_body : Declarations.constant_body -> bool - val is_opaque : Declarations.constant_body -> bool - val eq_recarg : Declarations.recarg -> Declarations.recarg -> bool -end - -module Entries : -sig - - open Names - open Constr - - type local_entry = - | LocalDefEntry of constr - | LocalAssumEntry of constr - - type inductive_universes = - | Monomorphic_ind_entry of Univ.ContextSet.t - | Polymorphic_ind_entry of Univ.UContext.t - | Cumulative_ind_entry of Univ.CumulativityInfo.t - - type one_inductive_entry = { - mind_entry_typename : Id.t; - mind_entry_arity : constr; - mind_entry_template : bool; (* Use template polymorphism *) - mind_entry_consnames : Id.t list; - mind_entry_lc : constr list } - - type mutual_inductive_entry = { - mind_entry_record : (Names.Id.t option) option; - (** Some (Some id): primitive record with id the binder name of the record - in projections. - Some None: non-primitive record *) - mind_entry_finite : Decl_kinds.recursivity_kind; - mind_entry_params : (Id.t * local_entry) list; - mind_entry_inds : one_inductive_entry list; - mind_entry_universes : inductive_universes; - (* universe constraints and the constraints for subtyping of - inductive types in the block. *) - mind_entry_private : bool option; - } - - type inline = int option - type 'a proof_output = Constr.t Univ.in_universe_context_set * 'a - type 'a const_entry_body = 'a proof_output Future.computation - type constant_universes_entry = - | Monomorphic_const_entry of Univ.ContextSet.t - | Polymorphic_const_entry of Univ.UContext.t - type 'a in_constant_universes_entry = 'a * constant_universes_entry - type 'a definition_entry = - { const_entry_body : 'a const_entry_body; - (* List of section variables *) - const_entry_secctx : Context.Named.t option; - (* State id on which the completion of type checking is reported *) - const_entry_feedback : Stateid.t option; - const_entry_type : Constr.types option; - const_entry_universes : constant_universes_entry; - const_entry_opaque : bool; - const_entry_inline_code : bool } - type parameter_entry = Context.Named.t option * Constr.types in_constant_universes_entry * inline - - type projection_entry = { - proj_entry_ind : MutInd.t; - proj_entry_arg : int } - - type 'a constant_entry = - | DefinitionEntry of 'a definition_entry - | ParameterEntry of parameter_entry - | ProjectionEntry of projection_entry - type module_struct_entry = Declarations.module_alg_expr - type module_params_entry = - (Names.MBId.t * module_struct_entry) list - type module_type_entry = module_params_entry * module_struct_entry -end - -module Environ : -sig - type env - type named_context_val - - type ('constr, 'types) punsafe_judgment = - { - uj_val : 'constr; - uj_type : 'types - } - type 'types punsafe_type_judgment = { - utj_val : 'types; - utj_type : Sorts.t } - - type unsafe_type_judgment = Constr.types punsafe_type_judgment - val empty_env : env - val lookup_mind : Names.MutInd.t -> env -> Declarations.mutual_inductive_body - val push_rel : Context.Rel.Declaration.t -> env -> env - val push_rel_context : Context.Rel.t -> env -> env - val push_rec_types : Constr.rec_declaration -> env -> env - val lookup_rel : int -> env -> Context.Rel.Declaration.t - val lookup_named : Names.Id.t -> env -> Context.Named.Declaration.t - val lookup_named_val : Names.Id.t -> named_context_val -> Context.Named.Declaration.t - val lookup_constant : Names.Constant.t -> env -> Declarations.constant_body - val opaque_tables : env -> Opaqueproof.opaquetab - val is_projection : Names.Constant.t -> env -> bool - val lookup_projection : Names.Projection.t -> env -> Declarations.projection_body - val named_context_of_val : named_context_val -> Context.Named.t - val push_named : Context.Named.Declaration.t -> env -> env - val named_context : env -> Context.Named.t - val named_context_val : env -> named_context_val - val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val - val reset_with_named_context : named_context_val -> env -> env - val rel_context : env -> Context.Rel.t - val constant_value_in : env -> Names.Constant.t Univ.puniverses -> Constr.t - val named_type : Names.Id.t -> env -> Constr.types - val constant_opt_value_in : env -> Names.Constant.t Univ.puniverses -> Constr.t option - val fold_named_context_reverse : - ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a - val evaluable_named : Names.Id.t -> env -> bool - val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env -end - -module CClosure : -sig - - type table_key = Names.Constant.t Univ.puniverses Names.tableKey - - type fconstr - - type fterm = - | FRel of int - | FAtom of Constr.t (** Metas and Sorts *) - | FCast of fconstr * Constr.cast_kind * fconstr - | FFlex of table_key - | FInd of Names.inductive Univ.puniverses - | FConstruct of Names.constructor Univ.puniverses - | FApp of fconstr * fconstr array - | FProj of Names.Projection.t * fconstr - | FFix of Constr.fixpoint * fconstr Esubst.subs - | FCoFix of Constr.cofixpoint * fconstr Esubst.subs - | FCaseT of Constr.case_info * Constr.t * fconstr * Constr.t array * fconstr Esubst.subs (* predicate and branches are closures *) - | FLambda of int * (Names.Name.t * Constr.t) list * Constr.t * fconstr Esubst.subs - | FProd of Names.Name.t * fconstr * fconstr - | FLetIn of Names.Name.t * fconstr * fconstr * Constr.t * fconstr Esubst.subs - | FEvar of Constr.existential * fconstr Esubst.subs - | FLIFT of int * fconstr - | FCLOS of Constr.t * fconstr Esubst.subs - | FLOCKED - - module RedFlags : sig - type reds - type red_kind - val mkflags : red_kind list -> reds - val fBETA : red_kind - val fCOFIX : red_kind - val fCONST : Names.Constant.t -> red_kind - val fFIX : red_kind - val fMATCH : red_kind - val fZETA : red_kind - val red_add_transparent : reds -> Names.transparent_state -> reds - end - - type 'a infos_cache - type 'a infos = { - i_flags : RedFlags.reds; - i_cache : 'a infos_cache } - - type clos_infos = fconstr infos - - val mk_clos : fconstr Esubst.subs -> Constr.t -> fconstr - val mk_atom : Constr.t -> fconstr - val mk_clos_deep : - (fconstr Esubst.subs -> Constr.t -> fconstr) -> - fconstr Esubst.subs -> Constr.t -> fconstr - val mk_red : fterm -> fconstr - val all : RedFlags.reds - val beta : RedFlags.reds - val betaiota : RedFlags.reds - val betaiotazeta : RedFlags.reds - - val create_clos_infos : ?evars:(Constr.existential -> Constr.t option) -> RedFlags.reds -> Environ.env -> clos_infos - - val whd_val : clos_infos -> fconstr -> Constr.t - - val inject : Constr.t -> fconstr - - val kl : clos_infos -> fconstr -> Constr.t - val term_of_fconstr : fconstr -> Constr.t -end - -module Reduction : -sig - exception NotConvertible - type conv_pb = - | CONV - | CUMUL - - val whd_all : Environ.env -> Constr.t -> Constr.t - - val whd_betaiotazeta : Environ.env -> Constr.t -> Constr.t - - val is_arity : Environ.env -> Constr.types -> bool - - val dest_prod : Environ.env -> Constr.types -> Context.Rel.t * Constr.types - - type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> Environ.env -> - ?evars:((Constr.existential->Constr.t option) * UGraph.t) -> - 'a -> 'a -> unit - val conv : Constr.t extended_conversion_function -end - -module Type_errors : -sig - - open Names - open Constr - open Environ - - type 'constr pguard_error = - (** Fixpoints *) - | NotEnoughAbstractionInFixBody - | RecursionNotOnInductiveType of 'constr - | RecursionOnIllegalTerm of int * (env * 'constr) * int list * int list - | NotEnoughArgumentsForFixCall of int - (** CoFixpoints *) - | CodomainNotInductiveType of 'constr - | NestedRecursiveOccurrences - | UnguardedRecursiveCall of 'constr - | RecCallInTypeOfAbstraction of 'constr - | RecCallInNonRecArgOfConstructor of 'constr - | RecCallInTypeOfDef of 'constr - | RecCallInCaseFun of 'constr - | RecCallInCaseArg of 'constr - | RecCallInCasePred of 'constr - | NotGuardedForm of 'constr - | ReturnPredicateNotCoInductive of 'constr - - type arity_error = - | NonInformativeToInformative - | StrongEliminationOnNonSmallType - | WrongArity - - type ('constr, 'types) ptype_error = - | UnboundRel of int - | UnboundVar of variable - | NotAType of ('constr, 'types) punsafe_judgment - | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option - | CaseNotInductive of ('constr, 'types) punsafe_judgment - | WrongCaseInfo of pinductive * case_info - | NumberBranches of ('constr, 'types) punsafe_judgment * int - | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr - | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment - | ActualType of ('constr, 'types) punsafe_judgment * 'types - | CantApplyBadType of - (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array - | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.Constraint.t - - type type_error = (constr, types) ptype_error - - exception TypeError of Environ.env * type_error -end - -module Modops : -sig - val destr_nofunctor : ('ty,'a) Declarations.functorize -> 'a - val add_structure : - Names.ModPath.t -> Declarations.structure_body -> Mod_subst.delta_resolver -> - Environ.env -> Environ.env - val add_module_type : Names.ModPath.t -> Declarations.module_type_body -> Environ.env -> Environ.env -end - -module Inductive : -sig - type mind_specif = Declarations.mutual_inductive_body * Declarations.one_inductive_body - val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Constr.types - exception SingletonInductiveBecomesProp of Names.Id.t - val lookup_mind_specif : Environ.env -> Names.inductive -> mind_specif - val find_inductive : Environ.env -> Constr.types -> Constr.pinductive * Constr.t list -end - -module Typeops : -sig - val infer_type : Environ.env -> Constr.types -> Environ.unsafe_type_judgment - val type_of_constant_in : Environ.env -> Constr.pconstant -> Constr.types -end - -module Mod_typing : -sig - type 'alg translation = - Declarations.module_signature * 'alg * Mod_subst.delta_resolver * Univ.ContextSet.t - val translate_modtype : - Environ.env -> Names.ModPath.t -> Entries.inline -> - Entries.module_type_entry -> Declarations.module_type_body - val translate_mse : - Environ.env -> Names.ModPath.t option -> Entries.inline -> Declarations.module_alg_expr -> - Declarations.module_alg_expr translation -end - -module Safe_typing : -sig - type private_constants - val mk_pure_proof : Constr.t -> private_constants Entries.proof_output -end - -(************************************************************************) -(* End of modules from kernel/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from intf/ *) -(************************************************************************) - -module Misctypes : -sig - type evars_flag = bool - type clear_flag = bool option - type advanced_flag = bool - type rec_flag = bool - - type 'a or_by_notation = - | AN of 'a - | ByNotation of (string * string option) Loc.located - - type 'a or_var = - | ArgArg of 'a - | ArgVar of Names.Id.t Loc.located - - type 'a and_short_name = 'a * Names.Id.t Loc.located option - - type 'a glob_sort_gen = - | GProp (** representation of [Prop] literal *) - | GSet (** representation of [Set] literal *) - | GType of 'a (** representation of [Type] literal *) - - type level_info = Names.Name.t Loc.located option - type glob_level = level_info glob_sort_gen - - type sort_info = Names.Name.t Loc.located list - type glob_sort = sort_info glob_sort_gen - - type ('a, 'b) gen_universe_decl = { - univdecl_instance : 'a; (* Declared universes *) - univdecl_extensible_instance : bool; (* Can new universes be added *) - univdecl_constraints : 'b; (* Declared constraints *) - univdecl_extensible_constraints : bool (* Can new constraints be added *) } - - type glob_constraint = glob_level * Univ.constraint_type * glob_level - - type case_style = Constr.case_style = - | LetStyle - | IfStyle - | LetPatternStyle - | MatchStyle - | RegularStyle (** infer printing form from number of constructor *) - [@@ocaml.deprecated "Alias for Constr.case_style."] - - type 'a cast_type = - | CastConv of 'a - | CastVM of 'a - | CastCoerce - | CastNative of 'a - - type 'constr intro_pattern_expr = - | IntroForthcoming of bool - | IntroNaming of intro_pattern_naming_expr - | IntroAction of 'constr intro_pattern_action_expr - and intro_pattern_naming_expr = - | IntroIdentifier of Names.Id.t - | IntroFresh of Names.Id.t - | IntroAnonymous - and 'constr intro_pattern_action_expr = - | IntroWildcard - | IntroOrAndPattern of 'constr or_and_intro_pattern_expr - | IntroInjection of ('constr intro_pattern_expr) Loc.located list - | IntroApplyOn of 'constr Loc.located * 'constr intro_pattern_expr Loc.located - | IntroRewrite of bool - and 'constr or_and_intro_pattern_expr = - | IntroOrPattern of ('constr intro_pattern_expr) Loc.located list list - | IntroAndPattern of ('constr intro_pattern_expr) Loc.located list - - type quantified_hypothesis = - | AnonHyp of int - | NamedHyp of Names.Id.t - - type 'a explicit_bindings = (quantified_hypothesis * 'a) Loc.located list - - type 'a bindings = - | ImplicitBindings of 'a list - | ExplicitBindings of 'a explicit_bindings - | NoBindings - - type 'a with_bindings = 'a * 'a bindings - - type 'a core_destruction_arg = - | ElimOnConstr of 'a - | ElimOnIdent of Names.Id.t Loc.located - | ElimOnAnonHyp of int - - type inversion_kind = - | SimpleInversion - | FullInversion - | FullInversionClear - - type multi = - | Precisely of int - | UpTo of int - | RepeatStar - | RepeatPlus - type 'id move_location = - | MoveAfter of 'id - | MoveBefore of 'id - | MoveFirst - | MoveLast - - type 'a destruction_arg = clear_flag * 'a core_destruction_arg - -end - -module Locus : -sig - type 'a occurrences_gen = - | AllOccurrences - | AllOccurrencesBut of 'a list (** non-empty *) - | NoOccurrences - | OnlyOccurrences of 'a list (** non-empty *) - type occurrences = int occurrences_gen - type occurrences_expr = (int Misctypes.or_var) occurrences_gen - type 'a with_occurrences = occurrences_expr * 'a - type hyp_location_flag = - InHyp | InHypTypeOnly | InHypValueOnly - type 'a hyp_location_expr = 'a with_occurrences * hyp_location_flag - type 'id clause_expr = - { onhyps : 'id hyp_location_expr list option; - concl_occs : occurrences_expr } - type clause = Names.Id.t clause_expr - type hyp_location = Names.Id.t * hyp_location_flag - type goal_location = hyp_location option -end - -(************************************************************************) -(* End Modules from intf/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from library/ *) -(************************************************************************) - -module Univops : -sig - val universes_of_constr : Constr.constr -> Univ.LSet.t - val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t -end - -module Nameops : -sig - - open Names - - val atompart_of_id : Names.Id.t -> string - - val pr_id : Names.Id.t -> Pp.t - [@@ocaml.deprecated "alias of API.Names.Id.print"] - - val pr_name : Names.Name.t -> Pp.t - [@@ocaml.deprecated "alias of API.Names.Name.print"] - - module Name : sig - include module type of struct include Name end - - val map : (Id.t -> Id.t) -> Name.t -> t - val get_id : t -> Names.Id.t - val fold_right : (Names.Id.t -> 'a -> 'a) -> t -> 'a -> 'a - - end - - val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a - [@@ocaml.deprecated "alias of API.Names"] - - val name_app : (Id.t -> Id.t) -> Name.t -> Name.t - [@@ocaml.deprecated "alias of API.Names"] - - val add_suffix : Id.t -> string -> Id.t - val increment_subscript : Id.t -> Id.t - val make_ident : string -> int option -> Id.t - val out_name : Name.t -> Id.t - [@@ocaml.deprecated "alias of API.Names"] - val pr_lab : Label.t -> Pp.t - [@@ocaml.deprecated "alias of API.Names"] -end - -module Libnames : -sig - - open Util - open Names - - type full_path - val pr_path : full_path -> Pp.t - val make_path : Names.DirPath.t -> Names.Id.t -> full_path - val eq_full_path : full_path -> full_path -> bool - val repr_path : full_path -> Names.DirPath.t * Names.Id.t - val dirpath : full_path -> Names.DirPath.t - val path_of_string : string -> full_path - - type qualid - val make_qualid : Names.DirPath.t -> Names.Id.t -> qualid - val qualid_eq : qualid -> qualid -> bool - val repr_qualid : qualid -> Names.DirPath.t * Names.Id.t - val pr_qualid : qualid -> Pp.t - val string_of_qualid : qualid -> string - val qualid_of_string : string -> qualid - val qualid_of_path : full_path -> qualid - val qualid_of_dirpath : Names.DirPath.t -> qualid - val qualid_of_ident : Names.Id.t -> qualid - - type reference = - | Qualid of qualid Loc.located - | Ident of Names.Id.t Loc.located - val loc_of_reference : reference -> Loc.t option - val qualid_of_reference : reference -> qualid Loc.located - val pr_reference : reference -> Pp.t - - val is_dirpath_prefix_of : Names.DirPath.t -> Names.DirPath.t -> bool - val split_dirpath : Names.DirPath.t -> Names.DirPath.t * Names.Id.t - val dirpath_of_string : string -> Names.DirPath.t - val pr_dirpath : Names.DirPath.t -> Pp.t - [@@ocaml.deprecated "Alias for DirPath.print"] - - val string_of_path : full_path -> string - - val basename : full_path -> Names.Id.t - - type object_name = full_path * Names.KerName.t - type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) - - module Dirset : Set.S with type elt = DirPath.t - module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset - module Spmap : CSig.MapS with type key = full_path -end - -module Globnames : -sig - - open Util - - type global_reference = - | VarRef of Names.Id.t - | ConstRef of Names.Constant.t - | IndRef of Names.inductive - | ConstructRef of Names.constructor - - type extended_global_reference = - | TrueGlobal of global_reference - | SynDef of Names.KerName.t - - (* Long term: change implementation so that only 1 kind of order is needed. - * Today: _env ones are fine grained, which one to pick depends. Eg. - * - conversion rule are implemented by the non_env ones - * - pretty printing (of user provided names/aliases) are implemented by - * the _env ones - *) - module Refset : CSig.SetS with type elt = global_reference - module Refmap : Map.ExtS - with type key = global_reference and module Set := Refset - - module Refset_env : CSig.SetS with type elt = global_reference - module Refmap_env : Map.ExtS - with type key = global_reference and module Set := Refset_env - - module RefOrdered : - sig - type t = global_reference - val compare : t -> t -> int - end - - val pop_global_reference : global_reference -> global_reference - val eq_gr : global_reference -> global_reference -> bool - val destIndRef : global_reference -> Names.inductive - - val encode_mind : Names.DirPath.t -> Names.Id.t -> Names.MutInd.t - val encode_con : Names.DirPath.t -> Names.Id.t -> Names.Constant.t - - val global_of_constr : Constr.t -> global_reference - - val subst_global : Mod_subst.substitution -> global_reference -> global_reference * Constr.t - val destConstructRef : global_reference -> Names.constructor - - val reference_of_constr : Constr.t -> global_reference - [@@ocaml.deprecated "alias of API.Globnames.global_of_constr"] - - val is_global : global_reference -> Constr.t -> bool -end - -(******************************************************************************) -(* XXX: Moved from intf *) -(******************************************************************************) -module Pattern : -sig - - type case_info_pattern = - { cip_style : Constr.case_style; - cip_ind : Names.inductive option; - cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) - cip_extensible : bool (** does this match end with _ => _ ? *) } - - type constr_pattern = - | PRef of Globnames.global_reference - | PVar of Names.Id.t - | PEvar of Evar.t * constr_pattern array - | PRel of int - | PApp of constr_pattern * constr_pattern array - | PSoApp of Names.Id.t * constr_pattern list - | PProj of Names.Projection.t * constr_pattern - | PLambda of Names.Name.t * constr_pattern * constr_pattern - | PProd of Names.Name.t * constr_pattern * constr_pattern - | PLetIn of Names.Name.t * constr_pattern * constr_pattern option * constr_pattern - | PSort of Misctypes.glob_sort - | PMeta of Names.Id.t option - | PIf of constr_pattern * constr_pattern * constr_pattern - | PCase of case_info_pattern * constr_pattern * constr_pattern * - (int * bool list * constr_pattern) list (** index of constructor, nb of args *) - | PFix of Constr.fixpoint - | PCoFix of Constr.cofixpoint - -end - -module Evar_kinds : -sig - type obligation_definition_status = - | Define of bool - | Expand - - type matching_var_kind = - | FirstOrderPatVar of Names.Id.t - | SecondOrderPatVar of Names.Id.t - - type t = - | ImplicitArg of Globnames.global_reference * (int * Names.Id.t option) - * bool (** Force inference *) - | BinderType of Names.Name.t - | NamedHole of Names.Id.t (* coming from some ?[id] syntax *) - | QuestionMark of obligation_definition_status * Names.Name.t - | CasesType of bool (* true = a subterm of the type *) - | InternalHole - | TomatchTypeParameter of Names.inductive * int - | GoalEvar - | ImpossibleCase - | MatchingVar of matching_var_kind - | VarInstance of Names.Id.t - | SubEvar of Evar.t -end - -module Glob_term : -sig - type 'a cases_pattern_r = - | PatVar of Names.Name.t - | PatCstr of Names.constructor * 'a cases_pattern_g list * Names.Name.t - and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t - type cases_pattern = [ `any ] cases_pattern_g - type existential_name = Names.Id.t - type 'a glob_constr_r = - | GRef of Globnames.global_reference * Misctypes.glob_level list option - (** An identifier that represents a reference to an object defined - either in the (global) environment or in the (local) context. *) - | GVar of Names.Id.t - (** An identifier that cannot be regarded as "GRef". - Bound variables are typically represented this way. *) - | GEvar of existential_name * (Names.Id.t * 'a glob_constr_g) list - | GPatVar of Evar_kinds.matching_var_kind - | GApp of 'a glob_constr_g * 'a glob_constr_g list - | GLambda of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g - | GProd of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g - | GLetIn of Names.Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g - | GCases of Constr.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g - | GLetTuple of Names.Name.t list * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g - | GIf of 'a glob_constr_g * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g - | GRec of 'a fix_kind_g * Names.Id.t array * 'a glob_decl_g list array * - 'a glob_constr_g array * 'a glob_constr_g array - | GSort of Misctypes.glob_sort - | GHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of 'a glob_constr_g * 'a glob_constr_g Misctypes.cast_type - - and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t - - and 'a glob_decl_g = Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g option * 'a glob_constr_g - - and 'a fix_recursion_order_g = - | GStructRec - | GWfRec of 'a glob_constr_g - | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - - and 'a fix_kind_g = - | GFix of ((int option * 'a fix_recursion_order_g) array * int) - | GCoFix of int - - and 'a predicate_pattern_g = - Names.Name.t * (Names.inductive * Names.Name.t list) Loc.located option - - and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) - - and 'a tomatch_tuples_g = 'a tomatch_tuple_g list - - and 'a cases_clause_g = (Names.Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located - and 'a cases_clauses_g = 'a cases_clause_g list - - type glob_constr = [ `any ] glob_constr_g - type tomatch_tuple = [ `any ] tomatch_tuple_g - type tomatch_tuples = [ `any ] tomatch_tuples_g - type cases_clause = [ `any ] cases_clause_g - type cases_clauses = [ `any ] cases_clauses_g - type glob_decl = [ `any ] glob_decl_g - type fix_kind = [ `any ] fix_kind_g - type predicate_pattern = [ `any ] predicate_pattern_g - type any_glob_constr = - | AnyGlobConstr : 'r glob_constr_g -> any_glob_constr - -end - -module Notation_term : -sig - type scope_name = string - type notation_var_instance_type = - | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList - type tmp_scope_name = scope_name - - type subscopes = tmp_scope_name option * scope_name list - type notation_constr = - | NRef of Globnames.global_reference - | NVar of Names.Id.t - | NApp of notation_constr * notation_constr list - | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | NList of Names.Id.t * Names.Id.t * notation_constr * notation_constr * bool - | NLambda of Names.Name.t * notation_constr * notation_constr - | NProd of Names.Name.t * notation_constr * notation_constr - | NBinderList of Names.Id.t * Names.Id.t * notation_constr * notation_constr - | NLetIn of Names.Name.t * notation_constr * notation_constr option * notation_constr - | NCases of Constr.case_style * notation_constr option * - (notation_constr * (Names.Name.t * (Names.inductive * Names.Name.t list) option)) list * - (Glob_term.cases_pattern list * notation_constr) list - | NLetTuple of Names.Name.t list * (Names.Name.t * notation_constr option) * - notation_constr * notation_constr - | NIf of notation_constr * (Names.Name.t * notation_constr option) * - notation_constr * notation_constr - | NRec of Glob_term.fix_kind * Names.Id.t array * - (Names.Name.t * notation_constr option * notation_constr) list array * - notation_constr array * notation_constr array - | NSort of Misctypes.glob_sort - | NCast of notation_constr * notation_constr Misctypes.cast_type - type interpretation = (Names.Id.t * (subscopes * notation_var_instance_type)) list * - notation_constr - type precedence = int - type parenRelation = - | L | E | Any | Prec of precedence - type tolerability = precedence * parenRelation -end - -module Constrexpr : -sig - - type binder_kind = - | Default of Decl_kinds.binding_kind - | Generalized of Decl_kinds.binding_kind * Decl_kinds.binding_kind * bool - - type explicitation = - | ExplByPos of int * Names.Id.t option - | ExplByName of Names.Id.t - type sign = bool - type raw_natural_number = string - type prim_token = - | Numeral of raw_natural_number * sign - | String of string - - type notation = string - type instance_expr = Misctypes.glob_level list - type proj_flag = int option - type abstraction_kind = - | AbsLambda - | AbsPi - - type cases_pattern_expr_r = - | CPatAlias of cases_pattern_expr * Names.Id.t - | CPatCstr of Libnames.reference - * cases_pattern_expr list option * cases_pattern_expr list - (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) - | CPatAtom of Libnames.reference option - | CPatOr of cases_pattern_expr list - | CPatNotation of notation * cases_pattern_notation_substitution - * cases_pattern_expr list - | CPatPrim of prim_token - | CPatRecord of (Libnames.reference * cases_pattern_expr) list - | CPatDelimiters of string * cases_pattern_expr - | CPatCast of cases_pattern_expr * constr_expr - and cases_pattern_expr = cases_pattern_expr_r CAst.t - - and cases_pattern_notation_substitution = - cases_pattern_expr list * cases_pattern_expr list list - - and constr_expr_r = - | CRef of Libnames.reference * instance_expr option - | CFix of Names.Id.t Loc.located * fix_expr list - | CCoFix of Names.Id.t Loc.located * cofix_expr list - | CProdN of binder_expr list * constr_expr - | CLambdaN of binder_expr list * constr_expr - | CLetIn of Names.Name.t Loc.located * constr_expr * constr_expr option * constr_expr - | CAppExpl of (proj_flag * Libnames.reference * instance_expr option) * constr_expr list - | CApp of (proj_flag * constr_expr) * - (constr_expr * explicitation Loc.located option) list - | CRecord of (Libnames.reference * constr_expr) list - | CCases of Constr.case_style - * constr_expr option - * case_expr list - * branch_expr list - | CLetTuple of Names.Name.t Loc.located list * (Names.Name.t Loc.located option * constr_expr option) * - constr_expr * constr_expr - | CIf of constr_expr * (Names.Name.t Loc.located option * constr_expr option) - * constr_expr * constr_expr - | CHole of Evar_kinds.t option * Misctypes.intro_pattern_naming_expr * Genarg.raw_generic_argument option - | CPatVar of Names.Id.t - | CEvar of Names.Id.t * (Names.Id.t * constr_expr) list - | CSort of Misctypes.glob_sort - | CCast of constr_expr * constr_expr Misctypes.cast_type - | CNotation of notation * constr_notation_substitution - | CGeneralization of Decl_kinds.binding_kind * abstraction_kind option * constr_expr - | CPrim of prim_token - | CDelimiters of string * constr_expr - and constr_expr = constr_expr_r CAst.t - - and case_expr = constr_expr * Names.Name.t Loc.located option * cases_pattern_expr option - - and branch_expr = - (cases_pattern_expr list Loc.located list * constr_expr) Loc.located - - and binder_expr = - Names.Name.t Loc.located list * binder_kind * constr_expr - - and fix_expr = - Names.Id.t Loc.located * (Names.Id.t Loc.located option * recursion_order_expr) * - local_binder_expr list * constr_expr * constr_expr - - and cofix_expr = - Names.Id.t Loc.located * local_binder_expr list * constr_expr * constr_expr - - and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option - - and local_binder_expr = - | CLocalAssum of Names.Name.t Loc.located list * binder_kind * constr_expr - | CLocalDef of Names.Name.t Loc.located * constr_expr * constr_expr option - | CLocalPattern of (cases_pattern_expr * constr_expr option) Loc.located - - and constr_notation_substitution = - constr_expr list * - constr_expr list list * - local_binder_expr list list - - type constr_pattern_expr = constr_expr -end - -module Genredexpr : -sig - - (** The parsing produces initially a list of [red_atom] *) - type 'a red_atom = - | FBeta - | FMatch - | FFix - | FCofix - | FZeta - | FConst of 'a list - | FDeltaBut of 'a list - - (** This list of atoms is immediately converted to a [glob_red_flag] *) - type 'a glob_red_flag = { - rBeta : bool; - rMatch : bool; - rFix : bool; - rCofix : bool; - rZeta : bool; - rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) - rConst : 'a list - } - - (** Generic kinds of reductions *) - type ('a,'b,'c) red_expr_gen = - | 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 - | Unfold of 'b Locus.with_occurrences list - | Fold of 'a list - | Pattern of 'a Locus.with_occurrences list - | ExtraRedExpr of string - | CbvVm of ('b,'c) Util.union Locus.with_occurrences option - | CbvNative of ('b,'c) Util.union Locus.with_occurrences option - - type ('a,'b,'c) may_eval = - | ConstrTerm of 'a - | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of Names.Id.t Loc.located * 'a - | ConstrTypeOf of 'a - - type r_trm = Constrexpr.constr_expr - type r_pat = Constrexpr.constr_pattern_expr - type r_cst = Libnames.reference Misctypes.or_by_notation - type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen -end - -(******************************************************************************) -(* XXX: end of moved from intf *) -(******************************************************************************) - -module Libobject : -sig - type obj - type 'a substitutivity = - | Dispose - | Substitute of 'a - | Keep of 'a - | Anticipate of 'a - - type 'a object_declaration = { - object_name : string; - cache_function : Libnames.object_name * 'a -> unit; - load_function : int -> Libnames.object_name * 'a -> unit; - open_function : int -> Libnames.object_name * 'a -> unit; - classify_function : 'a -> 'a substitutivity; - subst_function : Mod_subst.substitution * 'a -> 'a; - discharge_function : Libnames.object_name * 'a -> 'a option; - rebuild_function : 'a -> 'a - } - val declare_object : 'a object_declaration -> ('a -> obj) - val default_object : string -> 'a object_declaration - val object_tag : obj -> string -end - -module Summary : -sig - - type frozen - - type marshallable = - [ `Yes (* Full data will be marshalled to disk *) - | `No (* Full data will be store in memory, e.g. for Undo *) - | `Shallow ] (* Only part of the data will be marshalled to a slave process *) - - type 'a summary_declaration = - { freeze_function : marshallable -> 'a; - unfreeze_function : 'a -> unit; - init_function : unit -> unit; } - - val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref - val declare_summary : string -> 'a summary_declaration -> unit - module Local : - sig - type 'a local_ref - val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref - val (:=) : 'a local_ref -> 'a -> unit - val (!) : 'a local_ref -> 'a - end -end - -module Nametab : -sig - exception GlobalizationError of Libnames.qualid - - val global : Libnames.reference -> Globnames.global_reference - val global_of_path : Libnames.full_path -> Globnames.global_reference - val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid - val path_of_global : Globnames.global_reference -> Libnames.full_path - val locate_extended : Libnames.qualid -> Globnames.extended_global_reference - val full_name_module : Libnames.qualid -> Names.DirPath.t - val pr_global_env : Names.Id.Set.t -> Globnames.global_reference -> Pp.t - val basename_of_global : Globnames.global_reference -> Names.Id.t - - type visibility = - | Until of int - | Exactly of int - - val error_global_not_found : ?loc:Loc.t -> Libnames.qualid -> 'a - val shortest_qualid_of_module : Names.ModPath.t -> Libnames.qualid - val dirpath_of_module : Names.ModPath.t -> Names.DirPath.t - val locate_module : Libnames.qualid -> Names.ModPath.t - val dirpath_of_global : Globnames.global_reference -> Names.DirPath.t - val locate : Libnames.qualid -> Globnames.global_reference - val locate_constant : Libnames.qualid -> Names.Constant.t - - (** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) - - module type UserName = sig - type t - val equal : t -> t -> bool - val to_string : t -> string - val repr : t -> Names.Id.t * Names.Id.t list - end - - module type EqualityType = - sig - type t - val equal : t -> t -> bool - end - - module type NAMETREE = sig - type elt - type t - type user_name - - val empty : t - val push : visibility -> user_name -> elt -> t -> t - val locate : Libnames.qualid -> t -> elt - val find : user_name -> t -> elt - val exists : user_name -> t -> bool - val user_name : Libnames.qualid -> t -> user_name - val shortest_qualid : Names.Id.Set.t -> user_name -> t -> Libnames.qualid - val find_prefixes : Libnames.qualid -> t -> elt list - end - - module Make (U : UserName) (E : EqualityType) : - NAMETREE with type user_name = U.t and type elt = E.t - -end - -module Global : -sig - val env : unit -> Environ.env - val lookup_mind : Names.MutInd.t -> Declarations.mutual_inductive_body - val lookup_constant : Names.Constant.t -> Declarations.constant_body - val lookup_module : Names.ModPath.t -> Declarations.module_body - val lookup_modtype : Names.ModPath.t -> Declarations.module_type_body - val lookup_inductive : Names.inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body - val constant_of_delta_kn : Names.KerName.t -> Names.Constant.t - val register : - Retroknowledge.field -> Constr.t -> Constr.t -> unit - val env_of_context : Environ.named_context_val -> Environ.env - val is_polymorphic : Globnames.global_reference -> bool - - val constr_of_global_in_context : Environ.env -> - Globnames.global_reference -> Constr.types * Univ.AUContext.t - - val type_of_global_in_context : Environ.env -> - Globnames.global_reference -> Constr.types * Univ.AUContext.t - - val current_dirpath : unit -> Names.DirPath.t - val body_of_constant_body : Declarations.constant_body -> (Constr.t * Univ.AUContext.t) option - val body_of_constant : Names.Constant.t -> (Constr.t * Univ.AUContext.t) option - val add_constraints : Univ.Constraint.t -> unit -end - -module Lib : sig - type is_type = bool - type export = bool option - type node = - | Leaf of Libobject.obj (* FIX: horrible hack (wrt. Enrico) *) - | CompilingLibrary of Libnames.object_prefix - | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | ClosedModule of library_segment - | OpenedSection of Libnames.object_prefix * Summary.frozen - | ClosedSection of library_segment - - and library_segment = (Libnames.object_name * node) list - - val current_mp : unit -> Names.ModPath.t - val is_modtype : unit -> bool - val is_module : unit -> bool - val sections_are_opened : unit -> bool - val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit - val contents : unit -> library_segment - val cwd : unit -> Names.DirPath.t - val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name - val make_kn : Names.Id.t -> Names.KerName.t - val make_path : Names.Id.t -> Libnames.full_path - val discharge_con : Names.Constant.t -> Names.Constant.t - val discharge_inductive : Names.inductive -> Names.inductive -end - -module Declaremods : -sig - - val append_end_library_hook : (unit -> unit) -> unit - -end - -module Library : -sig - val library_is_loaded : Names.DirPath.t -> bool - val loaded_libraries : unit -> Names.DirPath.t list -end - -module States : -sig - type state - - val with_state_protection : ('a -> 'b) -> 'a -> 'b -end - -module Kindops : -sig - val logical_kind_of_goal_kind : Decl_kinds.goal_object_kind -> Decl_kinds.logical_kind -end - -module Goptions : -sig - type option_name = string list - type 'a option_sig = - { - optdepr : bool; - optname : string; - optkey : option_name; - optread : unit -> 'a; - optwrite : 'a -> unit - } - - type 'a write_function = 'a -> unit - - val declare_bool_option : ?preprocess:(bool -> bool) -> - bool option_sig -> bool write_function - val declare_int_option : ?preprocess:(int option -> int option) -> - int option option_sig -> int option write_function - val declare_string_option: ?preprocess:(string -> string) -> - string option_sig -> string write_function - val set_bool_option_value : option_name -> bool -> unit -end - -module Keys : -sig - type key - val constr_key : ('a -> ('a, 't, 'u, 'i) Constr.kind_of_term) -> 'a -> key option - val declare_equiv_keys : key -> key -> unit - val pr_keys : (Globnames.global_reference -> Pp.t) -> Pp.t -end - -module Coqlib : -sig - - type coq_eq_data = { eq : Globnames.global_reference; - ind : Globnames.global_reference; - refl : Globnames.global_reference; - sym : Globnames.global_reference; - trans: Globnames.global_reference; - congr: Globnames.global_reference; - } - - type coq_sigma_data = { - proj1 : Globnames.global_reference; - proj2 : Globnames.global_reference; - elim : Globnames.global_reference; - intro : Globnames.global_reference; - typ : Globnames.global_reference } - val find_reference : string -> string list -> string -> Globnames.global_reference - val check_required_library : string list -> unit - val logic_module_name : string list - val glob_true : Globnames.global_reference - val glob_false : Globnames.global_reference - val glob_O : Globnames.global_reference - val glob_S : Globnames.global_reference - val nat_path : Libnames.full_path - val datatypes_module_name : string list - val glob_eq : Globnames.global_reference - val build_coq_eq_sym : Globnames.global_reference Util.delayed - val build_coq_False : Globnames.global_reference Util.delayed - val build_coq_not : Globnames.global_reference Util.delayed - val build_coq_eq : Globnames.global_reference Util.delayed - val build_coq_eq_data : coq_eq_data Util.delayed - val path_of_O : Names.constructor - val path_of_S : Names.constructor - val build_prod : coq_sigma_data Util.delayed - val build_coq_True : Globnames.global_reference Util.delayed - val coq_iff_ref : Globnames.global_reference lazy_t - val build_coq_iff_left_proj : Globnames.global_reference Util.delayed - val build_coq_iff_right_proj : Globnames.global_reference Util.delayed - val init_modules : string list list - val build_coq_eq_refl : Globnames.global_reference Util.delayed - val arith_modules : string list list - val zarith_base_modules : string list list - val gen_reference_in_modules : string -> string list list-> string -> Globnames.global_reference - val jmeq_module_name : string list - val coq_eq_ref : Globnames.global_reference lazy_t - val coq_not_ref : Globnames.global_reference lazy_t - val coq_or_ref : Globnames.global_reference lazy_t - val build_coq_and : Globnames.global_reference Util.delayed - val build_coq_or : Globnames.global_reference Util.delayed - val build_coq_I : Globnames.global_reference Util.delayed - val coq_reference : string -> string list -> string -> Globnames.global_reference -end - -(************************************************************************) -(* End of modules from library/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from engine/ *) -(************************************************************************) - -module Universes : -sig - type universe_binders - type universe_opt_subst - val fresh_inductive_instance : Environ.env -> Names.inductive -> Constr.pinductive Univ.in_universe_context_set - val new_Type : Names.DirPath.t -> Constr.types - val type_of_global : Globnames.global_reference -> Constr.types Univ.in_universe_context_set - val constr_of_global : Globnames.global_reference -> Constr.t - val new_univ_level : Names.DirPath.t -> Univ.Level.t - val new_sort_in_family : Sorts.family -> Sorts.t - val pr_with_global_universes : Univ.Level.t -> Pp.t - val pr_universe_opt_subst : universe_opt_subst -> Pp.t - type universe_constraint - - module Constraints : - sig - type t - val pr : t -> Pp.t - end - - type universe_constraints = Constraints.t -end - -module UState : -sig - type t - val context : t -> Univ.UContext.t - val context_set : t -> Univ.ContextSet.t - val of_context_set : Univ.ContextSet.t -> t - - val const_univ_entry : poly:bool -> t -> Entries.constant_universes_entry - val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes - - type rigid = - | UnivRigid - | UnivFlexible of bool - -end - -module Evd : -sig - - type evar = Evar.t - [@@ocaml.deprecated "use Evar.t"] - - val string_of_existential : Evar.t -> string - [@@ocaml.deprecated "use Evar.print"] - - type evar_constraint = Reduction.conv_pb * Environ.env * Constr.t * Constr.t - - (* --------------------------------- *) - - (* evar info *) - - module Store : - sig - type t - val empty : t - end - - module Filter : - sig - type t - val repr : t -> bool list option - end - - (** This value defines the refinement of a given {i evar} *) - type evar_body = - | Evar_empty (** given {i evar} was not yet refined *) - | Evar_defined of Constr.t (** given {i var} was refined to the indicated term *) - - (** all the information we have concerning some {i evar} *) - type evar_info = - { - evar_concl : Constr.t; - evar_hyps : Environ.named_context_val; - evar_body : evar_body; - evar_filter : Filter.t; - evar_source : Evar_kinds.t Loc.located; - evar_candidates : Constr.t list option; (* if not None, list of allowed instances *) - evar_extra : Store.t - } - - val evar_concl : evar_info -> Constr.t - val evar_body : evar_info -> evar_body - val evar_context : evar_info -> Context.Named.t - val instantiate_evar_array : evar_info -> Constr.t -> Constr.t array -> Constr.t - val evar_filtered_env : evar_info -> Environ.env - val evar_hyps : evar_info -> Environ.named_context_val - - (* ------------------------------------ *) - - (* evar map *) - - type evar_map - type open_constr = evar_map * Constr.t - - open Util - - module Metaset : Set.S with type elt = Constr.metavariable - - type rigid = UState.rigid = - | UnivRigid - | UnivFlexible of bool - - type 'a freelisted = { - rebus : 'a; - freemetas : Metaset.t - } - - type instance_constraint = IsSuperType | IsSubType | Conv - - type instance_typing_status = - CoerceToType | TypeNotProcessed | TypeProcessed - - type instance_status = instance_constraint * instance_typing_status - - type clbinding = - | Cltyp of Names.Name.t * Constr.t freelisted - | Clval of Names.Name.t * (Constr.t freelisted * instance_status) * Constr.t freelisted - - val empty : evar_map - val from_env : Environ.env -> evar_map - val find : evar_map -> Evar.t -> evar_info - val find_undefined : evar_map -> Evar.t -> evar_info - val is_defined : evar_map -> Evar.t -> bool - val mem : evar_map -> Evar.t -> bool - val add : evar_map -> Evar.t -> evar_info -> evar_map - val evar_universe_context : evar_map -> UState.t - val set_universe_context : evar_map -> UState.t -> evar_map - val universes : evar_map -> UGraph.t - val define : Evar.t -> Constr.t -> evar_map -> evar_map - val fold : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a - val evar_key : Names.Id.t -> evar_map -> Evar.t - - val create_evar_defs : evar_map -> evar_map - - val meta_declare : Constr.metavariable -> Constr.types -> ?name:Names.Name.t -> evar_map -> evar_map - - val clear_metas : evar_map -> evar_map - - (** Allocates a new evar that represents a {i sort}. *) - val new_sort_variable : ?loc:Loc.t -> ?name:Names.Id.t -> rigid -> evar_map -> evar_map * Sorts.t - - val remove : evar_map -> Evar.t -> evar_map - val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> Environ.env -> - evar_map -> Globnames.global_reference -> evar_map * Constr.t - val evar_filtered_context : evar_info -> Context.Named.t - val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> evar_map -> Names.inductive -> evar_map * Constr.pinductive - val fold_undefined : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a - - val universe_context_set : evar_map -> Univ.ContextSet.t - val evar_ident : Evar.t -> evar_map -> Names.Id.t option - val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list - val universe_binders : evar_map -> Universes.universe_binders - val nf_constraints : evar_map -> evar_map - val from_ctx : UState.t -> evar_map - - val to_universe_context : evar_map -> Univ.UContext.t - val const_univ_entry : poly:bool -> evar_map -> Entries.constant_universes_entry - val ind_univ_entry : poly:bool -> evar_map -> Entries.inductive_universes - - val meta_list : evar_map -> (Constr.metavariable * clbinding) list - - val meta_defined : evar_map -> Constr.metavariable -> bool - - val meta_name : evar_map -> Constr.metavariable -> Names.Name.t - - module MonadR : - sig - module List : - sig - val map_right : ('a -> evar_map -> evar_map * 'b) -> 'a list -> evar_map -> evar_map * 'b list - end - end - - type 'a sigma = { - it : 'a ; - sigma : evar_map - } - - val sig_sig : 'a sigma -> evar_map - - val sig_it : 'a sigma -> 'a - - type 'a in_evar_universe_context = 'a * UState.t - - val univ_flexible : rigid - val univ_flexible_alg : rigid - val empty_evar_universe_context : UState.t - val union_evar_universe_context : UState.t -> UState.t -> UState.t - val merge_universe_context : evar_map -> UState.t -> evar_map - - type unsolvability_explanation = - | SeveralInstancesFound of int - - (** Return {i ids} of all {i evars} that occur in a given term. *) - val evars_of_term : Constr.t -> Evar.Set.t - - val evar_universe_context_of : Univ.ContextSet.t -> UState.t - [@@ocaml.deprecated "alias of API.UState.of_context_set"] - - val evar_context_universe_context : UState.t -> Univ.UContext.t - [@@ocaml.deprecated "alias of API.UState.context"] - - type evar_universe_context = UState.t - [@@ocaml.deprecated "alias of API.UState.t"] - - val existential_opt_value : evar_map -> Constr.existential -> Constr.t option - val existential_value : evar_map -> Constr.existential -> Constr.t - - exception NotInstantiatedEvar - - val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> Environ.env -> evar_map -> Sorts.family -> evar_map * Sorts.t -end - -module EConstr : -sig - type t - type constr = t - type types = t - type unsafe_judgment = (constr, types) Environ.punsafe_judgment - type named_declaration = (constr, types) Context.Named.Declaration.pt - type named_context = (constr, types) Context.Named.pt - type rel_context = (constr, types) Context.Rel.pt - type rel_declaration = (constr, types) Context.Rel.Declaration.pt - type existential = constr Constr.pexistential - module ESorts : - sig - type t - (** Type of sorts up-to universe unification. Essentially a wrapper around - Sorts.t so that normalization is ensured statically. *) - - val make : Sorts.t -> t - (** Turn a sort into an up-to sort. *) - - val kind : Evd.evar_map -> t -> Sorts.t - (** Returns the view into the current sort. Note that the kind of a variable - may change if the unification state of the evar map changes. *) - - end - - module EInstance : - sig - type t - (** Type of universe instances up-to universe unification. Similar to - {ESorts.t} for {Univ.Instance.t}. *) - - val make : Univ.Instance.t -> t - val kind : Evd.evar_map -> t -> Univ.Instance.t - val empty : t - val is_empty : t -> bool - end - - val of_constr : Constr.t -> constr - - val kind : Evd.evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) Constr.kind_of_term - - val mkArrow : constr -> constr -> constr - val mkInd : Names.inductive -> t - val mkProp : constr - val mkProd : Names.Name.t * constr * constr -> constr - val mkRel : int -> constr - val mkSort : Sorts.t -> constr - val mkVar : Names.Id.t -> constr - val mkLambda : Names.Name.t * constr * constr -> constr - val mkLambda_or_LetIn : rel_declaration -> constr -> constr - val mkApp : constr * constr array -> constr - val mkEvar : constr Constr.pexistential -> constr - - val mkMeta : Constr.metavariable -> constr - - val mkConstructU : Names.constructor * EInstance.t -> constr - val mkLetIn : Names.Name.t * constr * constr * constr -> constr - val mkProd_or_LetIn : rel_declaration -> constr -> constr - val mkCast : constr * Constr.cast_kind * constr -> constr - val mkNamedLambda : Names.Id.t -> types -> constr -> constr - val mkNamedProd : Names.Id.t -> types -> types -> types - - val isCast : Evd.evar_map -> t -> bool - val isEvar : Evd.evar_map -> constr -> bool - val isInd : Evd.evar_map -> constr -> bool - val isRel : Evd.evar_map -> constr -> bool - val isSort : Evd.evar_map -> constr -> bool - val isVar : Evd.evar_map -> constr -> bool - val isConst : Evd.evar_map -> constr -> bool - val isConstruct : Evd.evar_map -> constr -> bool - - val destInd : Evd.evar_map -> constr -> Names.inductive * EInstance.t - val destVar : Evd.evar_map -> constr -> Names.Id.t - val destEvar : Evd.evar_map -> constr -> constr Constr.pexistential - val destRel : Evd.evar_map -> constr -> int - val destProd : Evd.evar_map -> constr -> Names.Name.t * types * types - val destLambda : Evd.evar_map -> constr -> Names.Name.t * types * constr - val destApp : Evd.evar_map -> constr -> constr * constr array - val destConst : Evd.evar_map -> constr -> Names.Constant.t * EInstance.t - val destConstruct : Evd.evar_map -> constr -> Names.constructor * EInstance.t - val destFix : Evd.evar_map -> t -> (t, t) Constr.pfixpoint - val destCast : Evd.evar_map -> t -> t * Constr.cast_kind * t - - val mkConstruct : Names.constructor -> constr - - val compose_lam : (Names.Name.t * constr) list -> constr -> constr - - val decompose_lam : Evd.evar_map -> constr -> (Names.Name.t * constr) list * constr - val decompose_lam_n_assum : Evd.evar_map -> int -> constr -> rel_context * constr - val decompose_app : Evd.evar_map -> constr -> constr * constr list - val decompose_prod : Evd.evar_map -> constr -> (Names.Name.t * constr) list * constr - val decompose_prod_assum : Evd.evar_map -> constr -> rel_context * constr - - val applist : constr * constr list -> constr - - val to_constr : Evd.evar_map -> constr -> Constr.t - - val push_rel : rel_declaration -> Environ.env -> Environ.env - - module Unsafe : - sig - val to_constr : constr -> Constr.t - - val to_rel_decl : (constr, types) Context.Rel.Declaration.pt -> (Constr.constr, Constr.types) Context.Rel.Declaration.pt - - (** Physical identity. Does not care for defined evars. *) - - val to_named_decl : (constr, types) Context.Named.Declaration.pt -> (Constr.constr, Constr.types) Context.Named.Declaration.pt - - val to_instance : EInstance.t -> Univ.Instance.t - end - - module Vars : - sig - val substnl : t list -> int -> t -> t - val noccurn : Evd.evar_map -> int -> constr -> bool - val closed0 : Evd.evar_map -> constr -> bool - val subst1 : constr -> constr -> constr - val substl : constr list -> constr -> constr - val lift : int -> constr -> constr - val liftn : int -> int -> t -> t - val subst_var : Names.Id.t -> t -> t - val subst_vars : Names.Id.t list -> t -> t - end - - val fresh_global : - ?loc:Loc.t -> ?rigid:UState.rigid -> ?names:Univ.Instance.t -> Environ.env -> - Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * t - - val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (constr, types) Context.Named.Declaration.pt - val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (constr, types) Context.Rel.Declaration.pt - val kind_of_type : Evd.evar_map -> constr -> (constr, constr) Term.kind_of_type - val to_lambda : Evd.evar_map -> int -> constr -> constr - val it_mkLambda_or_LetIn : constr -> rel_context -> constr - val push_rel_context : rel_context -> Environ.env -> Environ.env - val eq_constr : Evd.evar_map -> constr -> constr -> bool - val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit - val fold : Evd.evar_map -> ('a -> constr -> 'a) -> 'a -> constr -> 'a - val existential_type : Evd.evar_map -> existential -> types - val iter : Evd.evar_map -> (constr -> unit) -> constr -> unit - val eq_constr_universes : Evd.evar_map -> constr -> constr -> Universes.universe_constraints option - val eq_constr_nounivs : Evd.evar_map -> constr -> constr -> bool - val compare_constr : Evd.evar_map -> (constr -> constr -> bool) -> constr -> constr -> bool - val isApp : Evd.evar_map -> constr -> bool - val it_mkProd_or_LetIn : constr -> rel_context -> constr - val push_named : named_declaration -> Environ.env -> Environ.env - val destCase : Evd.evar_map -> constr -> Constr.case_info * constr * constr * constr array - val decompose_lam_assum : Evd.evar_map -> constr -> rel_context * constr - val mkConst : Names.Constant.t -> constr - val mkCase : Constr.case_info * constr * constr * constr array -> constr - val named_context : Environ.env -> named_context - val val_of_named_context : named_context -> Environ.named_context_val - val mkFix : (t, t) Constr.pfixpoint -> t - val decompose_prod_n_assum : Evd.evar_map -> int -> t -> rel_context * t - val isMeta : Evd.evar_map -> t -> bool - - val destMeta : Evd.evar_map -> t -> Constr.metavariable - - val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t - val mkNamedLetIn : Names.Id.t -> constr -> types -> constr -> constr - val map : Evd.evar_map -> (t -> t) -> t -> t - val mkConstU : Names.Constant.t * EInstance.t -> t - val isProd : Evd.evar_map -> t -> bool - val mkConstructUi : (Names.inductive * EInstance.t) * int -> t - val isLambda : Evd.evar_map -> t -> bool -end - -module Namegen : -sig - (** *) - - (** [next_ident_away original_id unwanted_ids] returns a new identifier as close as possible - to the [original_id] while avoiding all [unwanted_ids]. - - In particular: - {ul {- if [original_id] does not appear in the list of [unwanted_ids], then [original_id] is returned.} - {- if [original_id] appears in the list of [unwanted_ids], - then this function returns a new id that: - {ul {- has the same {i root} as the [original_id],} - {- does not occur in the list of [unwanted_ids],} - {- has the smallest possible {i subscript}.}}}} - - where by {i subscript} of some identifier we mean last part of it that is composed - only from (decimal) digits and by {i root} of some identifier we mean - the whole identifier except for the {i subscript}. - - E.g. if we take [foo42], then [42] is the {i subscript}, and [foo] is the root. *) - val next_ident_away : Names.Id.t -> Names.Id.Set.t -> Names.Id.t - - val hdchar : Environ.env -> Evd.evar_map -> EConstr.types -> string - val id_of_name_using_hdchar : Environ.env -> Evd.evar_map -> EConstr.types -> Names.Name.t -> Names.Id.t - val next_ident_away_in_goal : Names.Id.t -> Names.Id.Set.t -> Names.Id.t - val default_dependent_ident : Names.Id.t - val next_global_ident_away : Names.Id.t -> Names.Id.Set.t -> Names.Id.t - val rename_bound_vars_as_displayed : - Evd.evar_map -> Names.Id.Set.t -> Names.Name.t list -> EConstr.types -> EConstr.types -end - -module Termops : -sig - val it_mkLambda_or_LetIn : Constr.t -> Context.Rel.t -> Constr.t - val local_occur_var : Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool - val occur_var : Environ.env -> Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool - val pr_evar_info : Evd.evar_info -> Pp.t - - val print_constr : EConstr.constr -> Pp.t - val pr_sort_family : Sorts.family -> Pp.t - - (** [dependent m t] tests whether [m] is a subterm of [t] *) - val dependent : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - - (** [pop c] returns a copy of [c] with decremented De Bruijn indexes *) - val pop : EConstr.constr -> EConstr.constr - - (** Does a given term contain an existential variable? *) - val occur_existential : Evd.evar_map -> EConstr.constr -> bool - - (** [map_constr_with_binders_left_to_right g f acc c] maps [f updated_acc] on all the immediate subterms of [c]. - {ul {- if a given immediate subterm of [c] is not below a binder, then [updated_acc] is the same as [acc].} - {- if a given immediate subterm of [c] is below a binder [b], then [updated_acc] is computed as [g b acc].}} *) - val map_constr_with_binders_left_to_right : - Evd.evar_map -> (EConstr.rel_declaration -> 'a -> 'a) -> ('a -> EConstr.constr -> EConstr.constr) -> 'a -> EConstr.constr -> EConstr.constr - - (** Remove the outer-most {!Constr.kind_of_term.Cast} from a given term. *) - val strip_outer_cast : Evd.evar_map -> EConstr.constr -> EConstr.constr - - (** [nb_lam] ⟦[fun (x1:t1)...(xn:tn) => c]⟧ where [c] is not an abstraction gives [n]. - Casts are ignored. *) - val nb_lam : Evd.evar_map -> EConstr.constr -> int - - (** [push_rel_assum env_assumtion env] adds a given {i env assumption} to the {i env context} of a given {i environment}. *) - val push_rel_assum : Names.Name.t * EConstr.types -> Environ.env -> Environ.env - - (** [push_rels_assum env_assumptions env] adds given {i env assumptions} to the {i env context} of a given {i environment}. *) - val push_rels_assum : (Names.Name.t * Constr.types) list -> Environ.env -> Environ.env - - type meta_value_map = (Constr.metavariable * Constr.t) list - - val last_arg : Evd.evar_map -> EConstr.constr -> EConstr.constr - val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Names.Name.t * 't) list - val prod_applist : Evd.evar_map -> EConstr.constr -> EConstr.constr list -> EConstr.constr - val nb_prod : Evd.evar_map -> EConstr.constr -> int - val is_section_variable : Names.Id.t -> bool - val ids_of_rel_context : ('c, 't) Context.Rel.pt -> Names.Id.t list - val subst_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr - val global_vars_set_of_decl : Environ.env -> Evd.evar_map -> EConstr.named_declaration -> Names.Id.Set.t - val vars_of_env: Environ.env -> Names.Id.Set.t - val ids_of_named_context : ('c, 't) Context.Named.pt -> Names.Id.t list - val ids_of_context : Environ.env -> Names.Id.t list - val global_of_constr : Evd.evar_map -> EConstr.constr -> Globnames.global_reference * EConstr.EInstance.t - val print_named_context : Environ.env -> Pp.t - val print_constr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t - val clear_named_body : Names.Id.t -> Environ.env -> Environ.env - val is_Prop : Evd.evar_map -> EConstr.constr -> bool - val is_Set : Evd.evar_map -> EConstr.constr -> bool - val is_Type : Evd.evar_map -> EConstr.constr -> bool - val is_global : Evd.evar_map -> Globnames.global_reference -> EConstr.constr -> bool - - val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - - val occur_var_in_decl : - Environ.env -> Evd.evar_map -> - Names.Id.t -> EConstr.named_declaration -> bool - - val subst_meta : meta_value_map -> Constr.t -> Constr.t - - val free_rels : Evd.evar_map -> EConstr.constr -> Int.Set.t - - val occur_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - [@@ocaml.deprecated "alias of API.Termops.dependent"] - - val replace_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr -> EConstr.constr - val map_named_decl : ('a -> 'b) -> ('a, 'a) Context.Named.Declaration.pt -> ('b, 'b) Context.Named.Declaration.pt - val map_rel_decl : ('a -> 'b) -> ('a, 'a) Context.Rel.Declaration.pt -> ('b, 'b) Context.Rel.Declaration.pt - val pr_metaset : Evd.Metaset.t -> Pp.t - val pr_evar_map : ?with_univs:bool -> int option -> Evd.evar_map -> Pp.t - val pr_evar_universe_context : UState.t -> Pp.t -end - -module Proofview_monad : -sig - type lazy_msg = unit -> Pp.t - module Info : - sig - type tree - end -end - -module Evarutil : -sig - val e_new_global : Evd.evar_map ref -> Globnames.global_reference -> EConstr.constr - - val nf_evars_and_universes : Evd.evar_map -> Evd.evar_map * (Constr.t -> Constr.t) - val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr - val nf_evar_info : Evd.evar_map -> Evd.evar_info -> Evd.evar_info - - val mk_new_meta : unit -> EConstr.constr - - (** [new_meta] is a generator of unique meta variables *) - val new_meta : unit -> Constr.metavariable - - val new_Type : ?rigid:Evd.rigid -> Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.constr - val new_global : Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * EConstr.constr - - val new_evar : - Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> Evd.evar_map * EConstr.constr - - val new_evar_instance : - Environ.named_context_val -> Evd.evar_map -> EConstr.types -> - ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> ?candidates:EConstr.constr list -> - ?store:Evd.Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> - EConstr.constr list -> Evd.evar_map * EConstr.constr - - val clear_hyps_in_evi : Environ.env -> Evd.evar_map ref -> Environ.named_context_val -> - EConstr.types -> Names.Id.Set.t -> Environ.named_context_val * EConstr.types - - type clear_dependency_error = - | OccurHypInSimpleClause of Names.Id.t option - | EvarTypingBreak of Constr.existential - - exception ClearDependencyError of Names.Id.t * clear_dependency_error - val undefined_evars_of_term : Evd.evar_map -> EConstr.constr -> Evar.Set.t - val has_undefined_evars : Evd.evar_map -> EConstr.constr -> bool - val e_new_evar : - Environ.env -> Evd.evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> EConstr.constr - val new_type_evar : - Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> Evd.rigid -> - Evd.evar_map * (EConstr.constr * Sorts.t) - val nf_evars_universes : Evd.evar_map -> Constr.t -> Constr.t - val safe_evar_value : Evd.evar_map -> Constr.existential -> Constr.t option - val evd_comb1 : (Evd.evar_map -> 'b -> Evd.evar_map * 'a) -> Evd.evar_map ref -> 'b -> 'a -end - -module Proofview : -sig - type proofview - type entry - type +'a tactic - type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * EConstr.types * (Evd.evar_map -> EConstr.constr -> telescope) - - module NonLogical : - sig - type +'a t - val make : (unit -> 'a) -> 'a t - val return : 'a -> 'a t - val ( >> ) : unit t -> 'a t -> 'a t - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - val print_char : char -> unit t - val print_debug : Pp.t -> unit t - val print_warning : Pp.t -> unit t - val print_notice : Pp.t -> unit t - val print_info : Pp.t -> unit t - val run : 'a t -> 'a - type 'a ref - val ref : 'a -> 'a ref t - val ( := ) : 'a ref -> 'a -> unit t - val ( ! ) : 'a ref -> 'a t - val raise : ?info:Exninfo.info -> exn -> 'a t - val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t - val read_line : string t - end - val proofview : proofview -> Evar.t list * Evd.evar_map - val cycle : int -> unit tactic - val swap : int -> int -> unit tactic - val revgoals : unit tactic - val give_up : unit tactic - val init : Evd.evar_map -> (Environ.env * EConstr.types) list -> entry * proofview - val shelve : unit tactic - val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic - val tclUNIT : 'a -> 'a tactic - val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - val tclORELSE : 'a tactic -> (Util.iexn -> 'a tactic) -> 'a tactic - val tclFOCUS : int -> int -> 'a tactic -> 'a tactic - val tclEVARMAP : Evd.evar_map tactic - val tclTHEN : unit tactic -> 'a tactic -> 'a tactic - val tclLIFT : 'a NonLogical.t -> 'a tactic - val tclOR : 'a tactic -> (Exninfo.iexn -> 'a tactic) -> 'a tactic - val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (Exninfo.iexn -> 'b tactic) -> 'b tactic - val tclINDEPENDENT : unit tactic -> unit tactic - val tclDISPATCH : unit tactic list -> unit tactic - val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic - val tclBREAK : (Exninfo.iexn -> Exninfo.iexn option) -> 'a tactic -> 'a tactic - val tclENV : Environ.env tactic - val tclONCE : 'a tactic -> 'a tactic - val tclPROGRESS : 'a tactic -> 'a tactic - val shelve_unifiable : unit tactic - val apply : Environ.env -> 'a tactic -> proofview -> 'a - * proofview - * (bool * Evar.t list * Evar.t list) - * Proofview_monad.Info.tree - val numgoals : int tactic - val with_shelf : 'a tactic -> (Evar.t list * 'a) tactic - - module Unsafe : - sig - val tclEVARS : Evd.evar_map -> unit tactic - - val tclGETGOALS : Evar.t list tactic - - val tclSETGOALS : Evar.t list -> unit tactic - - val tclNEWGOALS : Evar.t list -> unit tactic - end - - module Goal : - sig - type 'a t - val enter : ([ `LZ ] t -> unit tactic) -> unit tactic - val hyps : 'a t -> EConstr.named_context - val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic - val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic - val concl : 'a t -> EConstr.constr - val sigma : 'a t -> Evd.evar_map - val goal : [ `NF ] t -> Evar.t - val env : 'a t -> Environ.env - val assume : 'a t -> [ `NF ] t - end - - module Notations : - sig - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - end - module V82 : - sig - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - - val tactic : tac -> unit tactic - - val of_tactic : 'a tactic -> tac - - val nf_evar_goals : unit tactic - - val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic - - val catchable_exception : exn -> bool - end - module Trace : - sig - val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - val log : Proofview_monad.lazy_msg -> unit tactic - end -end - -module Ftactic : -sig - type +'a focus - type +'a t = 'a focus Proofview.tactic - val return : 'a -> 'a t - val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic - val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t - val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t - val bind : 'a t -> ('a -> 'b t) -> 'b t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val lift : 'a Proofview.tactic -> 'a t - val with_env : 'a t -> (Environ.env * 'a) t - module List : - sig - val map : ('a -> 'b t) -> 'a list -> 'b list t - val map_right : ('a -> 'b t) -> 'a list -> 'b list t - end - module Notations : - sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (<*>) : unit t -> 'a t -> 'a t - end -end - -module Geninterp : -sig - module Val : - sig - type 'a typ - type t = Dyn : 'a typ * 'a -> t - type 'a tag = - | Base : 'a typ -> 'a tag - | List : 'a tag -> 'a list tag - | Opt : 'a tag -> 'a option tag - | Pair : 'a tag * 'b tag -> ('a * 'b) tag - val create : string -> 'a typ - val pr : 'a typ -> Pp.t - val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option - val typ_list : t list typ - val typ_opt : t option typ - val typ_pair : (t * t) typ - val repr : 'a typ -> string - val inject : 'a tag -> 'a -> t - end - module TacStore : - sig - type t - type 'a field - val empty : t - val field : unit -> 'a field - val get : t -> 'a field -> 'a option - val set : t -> 'a field -> 'a -> t - val remove : t -> 'a field -> t - val merge : t -> t -> t - end - type interp_sign = { - lfun : Val.t Names.Id.Map.t; - extra : TacStore.t - } - type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t - val register_interp0 : - ('raw, 'glb, 'top) Genarg.genarg_type -> ('glb, Val.t) interp_fun -> unit - val register_val0 : ('raw, 'glb, 'top) Genarg.genarg_type -> 'top Val.tag option -> unit - val val_tag : 'a Genarg.typed_abstract_argument_type -> 'a Val.tag - val interp : ('raw, 'glb, 'top) Genarg.genarg_type -> ('glb, Val.t) interp_fun -end - -(************************************************************************) -(* End of modules from engine/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from pretyping/ *) -(************************************************************************) - -module Ltac_pretype : -sig -open Names -open Glob_term - -(** {5 Maps of pattern variables} *) - -(** Type [constr_under_binders] is for representing the term resulting - of a matching. Matching can return terms defined in a some context - of named binders; in the context, variable names are ordered by - (<) and referred to by index in the term Thanks to the canonical - ordering, a matching problem like - - [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]] - - will be accepted. Thanks to the reference by index, a matching - problem like - - [match ... with [(fun x => ?p)] => [forall x => p]] - - will work even if [x] is also the name of an existing goal - variable. - - Note: we do not keep types in the signature. Besides simplicity, - the main reason is that it would force to close the signature over - binders that occur only in the types of effective binders but not - in the term itself (e.g. for a term [f x] with [f:A -> True] and - [x:A]). - - On the opposite side, by not keeping the types, we loose - opportunity to propagate type informations which otherwise would - not be inferable, as e.g. when matching [forall x, x = 0] with - pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in - expression [forall x, h = x] where nothing tells how the type of x - could be inferred. We also loose the ability of typing ltac - variables before calling the right-hand-side of ltac matching clauses. *) - -type constr_under_binders = Id.t list * EConstr.constr - -(** Types of substitutions with or w/o bound variables *) - -type patvar_map = EConstr.constr Id.Map.t -type extended_patvar_map = constr_under_binders Id.Map.t - -(** A globalised term together with a closure representing the value - of its free variables. Intended for use when these variables are taken - from the Ltac environment. *) -type closure = { - idents:Id.t Id.Map.t; - typed: constr_under_binders Id.Map.t ; - untyped:closed_glob_constr Id.Map.t } -and closed_glob_constr = { - closure: closure; - term: glob_constr } - -(** Ltac variable maps *) -type var_map = constr_under_binders Id.Map.t -type uconstr_var_map = closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t - -type ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Id.t Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) -} - -end - -module Locusops : -sig - val clause_with_generic_occurrences : 'a Locus.clause_expr -> bool - val nowhere : 'a Locus.clause_expr - val allHypsAndConcl : 'a Locus.clause_expr - val is_nowhere : 'a Locus.clause_expr -> bool - val occurrences_map : - ('a list -> 'b list) -> 'a Locus.occurrences_gen -> 'b Locus.occurrences_gen - val convert_occs : Locus.occurrences -> bool * int list - val onConcl : 'a Locus.clause_expr - val onHyp : 'a -> 'a Locus.clause_expr -end - -module Pretype_errors : -sig - type unification_error - type subterm_unification_error - - type type_error = (EConstr.t, EConstr.types) Type_errors.ptype_error - - type pretype_error = - | CantFindCaseType of EConstr.constr - | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error - | UnifOccurCheck of Evar.t * EConstr.constr - | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option - | CannotUnify of EConstr.constr * EConstr.constr * unification_error option - | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr - | CannotUnifyBindingType of EConstr.constr * EConstr.constr - | CannotGeneralize of EConstr.constr - | NoOccurrenceFound of EConstr.constr * Names.Id.t option - | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (Environ.env * type_error) option - | WrongAbstractionType of Names.Name.t * EConstr.constr * EConstr.types * EConstr.types - | AbstractionOverMeta of Names.Name.t * Names.Name.t - | NonLinearUnification of Names.Name.t * EConstr.constr - | VarNotFound of Names.Id.t - | UnexpectedType of EConstr.constr * EConstr.constr - | NotProduct of EConstr.constr - | TypingError of type_error - | CannotUnifyOccurrences of subterm_unification_error - | UnsatisfiableConstraints of - (Evar.t * Evar_kinds.t) option * Evar.Set.t option - - exception PretypeError of Environ.env * Evd.evar_map * pretype_error - val error_var_not_found : ?loc:Loc.t -> Names.Id.t -> 'b - val precatchable_exception : exn -> bool -end - -module Reductionops : -sig - type local_reduction_function = Evd.evar_map -> EConstr.constr -> EConstr.constr - - type reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr - - type local_stack_reduction_function = - Evd.evar_map -> EConstr.constr -> EConstr.constr * EConstr.constr list - - type e_reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr - type state - - val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function - val nf_beta : local_reduction_function - val nf_betaiota : local_reduction_function - val splay_prod : Environ.env -> Evd.evar_map -> EConstr.constr -> - (Names.Name.t * EConstr.constr) list * EConstr.constr - val splay_prod_n : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.rel_context * EConstr.constr - val whd_all : reduction_function - val whd_beta : local_reduction_function - - val whd_betaiotazeta : local_reduction_function - - val whd_betaiota_stack : local_stack_reduction_function - - val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function - val is_conv : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val beta_applist : Evd.evar_map -> EConstr.constr * EConstr.constr list -> EConstr.constr - val sort_of_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.ESorts.t - val is_conv_leq : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val whd_betaiota : local_reduction_function - val is_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> bool - val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr - val nf_meta : Evd.evar_map -> EConstr.constr -> EConstr.constr - val hnf_prod_appvect : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr array -> EConstr.constr - val pr_state : state -> Pp.t - module Stack : - sig - type 'a t - val pr : ('a -> Pp.t) -> 'a t -> Pp.t - end - module Cst_stack : - sig - type t - val pr : t -> Pp.t - end -end - -module Inductiveops : -sig - type inductive_family - type inductive_type = - | IndType of inductive_family * EConstr.constr list - type constructor_summary = - { - cs_cstr : Constr.pconstructor; - cs_params : Constr.t list; - cs_nargs : int; - cs_args : Context.Rel.t; - cs_concl_realargs : Constr.t array; - } - - val arities_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array - val constructors_nrealargs_env : Environ.env -> Names.inductive -> int array - val constructor_nallargs_env : Environ.env -> Names.constructor -> int - - val inductive_nparams : Names.inductive -> int - - val inductive_nparamdecls : Names.inductive -> int - - val type_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array - val find_mrectype : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.constr list - val mis_is_recursive : - Names.inductive * Declarations.mutual_inductive_body * Declarations.one_inductive_body -> bool - val nconstructors : Names.inductive -> int - val find_rectype : Environ.env -> Evd.evar_map -> EConstr.types -> inductive_type - val get_constructors : Environ.env -> inductive_family -> constructor_summary array - val dest_ind_family : inductive_family -> Names.inductive Univ.puniverses * Constr.t list - val find_inductive : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * Constr.t list - val type_of_inductive : Environ.env -> Constr.pinductive -> Constr.types -end - -module Impargs : -sig - type implicit_status - type implicit_side_condition - type implicits_list = implicit_side_condition * implicit_status list - type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) - type manual_implicits = manual_explicitation list - val is_status_implicit : implicit_status -> bool - val name_of_implicit : implicit_status -> Names.Id.t - val implicits_of_global : Globnames.global_reference -> implicits_list list - val declare_manual_implicits : bool -> Globnames.global_reference -> ?enriching:bool -> - manual_implicits list -> unit - val is_implicit_args : unit -> bool - val is_strict_implicit_args : unit -> bool - val is_contextual_implicit_args : unit -> bool - val make_implicit_args : bool -> unit - val make_strict_implicit_args : bool -> unit - val make_contextual_implicit_args : bool -> unit -end - -module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) -sig - val get_type_of : ?polyprop:bool -> ?lax:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - val get_sort_family_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family - val expand_projection : Environ.env -> Evd.evar_map -> Names.Projection.t -> EConstr.constr -> EConstr.constr list -> EConstr.constr - val get_sort_of : - ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.t -end - -module Find_subterm : -sig - val error_invalid_occurrence : int list -> 'a -end - -module Evarsolve : -sig - val refresh_universes : - ?status:Evd.rigid -> ?onlyalg:bool -> ?refreshset:bool -> bool option -> - Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.types -end - -module Recordops : -sig - - type cs_pattern = - | Const_cs of Globnames.global_reference - | Prod_cs - | Sort_cs of Sorts.family - | Default_cs - - type obj_typ = { - o_DEF : Constr.t; - o_CTX : Univ.AUContext.t; - o_INJ : int option; (** position of trivial argument *) - o_TABS : Constr.t list; (** ordered *) - o_TPARAMS : Constr.t list; (** ordered *) - o_NPARAMS : int; - o_TCOMPS : Constr.t list } - - val lookup_projections : Names.inductive -> Names.Constant.t option list - val lookup_canonical_conversion : (Globnames.global_reference * cs_pattern) -> Constr.t * obj_typ - val find_projection_nparams : Globnames.global_reference -> int -end - -module Evarconv : -sig - val e_conv : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr -> bool - val the_conv_x : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map - val the_conv_x_leq : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map - val solve_unif_constraints_with_heuristics : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map -> Evd.evar_map -end - -module Typing : -sig - val e_sort_of : Environ.env -> Evd.evar_map ref -> EConstr.types -> Sorts.t - - val type_of : ?refresh:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.types - val e_solve_evars : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr - - val unsafe_type_of : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - - val e_check : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types -> unit - - val e_type_of : ?refresh:bool -> Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types -end - -module Miscops : -sig - val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> ('d,'e,'f) Genredexpr.red_expr_gen - val map_cast_type : ('a -> 'b) -> 'a Misctypes.cast_type -> 'b Misctypes.cast_type -end - -module Glob_ops : -sig - val map_glob_constr_left_to_right : (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - val loc_of_glob_constr : Glob_term.glob_constr -> Loc.t option - val glob_constr_eq : Glob_term.glob_constr -> Glob_term.glob_constr -> bool - val bound_glob_vars : Glob_term.glob_constr -> Names.Id.Set.t - - (** Conversion from glob_constr to cases pattern, if possible - - Take the current alias as parameter, - @raise Not_found if translation is impossible *) - val cases_pattern_of_glob_constr : Names.Name.t -> Glob_term.glob_constr -> Glob_term.cases_pattern - val map_glob_constr : - (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - - val empty_lvar : Ltac_pretype.ltac_var_map - -end - -module Redops : -sig - val all_flags : 'a Genredexpr.glob_red_flag - val make_red_flag : 'a Genredexpr.red_atom list -> 'a Genredexpr.glob_red_flag -end - -module Patternops : -sig - val pattern_of_glob_constr : Glob_term.glob_constr -> Names.Id.t list * Pattern.constr_pattern - val subst_pattern : Mod_subst.substitution -> Pattern.constr_pattern -> Pattern.constr_pattern - val pattern_of_constr : Environ.env -> Evd.evar_map -> Constr.t -> Pattern.constr_pattern - val instantiate_pattern : Environ.env -> - Evd.evar_map -> Ltac_pretype.extended_patvar_map -> - Pattern.constr_pattern -> Pattern.constr_pattern -end - -module Constr_matching : -sig - val special_meta : Constr.metavariable - - type binding_bound_vars = Names.Id.Set.t - type bound_ident_map = Names.Id.t Names.Id.Map.t - val is_matching : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> bool - val extended_matches : - Environ.env -> Evd.evar_map -> binding_bound_vars * Pattern.constr_pattern -> - EConstr.constr -> bound_ident_map * Ltac_pretype.extended_patvar_map - exception PatternMatchingFailure - type matching_result = - { m_sub : bound_ident_map * Ltac_pretype.patvar_map; - m_ctx : EConstr.constr } - val match_subterm_gen : Environ.env -> Evd.evar_map -> - bool -> - binding_bound_vars * Pattern.constr_pattern -> EConstr.constr -> - matching_result IStream.t - val matches : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> Ltac_pretype.patvar_map -end - -module Tacred : -sig - val try_red_product : Reductionops.reduction_function - val simpl : Reductionops.reduction_function - val unfoldn : - (Locus.occurrences * Names.evaluable_global_reference) list -> Reductionops.reduction_function - val hnf_constr : Reductionops.reduction_function - val red_product : Reductionops.reduction_function - val is_evaluable : Environ.env -> Names.evaluable_global_reference -> bool - val evaluable_of_global_reference : - Environ.env -> Globnames.global_reference -> Names.evaluable_global_reference - val error_not_evaluable : Globnames.global_reference -> 'a - val reduce_to_quantified_ref : - Environ.env -> Evd.evar_map -> Globnames.global_reference -> EConstr.types -> EConstr.types - val pattern_occs : (Locus.occurrences * EConstr.constr) list -> Reductionops.e_reduction_function - val cbv_norm_flags : CClosure.RedFlags.reds -> Reductionops.reduction_function -end - -(* XXX: Located manually from intf *) -module Tok : -sig - - type t = - | KEYWORD of string - | PATTERNIDENT of string - | IDENT of string - | FIELD of string - | INT of string - | STRING of string - | LEFTQMARK - | BULLET of string - | EOI - -end - -module CLexer : -sig - val add_keyword : string -> unit - val remove_keyword : string -> unit - val is_keyword : string -> bool - val keywords : unit -> CString.Set.t - - type keyword_state - val set_keyword_state : keyword_state -> unit - val get_keyword_state : unit -> keyword_state - - val check_ident : string -> unit - val terminal : string -> Tok.t - - include Grammar.GLexerType with type te = Tok.t -end - -module Extend : -sig - - type gram_assoc = NonA | RightA | LeftA - - type gram_position = - | First - | Last - | Before of string - | After of string - | Level of string - - type production_level = - | NextLevel - | NumLevel of int - - type 'a entry = 'a Grammar.GMake(CLexer).Entry.e - - type 'a user_symbol = - | Ulist1 of 'a user_symbol - | Ulist1sep of 'a user_symbol * string - | Ulist0 of 'a user_symbol - | Ulist0sep of 'a user_symbol * string - | Uopt of 'a user_symbol - | Uentry of 'a - | Uentryl of 'a * int - - type ('self, 'a) symbol = - | Atoken : Tok.t -> ('self, string) symbol - | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol - | Aself : ('self, 'self) symbol - | Anext : ('self, 'self) symbol - | Aentry : 'a entry -> ('self, 'a) symbol - | Aentryl : 'a entry * int -> ('self, 'a) symbol - | Arules : 'a rules list -> ('self, 'a) symbol - - and ('self, _, 'r) rule = - | Stop : ('self, 'r, 'r) rule - | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule - - and ('a, 'r) norec_rule = { norec_rule : 's. ('s, 'a, 'r) rule } - - and 'a rules = - | Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules - - type ('lev,'pos) constr_entry_key_gen = - | ETName | ETReference | ETBigint - | ETBinder of bool - | ETConstr of ('lev * 'pos) - | ETPattern - | ETOther of string * string - | ETConstrList of ('lev * 'pos) * Tok.t list - | ETBinderList of bool * Tok.t list - - type side = Left | Right - - type production_position = - | BorderProd of side * gram_assoc option - | InternalProd - - type constr_prod_entry_key = - (production_level,production_position) constr_entry_key_gen - - type simple_constr_prod_entry_key = - (production_level,unit) constr_entry_key_gen - - type 'a production_rule = - | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule - - type 'a single_extend_statment = - string option * - (** Level *) - gram_assoc option * - (** Associativity *) - 'a production_rule list - (** Symbol list with the interpretation function *) - - type 'a extend_statment = - gram_position option * - 'a single_extend_statment list -end - -(* XXX: Located manually from intf *) -module Vernacexpr : -sig - open Misctypes - open Constrexpr - open Libnames - - type instance_flag = bool option - type coercion_flag = bool - type inductive_flag = Decl_kinds.recursivity_kind - type lname = Names.Name.t Loc.located - type lident = Names.Id.t Loc.located - type opacity_flag = - | Opaque - | Transparent - type locality_flag = bool - type inductive_kind = - | Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool - - type vernac_type = - | VtStartProof of vernac_start - | VtSideff of vernac_sideff_type - | VtQed of vernac_qed_type - | VtProofStep of proof_step - | VtProofMode of string - | VtQuery of vernac_part_of_script * Feedback.route_id - | VtMeta - | VtUnknown - and vernac_qed_type = - | VtKeep - | VtKeepAsAxiom - | VtDrop - and vernac_start = string * opacity_guarantee * Names.Id.t list - and vernac_sideff_type = Names.Id.t list - and vernac_part_of_script = bool - and opacity_guarantee = - | GuaranteesOpacity - | Doesn'tGuaranteeOpacity - and proof_step = { - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; - proof_block_detection : proof_block_name option - } - and solving_tac = bool - and anon_abstracting_tac = bool - and proof_block_name = string - - type vernac_when = - | VtNow - | VtLater - - type verbose_flag = bool - - type obsolete_locality = bool - - type universe_decl_expr = (lident list, Misctypes.glob_constraint list) gen_universe_decl - - type ident_decl = lident * universe_decl_expr option - - type lstring - type 'a with_coercion = coercion_flag * 'a - type scope_name = string - type decl_notation = lstring * Constrexpr.constr_expr * scope_name option - type constructor_expr = (lident * Constrexpr.constr_expr) with_coercion - type 'a with_notation = 'a * decl_notation list - - type local_decl_expr = - | AssumExpr of lname * Constrexpr.constr_expr - | DefExpr of lname * Constrexpr.constr_expr * Constrexpr.constr_expr option - - type 'a with_priority = 'a * int option - type 'a with_instance = instance_flag * 'a - type constructor_list_or_record_decl_expr = - | Constructors of constructor_expr list - | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list - - type inductive_expr = ident_decl with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr - - type syntax_modifier = - | SetItemLevel of string list * Extend.production_level - | SetLevel of int - | SetAssoc of Extend.gram_assoc - | SetEntryType of string * Extend.simple_constr_prod_entry_key - | SetOnlyParsing - | SetOnlyPrinting - | SetCompatVersion of Flags.compat_version - | SetFormat of string * string Loc.located - - type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation - - type typeclass_constraint = (Names.Name.t Loc.located * universe_decl_expr option) * Decl_kinds.binding_kind * constr_expr - - type definition_expr = - | ProveBody of local_binder_expr list * constr_expr - | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr - * constr_expr option - type proof_expr = - ident_decl option * (local_binder_expr list * constr_expr) - - type proof_end = - | Admitted - | Proved of opacity_flag * lident option - - type fixpoint_expr = ident_decl * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option - - type cofixpoint_expr - - type scheme - - type section_subset_expr - - type module_binder - - type vernac_argument_status - type vernac_implicit_status - type module_ast_inl - type extend_name = string * int - type simple_binder - type option_value - type showable - type bullet - type comment - type register_kind - type locatable - type search_restriction - type searchable - type printable - type option_ref_value - type onlyparsing_flag - type reference_or_constr - - type hint_mode - - type 'a hint_info_gen = - { hint_priority : int option; - hint_pattern : 'a option } - - type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - - type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.reference list - | HintsTransparency of Libnames.reference list * bool - | HintsMode of Libnames.reference * hint_mode list - | HintsConstructors of Libnames.reference list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - - type 'a module_signature = - | Enforce of 'a (** ... : T *) - | Check of 'a list (** ... <: T1 <: T2, possibly empty *) - - type inline = - | NoInline - | DefaultInline - | InlineAt of int - - type cumulative_inductive_parsing_flag = - | GlobalCumulativity - | GlobalNonCumulativity - | LocalCumulativity - | LocalNonCumulativity - - type vernac_expr = - | VernacLoad of verbose_flag * string - | VernacTime of vernac_expr Loc.located - | VernacRedirect of string * vernac_expr Loc.located - | VernacTimeout of int * vernac_expr - | VernacFail of vernac_expr - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) - | VernacDelimiters of scope_name * string option - | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * - Constrexpr.constr_expr * scope_name option - | VernacNotation of - obsolete_locality * Constrexpr.constr_expr * (lstring * syntax_modifier list) * - scope_name option - | VernacNotationAddFormat of string * string * string - | VernacDefinition of - (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * ident_decl * definition_expr - | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list - | VernacEndProof of proof_end - | VernacExactProof of Constrexpr.constr_expr - | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * - inline * (ident_decl list * Constrexpr.constr_expr) with_coercion list - | VernacInductive of cumulative_inductive_parsing_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list - | VernacFixpoint of - Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list - | VernacCoFixpoint of - Decl_kinds.locality option * (cofixpoint_expr * decl_notation list) list - | VernacScheme of (lident option * scheme) list - | VernacCombinedScheme of lident * lident list - | VernacUniverse of lident list - | VernacConstraint of (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list - | VernacBeginSection of lident - | VernacEndSegment of lident - | VernacRequire of - Libnames.reference option * bool option * Libnames.reference list - | VernacImport of bool * Libnames.reference list - | VernacCanonical of Libnames.reference Misctypes.or_by_notation - | VernacCoercion of obsolete_locality * Libnames.reference Misctypes.or_by_notation * - class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * - class_rawexpr * class_rawexpr - | VernacNameSectionHypSet of lident * section_subset_expr - | VernacInstance of - bool * - Constrexpr.local_binder_expr list * - typeclass_constraint * - (bool * Constrexpr.constr_expr) option * - hint_info_expr - | VernacContext of Constrexpr.local_binder_expr list - | VernacDeclareInstances of - (Libnames.reference * hint_info_expr) list - | VernacDeclareClass of Libnames.reference - | VernacDeclareModule of bool option * lident * - module_binder list * module_ast_inl - | VernacDefineModule of bool option * lident * module_binder list * - module_ast_inl module_signature * module_ast_inl list - | VernacDeclareModuleType of lident * - module_binder list * module_ast_inl list * module_ast_inl list - | VernacInclude of module_ast_inl list - | VernacSolveExistential of int * Constrexpr.constr_expr - | VernacAddLoadPath of bool * string * Names.DirPath.t option - | VernacRemoveLoadPath of string - | VernacAddMLPath of bool * string - | VernacDeclareMLModule of string list - | VernacChdir of string option - | VernacWriteState of string - | VernacRestoreState of string - | VernacResetName of lident - | VernacResetInitial - | VernacBack of int - | VernacBackTo of int - | VernacCreateHintDb of string * bool - | VernacRemoveHints of string list * Libnames.reference list - | VernacHints of obsolete_locality * string list * hints_expr - | VernacSyntacticDefinition of Names.Id.t Loc.located * (Names.Id.t list * Constrexpr.constr_expr) * - obsolete_locality * onlyparsing_flag - | VernacDeclareImplicits of Libnames.reference Misctypes.or_by_notation * - (Constrexpr.explicitation * bool * bool) list list - | VernacArguments of Libnames.reference Misctypes.or_by_notation * - vernac_argument_status list * - (Names.Name.t * vernac_implicit_status) list list * - int option * - [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | - `DefaultImplicits ] list - | VernacArgumentsScope of Libnames.reference Misctypes.or_by_notation * - scope_name option list - | VernacReserve of simple_binder list - | VernacGeneralizable of (lident list) option - | VernacSetOpacity of (Conv_oracle.level * Libnames.reference Misctypes.or_by_notation list) - | VernacSetStrategy of - (Conv_oracle.level * Libnames.reference Misctypes.or_by_notation list) list - | VernacUnsetOption of Goptions.option_name - | VernacSetOption of Goptions.option_name * option_value - | VernacSetAppendOption of Goptions.option_name * string - | VernacAddOption of Goptions.option_name * option_ref_value list - | VernacRemoveOption of Goptions.option_name * option_ref_value list - | VernacMemOption of Goptions.option_name * option_ref_value list - | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of Genredexpr.raw_red_expr option * goal_selector option * Constrexpr.constr_expr - | VernacGlobalCheck of Constrexpr.constr_expr - | VernacDeclareReduction of string * Genredexpr.raw_red_expr - | VernacPrint of printable - | VernacSearch of searchable * goal_selector option * search_restriction - | VernacLocate of locatable - | VernacRegister of lident * register_kind - | VernacComments of comment list - | VernacGoal of Constrexpr.constr_expr - | VernacAbort of lident option - | VernacAbortAll - | VernacRestart - | VernacUndo of int - | VernacUndoTo of int - | VernacBacktrack of int*int*int - | VernacFocus of int option - | VernacUnfocus - | VernacUnfocused - | VernacBullet of bullet - | VernacSubproof of int option - | VernacEndSubproof - | VernacShow of showable - | VernacCheckGuard - | VernacProof of Genarg.raw_generic_argument option * section_subset_expr option - | VernacProofMode of string - | VernacToplevelControl of exn - | VernacExtend of extend_name * Genarg.raw_generic_argument list - | VernacProgram of vernac_expr - | VernacPolymorphic of bool * vernac_expr - | VernacLocal of bool * vernac_expr - and goal_selector = - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Names.Id.t - | SelectAll - and vernac_classification = vernac_type * vernac_when - and one_inductive_expr = - ident_decl * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list -end -(* XXX: end of moved from intf *) - -module Typeclasses : -sig - type typeclass = { - cl_univs : Univ.AUContext.t; - cl_impl : Globnames.global_reference; - cl_context : (Globnames.global_reference * bool) option list * Context.Rel.t; - cl_props : Context.Rel.t; - cl_projs : (Names.Name.t * (direction * Vernacexpr.hint_info_expr) option - * Names.Constant.t option) list; - cl_strict : bool; - cl_unique : bool; - } - and direction - - type instance - type evar_filter = Evar.t -> Evar_kinds.t -> bool - - val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool -> - ?split:bool -> ?fail:bool -> Environ.env -> Evd.evar_map -> Evd.evar_map - val set_resolvable : Evd.Store.t -> bool -> Evd.Store.t - val resolve_one_typeclass : ?unique:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.constr - val class_info : Globnames.global_reference -> typeclass - val mark_resolvables : ?filter:evar_filter -> Evd.evar_map -> Evd.evar_map - val add_instance : instance -> unit - val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic -> - Globnames.global_reference -> instance -end - -module Classops : -sig - type coe_index - type inheritance_path = coe_index list - type cl_index - - val hide_coercion : Globnames.global_reference -> int option - val lookup_path_to_sort_from : Environ.env -> Evd.evar_map -> EConstr.types -> - EConstr.types * inheritance_path - val get_coercion_value : coe_index -> Constr.t - val coercions : unit -> coe_index list - val pr_cl_index : cl_index -> Pp.t -end - -module Detyping : -sig - type 'a delay = - | Now : 'a delay - | Later : [ `thunk ] delay - val print_universes : bool ref - val print_evar_arguments : bool ref - val detype : 'a delay -> ?lax:bool -> bool -> Names.Id.Set.t -> Environ.env -> Evd.evar_map -> EConstr.constr -> 'a Glob_term.glob_constr_g - val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr - val set_detype_anonymous : (?loc:Loc.t -> int -> Names.Id.t) -> unit -end - -module Indrec : -sig - type dep_flag = bool - val lookup_eliminator : Names.inductive -> Sorts.family -> Globnames.global_reference - val build_case_analysis_scheme : Environ.env -> Evd.evar_map -> Constr.pinductive -> - dep_flag -> Sorts.family -> Evd.evar_map * Constr.t - val make_elimination_ident : Names.Id.t -> Sorts.family -> Names.Id.t - val build_mutual_induction_scheme : - Environ.env -> Evd.evar_map -> (Constr.pinductive * dep_flag * Sorts.family) list -> Evd.evar_map * Constr.t list - val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Constr.pinductive -> - Sorts.family -> Evd.evar_map * Constr.t -end - -module Pretyping : -sig - type typing_constraint = - | OfType of EConstr.types - | IsType - | WithoutTypeConstraint - - type inference_hook = Environ.env -> Evd.evar_map -> Evar.t -> Evd.evar_map * EConstr.constr - - type inference_flags = { - use_typeclasses : bool; - solve_unification_constraints : bool; - use_hook : inference_hook option; - fail_evar : bool; - expand_evars : bool - } - - val understand_ltac : inference_flags -> - Environ.env -> Evd.evar_map -> Ltac_pretype.ltac_var_map -> - typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.t - val understand_tcc : ?flags:inference_flags -> Environ.env -> Evd.evar_map -> - ?expected_type:typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr - val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Constr.t Evd.in_evar_universe_context - val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit - val register_constr_interp0 : - ('r, 'g, 't) Genarg.genarg_type -> - (Ltac_pretype.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit - val all_and_fail_flags : inference_flags - val ise_pretype_gen : - inference_flags -> Environ.env -> Evd.evar_map -> - Ltac_pretype.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr -end - -module Unification : -sig - type core_unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; - use_metas_eagerly_in_conv_on_closed_terms : bool; - use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; - modulo_delta_types : Names.transparent_state; - check_applied_meta_types : bool; - use_pattern_unification : bool; - use_meta_bound_pattern_unification : bool; - frozen_evars : Evar.Set.t; - restrict_conv_on_strict_subterms : bool; - modulo_betaiota : bool; - modulo_eta : bool; - } - type unify_flags = - { - core_unify_flags : core_unify_flags; - merge_unify_flags : core_unify_flags; - subterm_unify_flags : core_unify_flags; - allow_K_in_toplevel_higher_order_unification : bool; - resolve_evars : bool - } - val default_no_delta_unify_flags : unit -> unify_flags - val w_unify : Environ.env -> Evd.evar_map -> Reduction.conv_pb -> ?flags:unify_flags -> EConstr.constr -> EConstr.constr -> Evd.evar_map - val elim_flags : unit -> unify_flags - val w_unify_to_subterm : - Environ.env -> Evd.evar_map -> ?flags:unify_flags -> EConstr.constr * EConstr.constr -> Evd.evar_map * EConstr.constr -end - -module Univdecls : -sig - type universe_decl = - (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl - - val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr -> - Evd.evar_map * universe_decl - val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option -> - Evd.evar_map * universe_decl - val default_univ_decl : universe_decl -end - -(************************************************************************) -(* End of modules from pretyping/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from interp/ *) -(************************************************************************) - -module Tactypes : -sig - type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option - type glob_constr_pattern_and_expr = Names.Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern - type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - type delayed_open_constr = EConstr.constr delayed_open - type delayed_open_constr_with_bindings = EConstr.constr Misctypes.with_bindings delayed_open - type intro_pattern = delayed_open_constr Misctypes.intro_pattern_expr Loc.located - type intro_patterns = delayed_open_constr Misctypes.intro_pattern_expr Loc.located list - type intro_pattern_naming = Misctypes.intro_pattern_naming_expr Loc.located - type or_and_intro_pattern = delayed_open_constr Misctypes.or_and_intro_pattern_expr Loc.located -end - -module Genintern : -sig - open Genarg - - module Store : Store.S - - type glob_sign = { - ltacvars : Names.Id.Set.t; - genv : Environ.env; - extra : Store.t; - } - - val empty_glob_sign : Environ.env -> glob_sign - - type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb - - - val generic_intern : (raw_generic_argument, glob_generic_argument) intern_fun - - type 'glb subst_fun = Mod_subst.substitution -> 'glb -> 'glb - val generic_substitute : Genarg.glob_generic_argument subst_fun - - type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Names.Id.Map.t -> 'glb -> 'glb - - val register_intern0 : ('raw, 'glb, 'top) genarg_type -> - ('raw, 'glb) intern_fun -> unit - - val register_subst0 : ('raw, 'glb, 'top) genarg_type -> - 'glb subst_fun -> unit - - val register_ntn_subst0 : ('raw, 'glb, 'top) genarg_type -> - 'glb ntn_subst_fun -> unit - -end - -module Stdarg : -sig - val loc_of_or_by_notation : ('a -> Loc.t option) -> 'a Misctypes.or_by_notation -> Loc.t option - val wit_unit : unit Genarg.uniform_genarg_type - val wit_int : int Genarg.uniform_genarg_type - val wit_var : (Names.Id.t Loc.located, Names.Id.t Loc.located, Names.Id.t) Genarg.genarg_type - val wit_bool : bool Genarg.uniform_genarg_type - val wit_string : string Genarg.uniform_genarg_type - val wit_pre_ident : string Genarg.uniform_genarg_type - val wit_global : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type - val wit_ident : Names.Id.t Genarg.uniform_genarg_type - val wit_integer : int Genarg.uniform_genarg_type - val wit_sort_family : (Sorts.family, unit, unit) Genarg.genarg_type - val wit_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type - val wit_open_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type - val wit_intro_pattern : (Constrexpr.constr_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.glob_constr_and_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.intro_pattern) Genarg.genarg_type - val wit_int_or_var : (int Misctypes.or_var, int Misctypes.or_var, int) Genarg.genarg_type - val wit_ref : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type - val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) Genarg.genarg_type - val wit_uconstr : (Constrexpr.constr_expr , Tactypes.glob_constr_and_expr, Ltac_pretype.closed_glob_constr) Genarg.genarg_type - val wit_red_expr : - ((Constrexpr.constr_expr,Libnames.reference Misctypes.or_by_notation,Constrexpr.constr_expr) Genredexpr.red_expr_gen, - (Tactypes.glob_constr_and_expr,Names.evaluable_global_reference Misctypes.and_short_name Misctypes.or_var,Tactypes.glob_constr_pattern_and_expr) Genredexpr.red_expr_gen, - (EConstr.constr,Names.evaluable_global_reference,Pattern.constr_pattern) Genredexpr.red_expr_gen) Genarg.genarg_type - val wit_quant_hyp : Misctypes.quantified_hypothesis Genarg.uniform_genarg_type - val wit_bindings : - (Constrexpr.constr_expr Misctypes.bindings, - Tactypes.glob_constr_and_expr Misctypes.bindings, - EConstr.constr Misctypes.bindings Tactypes.delayed_open) Genarg.genarg_type - val wit_constr_with_bindings : - (Constrexpr.constr_expr Misctypes.with_bindings, - Tactypes.glob_constr_and_expr Misctypes.with_bindings, - EConstr.constr Misctypes.with_bindings Tactypes.delayed_open) Genarg.genarg_type - val wit_intropattern : (Constrexpr.constr_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.glob_constr_and_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.intro_pattern) Genarg.genarg_type - val wit_quantified_hypothesis : Misctypes.quantified_hypothesis Genarg.uniform_genarg_type - val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) Genarg.genarg_type - val wit_preident : string Genarg.uniform_genarg_type - val wit_reference : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type - val wit_open_constr_with_bindings : - (Constrexpr.constr_expr Misctypes.with_bindings, - Tactypes.glob_constr_and_expr Misctypes.with_bindings, - EConstr.constr Misctypes.with_bindings Tactypes.delayed_open) Genarg.genarg_type -end - -module Constrexpr_ops : -sig - val mkIdentC : Names.Id.t -> Constrexpr.constr_expr - val mkAppC : Constrexpr.constr_expr * Constrexpr.constr_expr list -> Constrexpr.constr_expr - val names_of_local_assums : Constrexpr.local_binder_expr list -> Names.Name.t Loc.located list - val coerce_reference_to_id : Libnames.reference -> Names.Id.t - val coerce_to_id : Constrexpr.constr_expr -> Names.Id.t Loc.located - val constr_loc : Constrexpr.constr_expr -> Loc.t option - val mkRefC : Libnames.reference -> Constrexpr.constr_expr - val mkLambdaC : Names.Name.t Loc.located list * Constrexpr.binder_kind * Constrexpr.constr_expr * Constrexpr.constr_expr -> Constrexpr.constr_expr - val default_binder_kind : Constrexpr.binder_kind - val mkLetInC : Names.Name.t Loc.located * Constrexpr.constr_expr * Constrexpr.constr_expr option * Constrexpr.constr_expr -> Constrexpr.constr_expr - val mkCProdN : ?loc:Loc.t -> Constrexpr.local_binder_expr list -> Constrexpr.constr_expr -> Constrexpr.constr_expr - val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr -end - -module Notation_ops : -sig - val glob_constr_of_notation_constr : ?loc:Loc.t -> Notation_term.notation_constr -> Glob_term.glob_constr - val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> - ('a -> Names.Name.t -> 'a * Names.Name.t) -> - ('a -> Notation_term.notation_constr -> Glob_term.glob_constr) -> - 'a -> Notation_term.notation_constr -> Glob_term.glob_constr -end - -module Notation : -sig - type cases_pattern_status = bool - type required_module = Libnames.full_path * string list - type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> Glob_term.glob_constr - type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.any_glob_constr -> 'a option) * cases_pattern_status - type delimiters = string - type local_scopes = Notation_term.tmp_scope_name option * Notation_term.scope_name list - type notation_location = (Names.DirPath.t * Names.DirPath.t) * string - val declare_string_interpreter : Notation_term.scope_name -> required_module -> - string prim_token_interpreter -> string prim_token_uninterpreter -> unit - val declare_numeral_interpreter : Notation_term.scope_name -> required_module -> - Bigint.bigint prim_token_interpreter -> Bigint.bigint prim_token_uninterpreter -> unit - val interp_notation_as_global_reference : ?loc:Loc.t -> (Globnames.global_reference -> bool) -> - Constrexpr.notation -> delimiters option -> Globnames.global_reference - val locate_notation : (Glob_term.glob_constr -> Pp.t) -> Constrexpr.notation -> - Notation_term.scope_name option -> Pp.t - val find_delimiters_scope : ?loc:Loc.t -> delimiters -> Notation_term.scope_name - val pr_scope : (Glob_term.glob_constr -> Pp.t) -> Notation_term.scope_name -> Pp.t - val pr_scopes : (Glob_term.glob_constr -> Pp.t) -> Pp.t - val interp_notation : ?loc:Loc.t -> Constrexpr.notation -> local_scopes -> - Notation_term.interpretation * (notation_location * Notation_term.scope_name option) - val uninterp_prim_token : Glob_term.glob_constr -> Notation_term.scope_name * Constrexpr.prim_token -end - -module Dumpglob : -sig - val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit - val pause : unit -> unit - val continue : unit -> unit -end - -module Smartlocate : -sig - val locate_global_with_alias : ?head:bool -> Libnames.qualid Loc.located -> Globnames.global_reference - val global_with_alias : ?head:bool -> Libnames.reference -> Globnames.global_reference - val global_of_extended_global : Globnames.extended_global_reference -> Globnames.global_reference - val loc_of_smart_reference : Libnames.reference Misctypes.or_by_notation -> Loc.t option - val smart_global : ?head:bool -> Libnames.reference Misctypes.or_by_notation -> Globnames.global_reference -end - -module Topconstr : -sig - - val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr - [@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] - -end - -module Constrintern : -sig - type ltac_sign = { - ltac_vars : Names.Id.Set.t; - ltac_bound : Names.Id.Set.t; - ltac_extra : Genintern.Store.t; - } - - type var_internalization_data - - type var_internalization_type = - | Inductive of Names.Id.t list * bool - | Recursive - | Method - | Variable - type internalization_env = var_internalization_data Names.Id.Map.t - - val interp_constr_evars : Environ.env -> Evd.evar_map ref -> - ?impls:internalization_env -> Constrexpr.constr_expr -> EConstr.constr - - val interp_type_evars : Environ.env -> Evd.evar_map ref -> - ?impls:internalization_env -> Constrexpr.constr_expr -> EConstr.types - - val empty_ltac_sign : ltac_sign - val intern_gen : Pretyping.typing_constraint -> Environ.env -> - ?impls:internalization_env -> ?pattern_mode:bool -> ?ltacvars:ltac_sign -> - Constrexpr.constr_expr -> Glob_term.glob_constr - val intern_constr_pattern : - Environ.env -> ?as_type:bool -> ?ltacvars:ltac_sign -> - Constrexpr.constr_pattern_expr -> Names.Id.t list * Pattern.constr_pattern - val intern_constr : Environ.env -> Constrexpr.constr_expr -> Glob_term.glob_constr - val for_grammar : ('a -> 'b) -> 'a -> 'b - val interp_reference : ltac_sign -> Libnames.reference -> Glob_term.glob_constr - val interp_constr : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> - Constrexpr.constr_expr -> Constr.t Evd.in_evar_universe_context - val interp_open_constr : Environ.env -> Evd.evar_map -> Constrexpr.constr_expr -> Evd.evar_map * EConstr.constr - val locate_reference : Libnames.qualid -> Globnames.global_reference - val interp_type : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> - Constrexpr.constr_expr -> Constr.types Evd.in_evar_universe_context - val interp_context_evars : - ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> - Environ.env -> Evd.evar_map ref -> Constrexpr.local_binder_expr list -> - internalization_env * ((Environ.env * EConstr.rel_context) * Impargs.manual_implicits) - val compute_internalization_data : Environ.env -> var_internalization_type -> - Constr.types -> Impargs.manual_explicitation list -> var_internalization_data - val empty_internalization_env : internalization_env - val global_reference : Names.Id.t -> Globnames.global_reference -end - -module Constrextern : -sig - val extern_glob_constr : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr - val extern_glob_type : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr - val extern_constr : ?lax:bool -> bool -> Environ.env -> Evd.evar_map -> EConstr.t -> Constrexpr.constr_expr - val without_symbols : ('a -> 'b) -> 'a -> 'b - val print_universes : bool ref - val extern_type : bool -> Environ.env -> Evd.evar_map -> EConstr.t -> Constrexpr.constr_expr - val with_universes : ('a -> 'b) -> 'a -> 'b - val set_extern_reference : - (?loc:Loc.t -> Names.Id.Set.t -> Globnames.global_reference -> Libnames.reference) -> unit -end - -module Declare : -sig - type internal_flag = - | UserAutomaticRequest - | InternalTacticRequest - | UserIndividualRequest - - type constant_declaration = Safe_typing.private_constants Entries.constant_entry * Decl_kinds.logical_kind - - type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants Entries.definition_entry - | SectionLocalAssum of Constr.types Univ.in_universe_context_set * Decl_kinds.polymorphic * bool - - type variable_declaration = Names.DirPath.t * section_variable_entry * Decl_kinds.logical_kind - - val declare_constant : - ?internal:internal_flag -> ?local:bool -> Names.Id.t -> ?export_seff:bool -> constant_declaration -> Names.Constant.t - - val declare_universe_context : Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit - - val declare_definition : - ?internal:internal_flag -> ?opaque:bool -> ?kind:Decl_kinds.definition_object_kind -> - ?local:bool -> Names.Id.t -> ?types:Constr.t -> - Constr.t Entries.in_constant_universes_entry -> Names.Constant.t - val definition_entry : ?fix_exn:Future.fix_exn -> - ?opaque:bool -> ?inline:bool -> ?types:Constr.types -> - ?univs:Entries.constant_universes_entry -> - ?eff:Safe_typing.private_constants -> Constr.t -> Safe_typing.private_constants Entries.definition_entry - val definition_message : Names.Id.t -> unit - val declare_variable : Names.Id.t -> variable_declaration -> Libnames.object_name -end - -(************************************************************************) -(* End of modules from interp/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from proofs/ *) -(************************************************************************) - -module Miscprint : -sig - val pr_or_and_intro_pattern : - ('a -> Pp.t) -> 'a Misctypes.or_and_intro_pattern_expr -> Pp.t - val pr_intro_pattern_naming : Misctypes.intro_pattern_naming_expr -> Pp.t - val pr_intro_pattern : - ('a -> Pp.t) -> 'a Misctypes.intro_pattern_expr Loc.located -> Pp.t - val pr_bindings : - ('a -> Pp.t) -> - ('a -> Pp.t) -> 'a Misctypes.bindings -> Pp.t - val pr_bindings_no_with : - ('a -> Pp.t) -> - ('a -> Pp.t) -> 'a Misctypes.bindings -> Pp.t - val pr_with_bindings : - ('a -> Pp.t) -> - ('a -> Pp.t) -> 'a * 'a Misctypes.bindings -> Pp.t -end - -(* All items in the Goal modules are deprecated. *) -module Goal : -sig - type goal = Evar.t - - val pr_goal : goal -> Pp.t - - module V82 : - sig - val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma - - val nf_hyps : Evd.evar_map -> goal -> Environ.named_context_val - - val env : Evd.evar_map -> goal -> Environ.env - - val concl : Evd.evar_map -> goal -> EConstr.constr - - val mk_goal : Evd.evar_map -> - Environ.named_context_val -> - EConstr.constr -> - Evd.Store.t -> - goal * EConstr.constr * Evd.evar_map - - val extra : Evd.evar_map -> goal -> Evd.Store.t - - val partial_solution_to : Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map - - val partial_solution : Evd.evar_map -> goal -> EConstr.constr -> Evd.evar_map - - val hyps : Evd.evar_map -> goal -> Environ.named_context_val - - val abstract_type : Evd.evar_map -> goal -> EConstr.types - end -end - -module Evar_refiner : -sig - type glob_constr_ltac_closure = Ltac_pretype.ltac_var_map * Glob_term.glob_constr - - val w_refine : Evar.t * Evd.evar_info -> - glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map -end - - -module Proof_type : -sig - type prim_rule = Refine of Constr.t - - type tactic = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -end - -module Logic : -sig - type refiner_error = - | BadType of Constr.t * Constr.t * Constr.t - | UnresolvedBindings of Names.Name.t list - | CannotApply of Constr.t * Constr.t - | NotWellTyped of Constr.t - | NonLinearProof of Constr.t - | MetaInType of EConstr.constr - | IntroNeedsProduct - | DoesNotOccurIn of Constr.t * Names.Id.t - | NoSuchHyp of Names.Id.t - exception RefinerError of refiner_error - val catchable_exception : exn -> bool -end - -module Refine : -sig - val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit Proofview.tactic - val solve_constraints : unit Proofview.tactic -end - -module Proof : -sig - type proof - type 'a focus_kind - - val proof : proof -> - Goal.goal list * (Goal.goal list * Goal.goal list) list * - Goal.goal list * Goal.goal list * Evd.evar_map - - val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof * (bool * Proofview_monad.Info.tree) - val unshelve : proof -> proof - val maximal_unfocus : 'a focus_kind -> proof -> proof - val pr_proof : proof -> Pp.t - - module V82 : - sig - val grab_evars : proof -> proof - - val subgoals : proof -> Goal.goal list Evd.sigma - [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] - - end -end - -module Proof_bullet : -sig - val get_default_goal_selector : unit -> Vernacexpr.goal_selector -end - -module Proof_global : -sig - - type state - - type proof_mode = { - name : string; - set : unit -> unit ; - reset : unit -> unit - } - type proof_universes = UState.t * Universes.universe_binders option - type proof_object = { - id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; - persistence : Decl_kinds.goal_kind; - universes: proof_universes; - } - - type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - proof_universes - | Proved of Vernacexpr.opacity_flag * - Vernacexpr.lident option * - proof_object - - type proof_terminator - type lemma_possible_guards - type closed_proof = proof_object * proof_terminator - - val make_terminator : (proof_ending -> unit) -> proof_terminator - val start_dependent_proof : - Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> unit - val with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof * 'a) -> 'a - val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit - val compact_the_proof : unit -> unit - val register_proof_mode : proof_mode -> unit - - exception NoCurrentProof - val give_me_the_proof : unit -> Proof.proof - (** @raise NoCurrentProof when outside proof mode. *) - - val discard_all : unit -> unit - val discard_current : unit -> unit - val get_current_proof_name : unit -> Names.Id.t -end - -module Redexpr : -sig - type red_expr = - (EConstr.constr, Names.evaluable_global_reference, Pattern.constr_pattern) Genredexpr.red_expr_gen - val reduction_of_red_expr : - Environ.env -> red_expr -> Reductionops.e_reduction_function * Constr.cast_kind - val declare_reduction : string -> Reductionops.reduction_function -> unit -end - -module Refiner : -sig - val project : 'a Evd.sigma -> Evd.evar_map - - val unpackage : 'a Evd.sigma -> Evd.evar_map ref * 'a - - val repackage : Evd.evar_map ref -> 'a -> 'a Evd.sigma - - val tclSHOWHYPS : Proof_type.tactic -> Proof_type.tactic - exception FailError of int * Pp.t Lazy.t - - val tclEVARS : Evd.evar_map -> Proof_type.tactic - val tclMAP : ('a -> Proof_type.tactic) -> 'a list -> Proof_type.tactic - val tclREPEAT : Proof_type.tactic -> Proof_type.tactic - val tclORELSE : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic - val tclFAIL : int -> Pp.t -> Proof_type.tactic - val tclIDTAC : Proof_type.tactic - val tclTHEN : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic - val tclTHENLIST : Proof_type.tactic list -> Proof_type.tactic - val tclTRY : Proof_type.tactic -> Proof_type.tactic - val tclAT_LEAST_ONCE : Proof_type.tactic -> Proof_type.tactic -end - -module Tacmach : -sig - - type tactic = Proof_type.tactic - - type 'a sigma = 'a Evd.sigma - [@@ocaml.deprecated "alias of API.Evd.sigma"] - - val re_sig : 'a -> Evd.evar_map -> 'a Evd.sigma - - val pf_reduction_of_red_expr : Goal.goal Evd.sigma -> Redexpr.red_expr -> EConstr.constr -> Evd.evar_map * EConstr.constr - - val pf_unsafe_type_of : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.types - - val pf_get_new_id : Names.Id.t -> Goal.goal Evd.sigma -> Names.Id.t - - val pf_env : Goal.goal Evd.sigma -> Environ.env - - val pf_concl : Goal.goal Evd.sigma -> EConstr.types - - val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> Goal.goal Evd.sigma -> 'a - - val pf_get_hyp : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.named_declaration - val pf_get_hyp_typ : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.types - val project : Goal.goal Evd.sigma -> Evd.evar_map - val refine : EConstr.constr -> Proof_type.tactic - val refine_no_check : EConstr.constr -> Proof_type.tactic - val pf_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Evd.evar_map * EConstr.types - - val pf_hyps : Goal.goal Evd.sigma -> EConstr.named_context - - val pf_ids_of_hyps : Goal.goal Evd.sigma -> Names.Id.t list - - val pf_reduce_to_atomic_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - - val pf_reduce_to_quantified_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - - val pf_eapply : (Environ.env -> Evd.evar_map -> 'a -> Evd.evar_map * 'b) -> - Evar.t Evd.sigma -> 'a -> Evar.t Evd.sigma * 'b - - val pf_unfoldn : (Locus.occurrences * Names.evaluable_global_reference) list - -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr - - val pf_reduce : (Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr) -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr - - val pf_conv_x : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -> bool - - val pf_is_matching : Goal.goal Evd.sigma -> Pattern.constr_pattern -> EConstr.constr -> bool - - val pf_hyps_types : Goal.goal Evd.sigma -> (Names.Id.t * EConstr.types) list - - val pr_gls : Goal.goal Evd.sigma -> Pp.t - - val pf_nf_betaiota : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr - - val pf_last_hyp : Goal.goal Evd.sigma -> EConstr.named_declaration - - val pf_nth_hyp_id : Goal.goal Evd.sigma -> int -> Names.Id.t - - val sig_it : 'a Evd.sigma -> 'a - - module New : - sig - val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val project : 'a Proofview.Goal.t -> Evd.evar_map - val pf_unsafe_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types - val of_old : (Goal.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a - - val pf_env : 'a Proofview.Goal.t -> Environ.env - val pf_ids_of_hyps : 'a Proofview.Goal.t -> Names.Id.t list - val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Names.Id.Set.t - val pf_concl : 'a Proofview.Goal.t -> EConstr.types - val pf_get_new_id : Names.Id.t -> 'a Proofview.Goal.t -> Names.Id.t - val pf_get_hyp : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.named_declaration - val pf_get_hyp_typ : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.types - val pf_get_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types - val pf_global : Names.Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference - val pf_hyps_types : 'a Proofview.Goal.t -> (Names.Id.t * EConstr.types) list - end -end - -module Pfedit : -sig - val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option - val refine_by_tactic : Environ.env -> Evd.evar_map -> EConstr.types -> unit Proofview.tactic -> - Constr.t * Evd.evar_map - val declare_implicit_tactic : unit Proofview.tactic -> unit - val clear_implicit_tactic : unit -> unit - val by : unit Proofview.tactic -> bool - val solve : ?with_end_tac:unit Proofview.tactic -> - Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof * bool - val cook_proof : - unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) - - val get_current_context : unit -> Evd.evar_map * Environ.env - val current_proof_statement : unit -> Names.Id.t * Decl_kinds.goal_kind * EConstr.types -end - -module Clenv : -sig - - type hole = { - hole_evar : EConstr.constr; - hole_type : EConstr.types; - hole_deps : bool; - hole_name : Names.Name.t; - } - - type clause = { - cl_holes : hole list; - cl_concl : EConstr.types; - } - - val make_evar_clause : Environ.env -> Evd.evar_map -> ?len:int -> EConstr.types -> - (Evd.evar_map * clause) - val solve_evar_clause : Environ.env -> Evd.evar_map -> bool -> clause -> EConstr.constr Misctypes.bindings -> - Evd.evar_map - type clausenv - val pr_clenv : clausenv -> Pp.t -end - -(************************************************************************) -(* End of modules from proofs/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from parsing/ *) -(************************************************************************) - -module Pcoq : -sig - - open Loc - open Names - open Extend - open Vernacexpr - open Genarg - open Constrexpr - open Libnames - open Misctypes - open Genredexpr - - module Gram : sig - include Grammar.S with type te = Tok.t - - type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action - type production_rule = symbol list * action - type single_extend_statment = - string option * Gramext.g_assoc option * production_rule list - type extend_statment = - Gramext.position option * single_extend_statment list - - type coq_parsable - - val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable - val action : 'a -> action - val entry_create : string -> 'a entry - val entry_parse : 'a entry -> coq_parsable -> 'a - val entry_print : Format.formatter -> 'a entry -> unit - val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b - - (* Apparently not used *) - val srules' : production_rule list -> symbol - val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a - - end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e - - val parse_string : 'a Gram.entry -> string -> 'a - val eoi_entry : 'a Gram.entry -> 'a Gram.entry - val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry - - type gram_universe - - val uprim : gram_universe - val uconstr : gram_universe - val utactic : gram_universe - val uvernac : gram_universe - - val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit - - val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry - - val create_generic_entry : gram_universe -> string -> - ('a, rlevel) abstract_argument_type -> 'a Gram.entry - - module Prim : - sig - open Names - open Libnames - val preident : string Gram.entry - val ident : Id.t Gram.entry - val name : Name.t located Gram.entry - val identref : Id.t located Gram.entry - val pattern_ident : Id.t Gram.entry - val pattern_identref : Id.t located Gram.entry - val base_ident : Id.t Gram.entry - val natural : int Gram.entry - val bigint : Constrexpr.raw_natural_number Gram.entry - val integer : int Gram.entry - val string : string Gram.entry - val lstring : string located Gram.entry - val qualid : qualid located Gram.entry - val fullyqualid : Id.t list located Gram.entry - val reference : reference Gram.entry - val by_notation : (string * string option) Loc.located Gram.entry - val smart_global : reference or_by_notation Gram.entry - val dirpath : DirPath.t Gram.entry - val ne_string : string Gram.entry - val ne_lstring : string located Gram.entry - val var : Id.t located Gram.entry - end - - module Constr : - sig - val constr : constr_expr Gram.entry - val constr_eoi : constr_expr Gram.entry - val lconstr : constr_expr Gram.entry - val binder_constr : constr_expr Gram.entry - val operconstr : constr_expr Gram.entry - val ident : Id.t Gram.entry - val global : reference Gram.entry - val universe_level : glob_level Gram.entry - val sort : glob_sort Gram.entry - val sort_family : Sorts.family Gram.entry - val pattern : cases_pattern_expr Gram.entry - val constr_pattern : constr_expr Gram.entry - val lconstr_pattern : constr_expr Gram.entry - val closed_binder : local_binder_expr list Gram.entry - val binder : local_binder_expr list Gram.entry (* closed_binder or variable *) - val binders : local_binder_expr list Gram.entry (* list of binder *) - val open_binders : local_binder_expr list Gram.entry - val binders_fixannot : (local_binder_expr list * (Id.t located option * recursion_order_expr)) Gram.entry - val typeclass_constraint : (Name.t located * bool * constr_expr) Gram.entry - val record_declaration : constr_expr Gram.entry - val appl_arg : (constr_expr * explicitation located option) Gram.entry - end - - module Vernac_ : - sig - val gallina : vernac_expr Gram.entry - val gallina_ext : vernac_expr Gram.entry - val command : vernac_expr Gram.entry - val syntax : vernac_expr Gram.entry - val vernac : vernac_expr Gram.entry - val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry - val vernac_eoi : vernac_expr Gram.entry - val noedit_mode : vernac_expr Gram.entry - val command_entry : vernac_expr Gram.entry - val red_expr : raw_red_expr Gram.entry - val hint_info : Vernacexpr.hint_info_expr Gram.entry - end - - val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option - - val get_command_entry : unit -> vernac_expr Gram.entry - val set_command_entry : vernac_expr Gram.entry -> unit - - type gram_reinit = gram_assoc * gram_position - val grammar_extend : 'a Gram.entry -> gram_reinit option -> - 'a Extend.extend_statment -> unit - - module GramState : Store.S - - type 'a grammar_command - - type extend_rule = - | ExtendRule : 'a Gram.entry * gram_reinit option * 'a extend_statment -> extend_rule - - type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t - - val create_grammar_command : string -> 'a grammar_extension -> 'a grammar_command - - val extend_grammar_command : 'a grammar_command -> 'a -> unit - val recover_grammar_command : 'a grammar_command -> 'a list - val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b - - val to_coqloc : Ploc.t -> Loc.t - val (!@) : Ploc.t -> Loc.t - -end - -module Egramml : -sig - open Vernacexpr - - type 's grammar_prod_item = - | GramTerminal of string - | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option * - ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item - - val extend_vernac_command_grammar : - extend_name -> vernac_expr Pcoq.Gram.entry option -> - vernac_expr grammar_prod_item list -> unit - - val make_rule : - (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> - 'a grammar_prod_item list -> 'a Extend.production_rule - -end - -module G_vernac : -sig - - val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry - val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry - val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry - -end - -module G_proofs : -sig - - val hint : Vernacexpr.hints_expr Pcoq.Gram.entry - -end - -(************************************************************************) -(* End of modules from parsing/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from printing/ *) -(************************************************************************) - -module Genprint : -sig - type printer_with_level = - { default_already_surrounded : Notation_term.tolerability; - default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } - type printer_result = - | PrinterBasic of (unit -> Pp.t) - | PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) - | PrinterNeedsContextAndLevel of printer_with_level - type 'a printer = 'a -> Pp.t - type 'a top_printer = 'a -> printer_result - val register_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'raw printer -> 'glb printer -> 'top top_printer -> unit - val register_vernac_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'raw printer -> unit - val register_val_print0 : 'top Geninterp.Val.typ -> 'top top_printer -> unit - val generic_top_print : Genarg.tlevel Genarg.generic_argument top_printer - val generic_val_print : Geninterp.Val.t top_printer -end - -module Pputils : -sig - val pr_with_occurrences : ('a -> Pp.t) -> (string -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t - val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> - (string -> Pp.t) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t - val pr_raw_generic : Environ.env -> Genarg.rlevel Genarg.generic_argument -> Pp.t - val pr_glb_generic : Environ.env -> Genarg.glevel Genarg.generic_argument -> Pp.t - val pr_or_var : ('a -> Pp.t) -> 'a Misctypes.or_var -> Pp.t - val pr_or_by_notation : ('a -> Pp.t) -> 'a Misctypes.or_by_notation -> Pp.t -end - -module Ppconstr : -sig - val pr_name : Names.Name.t -> Pp.t - [@@ocaml.deprecated "alias of API.Names.Name.print"] - - val lsimpleconstr : Notation_term.tolerability - val ltop : Notation_term.tolerability - val pr_id : Names.Id.t -> Pp.t - val pr_or_var : ('a -> Pp.t) -> 'a Misctypes.or_var -> Pp.t - val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t - val pr_lident : Names.Id.t Loc.located -> Pp.t - val pr_lname : Names.Name.t Loc.located -> Pp.t - val prec_less : int -> int * Notation_term.parenRelation -> bool - val pr_constr_expr : Constrexpr.constr_expr -> Pp.t - val pr_lconstr_expr : Constrexpr.constr_expr -> Pp.t - val pr_constr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.t - val pr_lconstr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.t - val pr_binders : Constrexpr.local_binder_expr list -> Pp.t - val pr_glob_sort : Misctypes.glob_sort -> Pp.t -end - -module Printer : -sig - val pr_named_context : Environ.env -> Evd.evar_map -> Context.Named.t -> Pp.t - val pr_rel_context : Environ.env -> Evd.evar_map -> Context.Rel.t -> Pp.t - val pr_goal : Goal.goal Evd.sigma -> Pp.t - - val pr_constr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t - val pr_lconstr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t - - val pr_constr : Constr.t -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_lconstr : Constr.t -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_econstr : EConstr.constr -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_glob_constr : Glob_term.glob_constr -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_constr_pattern : Pattern.constr_pattern -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_glob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t - val pr_lglob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t - val pr_econstr_n_env : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> EConstr.constr -> Pp.t - val pr_econstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t - val pr_constr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t - val pr_lconstr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t - val pr_closed_glob : Ltac_pretype.closed_glob_constr -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - val pr_lglob_constr : Glob_term.glob_constr -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t - val pr_leconstr : EConstr.constr -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_global : Globnames.global_reference -> Pp.t - val pr_lconstr_under_binders : Ltac_pretype.constr_under_binders -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t - - val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t - val pr_closed_glob_n_env : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Ltac_pretype.closed_glob_constr -> Pp.t - val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Ltac_pretype.closed_glob_constr -> Pp.t - val pr_rel_context_of : Environ.env -> Evd.evar_map -> Pp.t - val pr_named_context_of : Environ.env -> Evd.evar_map -> Pp.t - val pr_ltype : Constr.types -> Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t - [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - - val pr_idpred : Names.Id.Pred.t -> Pp.t - val pr_cpred : Names.Cpred.t -> Pp.t - val pr_transparent_state : Names.transparent_state -> Pp.t -end - -module Prettyp : -sig - type 'a locatable_info = { - locate : Libnames.qualid -> 'a option; - locate_all : Libnames.qualid -> 'a list; - shortest_qualid : 'a -> Libnames.qualid; - name : 'a -> Pp.t; - print : 'a -> Pp.t; - about : 'a -> Pp.t; - } - - val register_locatable : string -> 'a locatable_info -> unit - val print_located_other : string -> Libnames.reference -> Pp.t -end - -(************************************************************************) -(* End of modules from printing/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from tactics/ *) -(************************************************************************) - -module Tacticals : -sig - open Proof_type - - val tclORELSE : tactic -> tactic -> tactic - val tclDO : int -> tactic -> tactic - val tclIDTAC : tactic - val tclFAIL : int -> Pp.t -> tactic - val tclTHEN : tactic -> tactic -> tactic - val tclTHENLIST : tactic list -> tactic - val pf_constr_of_global : - Globnames.global_reference -> (EConstr.constr -> Proof_type.tactic) -> Proof_type.tactic - val tclMAP : ('a -> tactic) -> 'a list -> tactic - val tclTRY : tactic -> tactic - val tclCOMPLETE : tactic -> tactic - val tclTHENS : tactic -> tactic list -> tactic - val tclFIRST : tactic list -> tactic - val tclTHENFIRST : tactic -> tactic -> tactic - val tclTHENLAST : tactic -> tactic -> tactic - val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic - val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic - val tclSOLVE : tactic list -> tactic - - val onClause : (Names.Id.t option -> tactic) -> Locus.clause -> tactic - val onAllHypsAndConcl : (Names.Id.t option -> tactic) -> tactic - val onLastHypId : (Names.Id.t -> tactic) -> tactic - val onNthHypId : int -> (Names.Id.t -> tactic) -> tactic - val onNLastHypsId : int -> (Names.Id.t list -> tactic) -> tactic - - val tclTHENSEQ : tactic list -> tactic - [@@ocaml.deprecated "alias of API.Tacticals.tclTHENLIST"] - - val nLastDecls : int -> Goal.goal Evd.sigma -> EConstr.named_context - - val tclTHEN_i : tactic -> (int -> tactic) -> tactic - - val tclPROGRESS : tactic -> tactic - - val elimination_sort_of_goal : Goal.goal Evd.sigma -> Sorts.family - - module New : - sig - open Proofview - val tclORELSE0 : unit tactic -> unit tactic -> unit tactic - val tclFAIL : int -> Pp.t -> 'a tactic - val pf_constr_of_global : Globnames.global_reference -> EConstr.constr tactic - val tclTHEN : unit tactic -> unit tactic -> unit tactic - val tclTHENS : unit tactic -> unit tactic list -> unit tactic - val tclFIRST : unit tactic list -> unit tactic - val tclZEROMSG : ?loc:Loc.t -> Pp.t -> 'a tactic - val tclORELSE : unit tactic -> unit tactic -> unit tactic - val tclREPEAT : unit tactic -> unit tactic - val tclTRY : unit tactic -> unit tactic - val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic - val tclPROGRESS : unit Proofview.tactic -> unit Proofview.tactic - val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic - val tclDO : int -> unit tactic -> unit tactic - val tclTIMEOUT : int -> unit tactic -> unit tactic - val tclTIME : string option -> 'a tactic -> 'a tactic - val tclOR : unit tactic -> unit tactic -> unit tactic - val tclONCE : unit tactic -> unit tactic - val tclEXACTLY_ONCE : unit tactic -> unit tactic - val tclIFCATCH : - unit tactic -> - (unit -> unit tactic) -> - (unit -> unit tactic) -> unit tactic - val tclSOLVE : unit tactic list -> unit tactic - val tclCOMPLETE : 'a tactic -> 'a tactic - val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic - val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic - val tclDELAYEDWITHHOLES : bool -> 'a Tactypes.delayed_open -> ('a -> unit tactic) -> unit tactic - val tclTHENLIST : unit tactic list -> unit tactic - val tclTHENLAST : unit tactic -> unit tactic -> unit tactic - val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic - val tclIDTAC : unit tactic - val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic - val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic - end -end - -module Hipattern : -sig - exception NoEquationFound - type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option - type testing_function = Evd.evar_map -> EConstr.constr -> bool - val is_disjunction : ?strict:bool -> ?onlybinary:bool -> testing_function - val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function - val match_with_equality_type : (EConstr.constr * EConstr.constr list) matching_function - val is_empty_type : testing_function - val is_unit_type : testing_function - val is_unit_or_eq_type : testing_function - val is_conjunction : ?strict:bool -> ?onlybinary:bool -> testing_function - val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function - val match_with_imp_term : (EConstr.constr * EConstr.constr) matching_function - val match_with_forall_term : (Names.Name.t * EConstr.constr * EConstr.constr) matching_function - val match_with_nodep_ind : (EConstr.constr * EConstr.constr list * int) matching_function - val match_with_sigma_type : (EConstr.constr * EConstr.constr list) matching_function -end - -module Ind_tables : -sig - type individual - type 'a scheme_kind - - val check_scheme : 'a scheme_kind -> Names.inductive -> bool - val find_scheme : ?mode:Declare.internal_flag -> 'a scheme_kind -> Names.inductive -> Names.Constant.t * Safe_typing.private_constants - val pr_scheme_kind : 'a scheme_kind -> Pp.t -end - -module Elimschemes : -sig - val case_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_type_in_prop : Ind_tables.individual Ind_tables.scheme_kind - val case_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind -end - -module Tactics : -sig - open Proofview - - type change_arg = Ltac_pretype.patvar_map -> Evd.evar_map -> Evd.evar_map * EConstr.constr - type tactic_reduction = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr - - type elim_scheme = - { - elimc: EConstr.constr Misctypes.with_bindings option; - elimt: EConstr.types; - indref: Globnames.global_reference option; - params: EConstr.rel_context; - nparams: int; - predicates: EConstr.rel_context; - npredicates: int; - branches: EConstr.rel_context; - nbranches: int; - args: EConstr.rel_context; - nargs: int; - indarg: EConstr.rel_declaration option; - concl: EConstr.types; - indarg_in_concl: bool; - farg_in_concl: bool; - } - - val unify : ?state:Names.transparent_state -> EConstr.constr -> EConstr.constr -> unit Proofview.tactic - val intro_then : (Names.Id.t -> unit Proofview.tactic) -> unit Proofview.tactic - val reflexivity : unit tactic - val change_concl : EConstr.constr -> unit tactic - val apply : EConstr.constr -> unit tactic - val normalise_vm_in_concl : unit tactic - val assert_before : Names.Name.t -> EConstr.types -> unit tactic - val exact_check : EConstr.constr -> unit tactic - val simplest_elim : EConstr.constr -> unit tactic - val introf : unit tactic - val cut : EConstr.types -> unit tactic - val convert_concl : ?check:bool -> EConstr.types -> Constr.cast_kind -> unit tactic - val intro_using : Names.Id.t -> unit tactic - val intro : unit tactic - val fresh_id_in_env : Names.Id.Set.t -> Names.Id.t -> Environ.env -> Names.Id.t - val is_quantified_hypothesis : Names.Id.t -> 'a Goal.t -> bool - val tclABSTRACT : ?opaque:bool -> Names.Id.t option -> unit Proofview.tactic -> unit Proofview.tactic - val intro_patterns : bool -> Tactypes.intro_patterns -> unit Proofview.tactic - val apply_with_delayed_bindings_gen : - Misctypes.advanced_flag -> Misctypes.evars_flag -> (Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings Loc.located) list -> unit Proofview.tactic - val apply_delayed_in : - Misctypes.advanced_flag -> Misctypes.evars_flag -> Names.Id.t -> - (Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings Loc.located) list -> - Tactypes.intro_pattern option -> unit Proofview.tactic - val elim : - Misctypes.evars_flag -> Misctypes.clear_flag -> EConstr.constr Misctypes.with_bindings -> EConstr.constr Misctypes.with_bindings option -> unit Proofview.tactic - val general_case_analysis : Misctypes.evars_flag -> Misctypes.clear_flag -> EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic - val mutual_fix : - Names.Id.t -> int -> (Names.Id.t * int * EConstr.constr) list -> int -> unit Proofview.tactic - val mutual_cofix : Names.Id.t -> (Names.Id.t * EConstr.constr) list -> int -> unit Proofview.tactic - val forward : bool -> unit Proofview.tactic option option -> - Tactypes.intro_pattern option -> EConstr.constr -> unit Proofview.tactic - val generalize_gen : (EConstr.constr Locus.with_occurrences * Names.Name.t) list -> unit Proofview.tactic - val letin_tac : (bool * Tactypes.intro_pattern_naming) option -> - Names.Name.t -> EConstr.constr -> EConstr.types option -> Locus.clause -> unit Proofview.tactic - val letin_pat_tac : Misctypes.evars_flag -> - (bool * Tactypes.intro_pattern_naming) option -> - Names.Name.t -> - Evd.evar_map * EConstr.constr -> - Locus.clause -> unit Proofview.tactic - val induction_destruct : Misctypes.rec_flag -> Misctypes.evars_flag -> - (Tactypes.delayed_open_constr_with_bindings Misctypes.destruction_arg - * (Tactypes.intro_pattern_naming option * Tactypes.or_and_intro_pattern option) - * Locus.clause option) list * - EConstr.constr Misctypes.with_bindings option -> unit Proofview.tactic - val reduce : Redexpr.red_expr -> Locus.clause -> unit Proofview.tactic - val change : Pattern.constr_pattern option -> change_arg -> Locus.clause -> unit Proofview.tactic - val intros_reflexivity : unit Proofview.tactic - val exact_no_check : EConstr.constr -> unit Proofview.tactic - val assumption : unit Proofview.tactic - val intros_transitivity : EConstr.constr option -> unit Proofview.tactic - val vm_cast_no_check : EConstr.constr -> unit Proofview.tactic - val native_cast_no_check : EConstr.constr -> unit Proofview.tactic - val case_type : EConstr.types -> unit Proofview.tactic - val elim_type : EConstr.types -> unit Proofview.tactic - val cut_and_apply : EConstr.constr -> unit Proofview.tactic - val left_with_bindings : Misctypes.evars_flag -> EConstr.constr Misctypes.bindings -> unit Proofview.tactic - val right_with_bindings : Misctypes.evars_flag -> EConstr.constr Misctypes.bindings -> unit Proofview.tactic - val any_constructor : Misctypes.evars_flag -> unit Proofview.tactic option -> unit Proofview.tactic - val constructor_tac : Misctypes.evars_flag -> int option -> int -> - EConstr.constr Misctypes.bindings -> unit Proofview.tactic - val specialize : EConstr.constr Misctypes.with_bindings -> Tactypes.intro_pattern option -> unit Proofview.tactic - val intros_symmetry : Locus.clause -> unit Proofview.tactic - val split_with_bindings : Misctypes.evars_flag -> EConstr.constr Misctypes.bindings list -> unit Proofview.tactic - val intros_until : Misctypes.quantified_hypothesis -> unit Proofview.tactic - val intro_move : Names.Id.t option -> Names.Id.t Misctypes.move_location -> unit Proofview.tactic - val move_hyp : Names.Id.t -> Names.Id.t Misctypes.move_location -> unit Proofview.tactic - val rename_hyp : (Names.Id.t * Names.Id.t) list -> unit Proofview.tactic - val revert : Names.Id.t list -> unit Proofview.tactic - val simple_induct : Misctypes.quantified_hypothesis -> unit Proofview.tactic - val simple_destruct : Misctypes.quantified_hypothesis -> unit Proofview.tactic - val fix : Names.Id.t option -> int -> unit Proofview.tactic - val cofix : Names.Id.t option -> unit Proofview.tactic - val keep : Names.Id.t list -> unit Proofview.tactic - val clear : Names.Id.t list -> unit Proofview.tactic - val clear_body : Names.Id.t list -> unit Proofview.tactic - val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> EConstr.constr -> unit Proofview.tactic - val force_destruction_arg : Misctypes.evars_flag -> Environ.env -> Evd.evar_map -> - Tactypes.delayed_open_constr_with_bindings Misctypes.destruction_arg -> - Evd.evar_map * EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg - val apply_with_bindings : EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic - val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Names.Id.t -> unit Proofview.tactic - val specialize_eqs : Names.Id.t -> unit Proofview.tactic - val generalize : EConstr.constr list -> unit Proofview.tactic - val simplest_case : EConstr.constr -> unit Proofview.tactic - val introduction : ?check:bool -> Names.Id.t -> unit Proofview.tactic - val convert_concl_no_check : EConstr.types -> Constr.cast_kind -> unit Proofview.tactic - val reduct_in_concl : tactic_reduction * Constr.cast_kind -> unit Proofview.tactic - val reduct_in_hyp : ?check:bool -> tactic_reduction -> Locus.hyp_location -> unit Proofview.tactic - val convert_hyp_no_check : EConstr.named_declaration -> unit Proofview.tactic - val reflexivity_red : bool -> unit Proofview.tactic - val symmetry_red : bool -> unit Proofview.tactic - val eapply : EConstr.constr -> unit Proofview.tactic - val transitivity_red : bool -> EConstr.constr option -> unit Proofview.tactic - val assert_after_replacing : Names.Id.t -> EConstr.types -> unit Proofview.tactic - val intros : unit Proofview.tactic - val setoid_reflexivity : unit Proofview.tactic Hook.t - val setoid_symmetry : unit Proofview.tactic Hook.t - val setoid_symmetry_in : (Names.Id.t -> unit Proofview.tactic) Hook.t - val setoid_transitivity : (EConstr.constr option -> unit Proofview.tactic) Hook.t - val unfold_in_concl : - (Locus.occurrences * Names.evaluable_global_reference) list -> unit Proofview.tactic - val intros_using : Names.Id.t list -> unit Proofview.tactic - val simpl_in_concl : unit Proofview.tactic - val reduct_option : ?check:bool -> tactic_reduction * Constr.cast_kind -> Locus.goal_location -> unit Proofview.tactic - val simplest_split : unit Proofview.tactic - val unfold_in_hyp : - (Locus.occurrences * Names.evaluable_global_reference) list -> Locus.hyp_location -> unit Proofview.tactic - val split : EConstr.constr Misctypes.bindings -> unit Proofview.tactic - val red_in_concl : unit Proofview.tactic - val change_in_concl : (Locus.occurrences * Pattern.constr_pattern) option -> change_arg -> unit Proofview.tactic - val eapply_with_bindings : EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic - val assert_by : Names.Name.t -> EConstr.types -> unit Proofview.tactic -> - unit Proofview.tactic - val intro_avoiding : Names.Id.Set.t -> unit Proofview.tactic - val pose_proof : Names.Name.t -> EConstr.constr -> unit Proofview.tactic - val pattern_option : (Locus.occurrences * EConstr.constr) list -> Locus.goal_location -> unit Proofview.tactic - val compute_elim_sig : Evd.evar_map -> ?elimc:EConstr.constr Misctypes.with_bindings -> EConstr.types -> elim_scheme - val try_intros_until : - (Names.Id.t -> unit Proofview.tactic) -> Misctypes.quantified_hypothesis -> unit Proofview.tactic - val cache_term_by_tactic_then : - opaque:bool -> ?goal_type:(EConstr.constr option) -> Names.Id.t -> - Decl_kinds.goal_kind -> unit Proofview.tactic -> (EConstr.constr -> EConstr.constr list -> unit Proofview.tactic) -> unit Proofview.tactic - val apply_type : EConstr.constr -> EConstr.constr list -> unit Proofview.tactic - val hnf_in_concl : unit Proofview.tactic - val intro_mustbe_force : Names.Id.t -> unit Proofview.tactic - - module New : - sig - val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.constr) -> unit Proofview.tactic - val reduce_after_refine : unit Proofview.tactic - end - module Simple : - sig - val intro : Names.Id.t -> unit Proofview.tactic - val apply : EConstr.constr -> unit Proofview.tactic - val case : EConstr.constr -> unit Proofview.tactic - end -end - -module Elim : -sig - val h_decompose : Names.inductive list -> EConstr.constr -> unit Proofview.tactic - val h_double_induction : Misctypes.quantified_hypothesis -> Misctypes.quantified_hypothesis-> unit Proofview.tactic - val h_decompose_or : EConstr.constr -> unit Proofview.tactic - val h_decompose_and : EConstr.constr -> unit Proofview.tactic -end - -module Equality : -sig - type orientation = bool - type freeze_evars_flag = bool - type dep_proof_flag = bool - type conditions = - | Naive - | FirstSolved - | AllMatches - type inj_flags = { - keep_proof_equalities : bool; (* One may want it or not *) - injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) - injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) - } - - val build_selector : - Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.types -> - EConstr.constr -> EConstr.constr -> EConstr.constr - val replace : EConstr.constr -> EConstr.constr -> unit Proofview.tactic - val general_rewrite : - orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr -> unit Proofview.tactic - val inj : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> - Misctypes.clear_flag -> EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic - val general_multi_rewrite : - Misctypes.evars_flag -> (bool * Misctypes.multi * Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings) list -> - Locus.clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic - val replace_in_clause_maybe_by : EConstr.constr -> EConstr.constr -> Locus.clause -> unit Proofview.tactic option -> unit Proofview.tactic - val replace_term : bool option -> EConstr.constr -> Locus.clause -> unit Proofview.tactic - val dEq : keep_proofs:bool option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val discr_tac : Misctypes.evars_flag -> - EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val injClause : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> - EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - - val simpleInjClause : inj_flags option -> Misctypes.evars_flag -> - EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> - unit Proofview.tactic - val rewriteInConcl : bool -> EConstr.constr -> unit Proofview.tactic - val rewriteInHyp : bool -> EConstr.constr -> Names.Id.t -> unit Proofview.tactic - val cutRewriteInConcl : bool -> EConstr.constr -> unit Proofview.tactic - val cutRewriteInHyp : bool -> EConstr.types -> Names.Id.t -> unit Proofview.tactic - val general_rewrite_ebindings_clause : Names.Id.t option -> - orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr Misctypes.with_bindings -> Misctypes.evars_flag -> unit Proofview.tactic - val subst : Names.Id.t list -> unit Proofview.tactic - - type subst_tactic_flags = { - only_leibniz : bool; - rewrite_dependent_proof : bool - } - val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic - - val general_rewrite_in : - orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(unit Proofview.tactic * conditions) -> Names.Id.t -> EConstr.constr -> Misctypes.evars_flag -> unit Proofview.tactic - - val general_setoid_rewrite_clause : - (Names.Id.t option -> orientation -> Locus.occurrences -> EConstr.constr Misctypes.with_bindings -> - new_goals:EConstr.constr list -> unit Proofview.tactic) Hook.t - - val discrConcl : unit Proofview.tactic - val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr -> unit Proofview.tactic - val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr -> unit Proofview.tactic - val general_rewrite_bindings : - orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr Misctypes.with_bindings -> Misctypes.evars_flag -> unit Proofview.tactic - val discriminable : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val discrHyp : Names.Id.t -> unit Proofview.tactic - val injectable : Environ.env -> Evd.evar_map -> keep_proofs:(bool option) -> EConstr.constr -> EConstr.constr -> bool - val injHyp : inj_flags option -> Misctypes.clear_flag -> Names.Id.t -> unit Proofview.tactic - val subst_gen : bool -> Names.Id.t list -> unit Proofview.tactic -end - -module Contradiction : -sig - val contradiction : EConstr.constr Misctypes.with_bindings option -> unit Proofview.tactic - val absurd : EConstr.constr -> unit Proofview.tactic -end - -module Inv : -sig - val dinv : - Misctypes.inversion_kind -> EConstr.constr option -> - Tactypes.or_and_intro_pattern option -> Misctypes.quantified_hypothesis -> unit Proofview.tactic - val inv_clause : - Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> Names.Id.t list -> - Misctypes.quantified_hypothesis -> unit Proofview.tactic - val inv_clear_tac : Names.Id.t -> unit Proofview.tactic - val inv_tac : Names.Id.t -> unit Proofview.tactic - val dinv_tac : Names.Id.t -> unit Proofview.tactic - val dinv_clear_tac : Names.Id.t -> unit Proofview.tactic - val inv : Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> - Misctypes.quantified_hypothesis -> unit Proofview.tactic -end - -module Leminv : -sig - val lemInv_clause : - Misctypes.quantified_hypothesis -> EConstr.constr -> Names.Id.t list -> unit Proofview.tactic - val add_inversion_lemma_exn : - Names.Id.t -> Constrexpr.constr_expr -> Sorts.family -> bool -> (Names.Id.t -> unit Proofview.tactic) -> - unit -end - -module Hints : -sig - - type raw_hint = EConstr.t * EConstr.types * Univ.ContextSet.t - - type 'a hint_ast = - | Res_pf of 'a (* Hint Apply *) - | ERes_pf of 'a (* Hint EApply *) - | Give_exact of 'a - | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) - | Unfold_nth of Names.evaluable_global_reference (* Hint Unfold *) - | Extern of Genarg.glob_generic_argument (* Hint Extern *) - - type hint - - type debug = - | Debug | Info | Off - - type 'a hints_path_atom_gen = - | PathHints of 'a list - | PathAny - - type hint_term = - | IsGlobRef of Globnames.global_reference - | IsConstr of EConstr.constr * Univ.ContextSet.t - - type hint_db_name = string - type hint_info = (Names.Id.t list * Pattern.constr_pattern) Vernacexpr.hint_info_gen - type hnf = bool - type hints_path_atom = Globnames.global_reference hints_path_atom_gen - - type 'a hints_path_gen = - | PathAtom of 'a hints_path_atom_gen - | PathStar of 'a hints_path_gen - | PathSeq of 'a hints_path_gen * 'a hints_path_gen - | PathOr of 'a hints_path_gen * 'a hints_path_gen - | PathEmpty - | PathEpsilon - - type hints_path = Globnames.global_reference hints_path_gen - - type hints_entry = - | HintsResolveEntry of (hint_info * Decl_kinds.polymorphic * hnf * hints_path_atom * hint_term) list - | HintsImmediateEntry of (hints_path_atom * Decl_kinds.polymorphic * hint_term) list - | HintsCutEntry of hints_path - | HintsUnfoldEntry of Names.evaluable_global_reference list - | HintsTransparencyEntry of Names.evaluable_global_reference list * bool - | HintsModeEntry of Globnames.global_reference * Vernacexpr.hint_mode list - | HintsExternEntry of hint_info * Genarg.glob_generic_argument - - type 'a with_metadata = private { - pri : int; - poly : Decl_kinds.polymorphic; - pat : Pattern.constr_pattern option; - name : hints_path_atom; - db : string option; - secvars : Names.Id.Pred.t; - code : 'a; - } - type full_hint = hint with_metadata - - module Hint_db : - sig - type t - val empty : ?name:hint_db_name -> Names.transparent_state -> bool -> t - val transparent_state : t -> Names.transparent_state - val iter : (Globnames.global_reference option -> - Vernacexpr.hint_mode array list -> full_hint list -> unit) -> t -> unit - end - type hint_db = Hint_db.t - - val add_hints : bool -> hint_db_name list -> hints_entry -> unit - val searchtable_map : hint_db_name -> hint_db - val pp_hints_path_atom : ('a -> Pp.t) -> 'a hints_path_atom_gen -> Pp.t - val pp_hints_path_gen : ('a -> Pp.t) -> 'a hints_path_gen -> Pp.t - val glob_hints_path_atom : - Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen - val pp_hints_path : hints_path -> Pp.t - val glob_hints_path : - Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen - val run_hint : hint -> - ((raw_hint * Clenv.clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic - val typeclasses_db : hint_db_name - val add_hints_init : (unit -> unit) -> unit - val create_hint_db : bool -> hint_db_name -> Names.transparent_state -> bool -> unit - val empty_hint_info : 'a Vernacexpr.hint_info_gen - val repr_hint : hint -> (raw_hint * Clenv.clausenv) hint_ast - val pr_hint_db_env : Environ.env -> Evd.evar_map -> Hint_db.t -> Pp.t - val pr_hint_db : Hint_db.t -> Pp.t - [@@ocaml.deprecated "please used pr_hint_db_env"] -end - -module Auto : -sig - val default_auto : unit Proofview.tactic - val full_trivial : ?debug:Hints.debug -> - Tactypes.delayed_open_constr list -> unit Proofview.tactic - val h_auto : ?debug:Hints.debug -> - int option -> Tactypes.delayed_open_constr list -> Hints.hint_db_name list option -> unit Proofview.tactic - val h_trivial : ?debug:Hints.debug -> - Tactypes.delayed_open_constr list -> Hints.hint_db_name list option -> unit Proofview.tactic - val new_full_auto : ?debug:Hints.debug -> - int -> Tactypes.delayed_open_constr list -> unit Proofview.tactic - val full_auto : ?debug:Hints.debug -> - int -> Tactypes.delayed_open_constr list -> unit Proofview.tactic - val new_auto : ?debug:Hints.debug -> - int -> Tactypes.delayed_open_constr list -> Hints.hint_db_name list -> unit Proofview.tactic - val default_full_auto : unit Proofview.tactic -end - -module Eauto : -sig - val e_assumption : unit Proofview.tactic - val e_give_exact : ?flags:Unification.unify_flags -> EConstr.constr -> unit Proofview.tactic - val prolog_tac : Tactypes.delayed_open_constr list -> int -> unit Proofview.tactic - val make_dimension : int option -> int option -> bool * int - val gen_eauto : ?debug:Hints.debug -> bool * int -> Tactypes.delayed_open_constr list -> - Hints.hint_db_name list option -> unit Proofview.tactic - val autounfold_tac : Hints.hint_db_name list option -> Locus.clause -> unit Proofview.tactic - val autounfold_one : Hints.hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic - val eauto_with_bases : - ?debug:Hints.debug -> bool * int -> Tactypes.delayed_open_constr list -> Hints.hint_db list -> Proof_type.tactic -end - -module Class_tactics : -sig - - type search_strategy = - | Dfs - | Bfs - - val set_typeclasses_debug : bool -> unit - val set_typeclasses_strategy : search_strategy -> unit - val set_typeclasses_depth : int option -> unit - val typeclasses_eauto : ?only_classes:bool -> ?st:Names.transparent_state -> ?strategy:search_strategy -> - depth:(Int.t option) -> - Hints.hint_db_name list -> unit Proofview.tactic - val head_of_constr : Names.Id.t -> EConstr.constr -> unit Proofview.tactic - val not_evar : EConstr.constr -> unit Proofview.tactic - val is_ground : EConstr.constr -> unit Proofview.tactic - val autoapply : EConstr.constr -> Hints.hint_db_name -> unit Proofview.tactic - val catchable : exn -> bool -end - -module Eqdecide : -sig - val compare : EConstr.constr -> EConstr.constr -> unit Proofview.tactic - val decideEqualityGoal : unit Proofview.tactic -end - -module Autorewrite : -sig - type rew_rule = { rew_lemma: Constr.t; - rew_type: Constr.types; - rew_pat: Constr.t; - rew_ctx: Univ.ContextSet.t; - rew_l2r: bool; - rew_tac: Genarg.glob_generic_argument option } - type raw_rew_rule = (Constr.t Univ.in_universe_context_set * bool * - Genarg.raw_generic_argument option) - Loc.located - val auto_multi_rewrite : ?conds:Equality.conditions -> string list -> Locus.clause -> unit Proofview.tactic - val auto_multi_rewrite_with : ?conds:Equality.conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic - val add_rew_rules : string -> raw_rew_rule list -> unit - val find_rewrites : string -> rew_rule list - val find_matches : string -> Constr.t -> rew_rule list - val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t -end - -(************************************************************************) -(* End of modules from tactics/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from vernac/ *) -(************************************************************************) - -module Ppvernac : -sig - val pr_vernac : Vernacexpr.vernac_expr -> Pp.t - val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t -end - -module Lemmas : -sig - - type 'a declaration_hook - - val mk_hook : - (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook - val start_proof : Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Evd.evar_map -> - ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> - unit declaration_hook -> unit - val call_hook : - Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a - val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit - val get_current_context : unit -> Evd.evar_map * Environ.env - [@@ocaml.deprecated "please use [Pfedit.get_current_context]"] -end - -module Himsg : -sig - val explain_refiner_error : Environ.env -> Evd.evar_map -> Logic.refiner_error -> Pp.t - val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.t -end - -module ExplainErr : -sig - val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn - val register_additional_error_info : (Util.iexn -> Pp.t option Loc.located option) -> unit -end - -module Locality : -sig - val make_section_locality : bool option -> bool - val make_module_locality : bool option -> bool -end - -module Metasyntax : -sig - - val add_token_obj : string -> unit - - type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry - val register_grammar : string -> any_entry list -> unit - -end - -module Search : -sig - type glob_search_about_item = - | GlobSearchSubPattern of Pattern.constr_pattern - | GlobSearchString of string - type filter_function = Globnames.global_reference -> Environ.env -> Constr.t -> bool - type display_function = Globnames.global_reference -> Environ.env -> Constr.t -> unit - val search_about_filter : glob_search_about_item -> filter_function - val module_filter : Names.DirPath.t list * bool -> filter_function - val generic_search : int option -> display_function -> unit -end - -module Obligations : -sig - val default_tactic : unit Proofview.tactic ref - val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit - val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit - val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit - val solve_all_obligations : unit Proofview.tactic option -> unit - val admit_obligations : Names.Id.t option -> unit - val show_obligations : ?msg:bool -> Names.Id.t option -> unit - val show_term : Names.Id.t option -> Pp.t -end - -module Command : -sig - open Names - open Constrexpr - open Vernacexpr - - type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : universe_decl_expr option; - fix_annot : Id.t Loc.located option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr - } - - type structured_one_inductive_expr = { - ind_name : Id.t; - ind_univs : universe_decl_expr option; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list - } - - type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - - type recursive_preentry = Names.Id.t list * Constr.t option list * Constr.types list - - type one_inductive_impls - - val do_mutual_inductive : - (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> - Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit - - val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.universe_decl_expr option -> - Constrexpr.local_binder_expr list -> Redexpr.red_expr option -> Constrexpr.constr_expr -> - Constrexpr.constr_expr option -> unit Lemmas.declaration_hook -> unit - - val do_fixpoint : - Decl_kinds.locality -> Decl_kinds.polymorphic -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit - - val extract_fixpoint_components : bool -> - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - structured_fixpoint_expr list * Vernacexpr.decl_notation list - - val interp_fixpoint : - structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - - val extract_mutual_inductive_declaration_components : - (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> - structured_inductive_expr * Libnames.qualid list * Vernacexpr.decl_notation list - - val interp_mutual_inductive : - structured_inductive_expr -> Vernacexpr.decl_notation list -> - Decl_kinds.cumulative_inductive_flag -> - Decl_kinds.polymorphic -> - Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> - Entries.mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list - - val declare_mutual_inductive_with_eliminations : - Entries.mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> - Names.MutInd.t -end - -module Classes : -sig - val set_typeclass_transparency : Names.evaluable_global_reference -> bool -> bool -> unit - val new_instance : - ?abstract:bool -> - ?global:bool -> - ?refine:bool -> - Decl_kinds.polymorphic -> - Constrexpr.local_binder_expr list -> - Vernacexpr.typeclass_constraint -> - (bool * Constrexpr.constr_expr) option -> - ?generalize:bool -> - ?tac:unit Proofview.tactic -> - ?hook:(Globnames.global_reference -> unit) -> - Vernacexpr.hint_info_expr -> - Names.Id.t -end - -module Vernacstate : -sig - - type t = { (* TODO: inline records in OCaml 4.03 *) - system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) - } - - (* XXX: This should not be exported *) - val freeze_interp_state : Summary.marshallable -> t - val unfreeze_interp_state : t -> unit - -end - -module Vernacinterp : -sig - - type deprecation = bool - - type atts = { - loc : Loc.t option; - locality : bool option; - polymorphic : bool; - } - - type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t - - type plugin_args = Genarg.raw_generic_argument list - - val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit - -end - -module Mltop : -sig - val declare_cache_obj : (unit -> unit) -> string -> unit - val add_known_plugin : (unit -> unit) -> string -> unit - val add_known_module : string -> unit - val module_is_known : string -> bool -end - -module Topfmt : -sig - val std_ft : Format.formatter ref - val with_output_to : out_channel -> Format.formatter - val get_margin : unit -> int option -end - -module Vernacentries : -sig - - val dump_global : Libnames.reference Misctypes.or_by_notation -> unit - val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> - Evd.evar_map * Redexpr.red_expr) Hook.t - val command_focus : unit Proof.focus_kind -end - -(************************************************************************) -(* End of modules from vernac/ *) -(************************************************************************) - -(************************************************************************) -(* Modules from stm/ *) -(************************************************************************) - -module Vernac_classifier : -sig - val declare_vernac_classifier : - Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> Vernacexpr.vernac_classification) -> unit - val classify_as_proofstep : Vernacexpr.vernac_classification - val classify_as_query : Vernacexpr.vernac_classification - val classify_as_sideeff : Vernacexpr.vernac_classification - val classify_vernac : Vernacexpr.vernac_expr -> Vernacexpr.vernac_classification -end - -module Stm : -sig - type doc - - val get_doc : Feedback.doc_id -> doc - - val state_of_id : doc:doc -> - Stateid.t -> [ `Valid of Vernacstate.t option | `Expired | `Error of exn ] -end - -(************************************************************************) -(* End of modules from stm/ *) -(************************************************************************) diff --git a/API/API.mllib b/API/API.mllib deleted file mode 100644 index 25275c704..000000000 --- a/API/API.mllib +++ /dev/null @@ -1 +0,0 @@ -API diff --git a/API/PROPERTIES b/API/PROPERTIES deleted file mode 100644 index cd942e202..000000000 --- a/API/PROPERTIES +++ /dev/null @@ -1,8 +0,0 @@ -0 : All API elements, i.e.: - - modules - - module types - - functions & values - - types - are present if and only if are needed for implementing Coq plugins. - -1 : Individual API elements are not aliased. @@ -7,6 +7,29 @@ Notations right (e.g. "( x ; .. ; y ; z )") now supported. - Notations with a specific level for the leftmost nonterminal, when printing-only, are supported. +- When several notations are available for the same expression, + priority is given to latest notations defined in the scopes being + opened rather than to the latest notations defined independently of + whether they are in an opened scope or not. +- Notations can now refer to the syntactic category of patterns (as in + "fun 'pat =>" or "match p with pat => ... end"). Two variants are + available, depending on whether a single variable is considered as a + pattern or not. +- Recursive notations now support ".." patterns with several + occurrences of the recursive term or binder, possibly mixing terms + and binders, possibly in reverse left-to-right order. +- "Locate" now working also on notations of the form "x + y" (rather + than "_ + _"). + +Specification language + +- When printing clauses of a "match", clauses with same right-hand + side are factorized and the last most factorized clause with no + variables, if it exists, is turned into a default clause. + Use "Unset Printing Allow Default Clause" do deactivate printing + of a default clause. + Use "Unset Printing Factorizable Match Patterns" to deactivate + factorization of clauses with same right-hand side. Tactics @@ -20,6 +43,80 @@ Tactics - The tactic "romega" is also aware now of the bodies of context variables. - Tactic "decide equality" now able to manage constructors which contain proofs. +- Added tactics reset ltac profile, show ltac profile (and variants) +- Added tactics restart_timer, finish_timing, and time_constr as an + experimental way of timing Ltac's evaluation phase +- Added tactic optimize_heap, analogous to the Vernacular Optimize + Heap, which performs a major garbage collection and heap compaction + in the OCaml run-time system. +- The tactics "dtauto", "dintuition", "firstorder" now handle inductive types + with let bindings in the parameters. +- The tactic "dtauto" now handles some inductives such as + "@sigT A (fun _ => B)" as non-dependent conjunctions. + +Focusing + +- Focusing bracket `{` now supports single-numbered goal selector, + e.g. `2: {` will focus on the second sub-goal. As usual, unfocus + with `}` once the sub-goal is fully solved. + +Vernacular Commands + +- Proofs ending in "Qed exporting ident, .., ident" are not supported + anymore. Constants generated during `abstract` are kept private to the + local environment. +- The deprecated Coercion Local, Open Local Scope, Notation Local syntax + was removed. Use Local as a prefix instead. +- For the Extraction Language command, "OCaml" is spelled correctly. + The older "Ocaml" is still accepted, but deprecated. + +Universes + +- Qualified naming of global universes now works like other namespaced + objects (e.g. constants), with a separate namespace, inside and across + module and library boundaries. Global universe names introduced in an + inductive / constant / Let declaration get qualified with the name of + the declaration. +- Universe cumulativity for inductive types is now specified as a + variance for each polymorphic universe. See the reference manual for + more information. +- Fix #5726: Notations that start with `Type` now support universe instances + with `@{u}`. + +Checker + +- The checker now accepts filenames in addition to logical paths. + +CoqIDE + +- Find and Replace All report the number of occurrences found; Find indicates + when it wraps. + +Documentation + +- The Coq FAQ, formerly located at https://coq.inria.fr/faq, has been + moved to the GitHub wiki section of this repository; the main entry + page is https://github.com/coq/coq/wiki/The-Coq-FAQ. + +Changes from 8.7.1 to 8.7.2 +=========================== + +Fixed a critical bug in the VM handling of universes (#6677). This bug +affected all releases since 8.5. + +Improved support for building with OCaml 4.06.0 and external num package. + +Many other bug fixes, documentation improvements, and user +message improvements (for details, see the 8.7.2 milestone at +https://github.com/coq/coq/milestone/11?closed=1). + +Changes from 8.7.0 to 8.7.1 +=========================== + +Compatibility with OCaml 4.06.0. + +Many bug fixes, documentation improvements, and user message improvements (for +details see the 8.7.1 milestone at https://github.com/coq/coq/milestone/10?closed=1). Changes from 8.7+beta2 to 8.7.0 =============================== @@ -247,7 +344,7 @@ Changes from 8.6 to 8.6.1 - Fix bug 5550: "typeclasses eauto with" does not work with section variables. - Bug 5546, qualify datatype constructors when needed in Show Match - Bug #5535, test for Show with -emacs -- Fix bug #5486, don't reverse ids in tuples +- Fix bug #5486, don't reverse ids in tuples - Fixing #5522 (anomaly with free vars of pat) - Fix bug #5526, don't check for nonlinearity in notation if printing only - Fix bug #5255 @@ -269,7 +366,7 @@ Changes from 8.6 to 8.6.1 - show unused intro pattern warning - [future] Be eager when "chaining" already resolved future values. - Opaque side effects -- Fix #5132: coq_makefile generates incorrect install goal +- Fix #5132: coq_makefile generates incorrect install goal - Run non-tactic comands without resilient_command - Univs: fix bug #5365, generation of u+k <= v constraints - make `emit' tail recursive diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index b4e6a1418..74a138f14 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -28,8 +28,12 @@ Please make pull requests against the `master` branch. It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to [`dev/ci/README.md`](/dev/ci/README.md#information-for-developers) for more information on Travis CI tests. +If your pull request fixes a bug, please consider adding a regression test as well. See [`test-suite/README.md`](/test-suite/README.md) for how to do so. + Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by Travis (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. + Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. - [needs: rebase](https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22%20) indicates the PR should be rebased on top of the latest `master` branch. See the [GitHub documentation](https://help.github.com/articles/about-git-rebase/) for a brief introduction to using `git rebase`. @@ -48,6 +52,8 @@ Our issue tracker includes a flag to mark bugs related to documentation. You can The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) are at [`doc/refman`](/doc/refman). These are written in LaTeX and compiled to HTML with [HeVeA](http://hevea.inria.fr/). +You may also contribute to the informal documentation available in [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are editable by anyone with a GitHub account. + ## Contributing outside this repository There are many useful ways to contribute to the Coq ecosystem that don't involve the Coq repository. @@ -43,7 +43,7 @@ WHAT DO YOU NEED ? - a C compiler - for Coqide, the Lablgtk development files, and the GTK libraries - incuding gtksourceview, see INSTALL.ide for more details + including gtksourceview, see INSTALL.ide for more details Opam (https://opam.ocaml.org/) is recommended to install ocaml and the corresponding packages. diff --git a/INSTALL.ide b/INSTALL.ide index 513e37c91..26c192baa 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS install GTK+ 2.x, should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. - You need at least version 2.16. + You need at least version 2.18.3. Your distribution may contain precompiled packages. For example, for Debian, run @@ -57,7 +57,7 @@ COMPILATION REQUIREMENTS ./configure && make world && make install You must have write access to the OCaml standard library path. - If this fails, read lablgtk-2.14.2/README. + If this fails, read the README. INSTALLATION @@ -23,20 +23,28 @@ package "config" ( ) +package "clib" ( + description = "Base General Coq Library" + version = "8.7" + + directory = "clib" + requires = "str, unix, threads" + + archive(byte) = "clib.cma" + archive(native) = "clib.cmxa" +) + package "lib" ( - description = "Base Coq Library" + description = "Base Coq-Specific Library" version = "8.7" directory = "lib" - requires = "coq.config" + requires = "coq.clib, coq.config" - archive(byte) = "clib.cma" - archive(byte) += "lib.cma" - - archive(native) = "clib.cmxa" - archive(native) += "lib.cmxa" + archive(byte) = "lib.cma" + archive(native) = "lib.cmxa" ) @@ -47,13 +55,17 @@ package "vm" ( directory = "kernel/byterun" -# We should generate this file at configure time for local byte builds -# to work properly. - -# Enable this setting for local byte builds, disabling the one below. +# We could generate this file at configure time for the share byte +# build path to work properly. +# +# Enable this setting for local byte builds if you want dynamic linking: +# # linkopts(byte) = "-dllpath path_to_coq/kernel/byterun/ -dllib -lcoqrun" - linkopts(byte) = "-dllib -lcoqrun" +# We currently prefer static linking of the VM. + archive(byte) = "libcoqrun.a" + linkopts(byte) = "-custom" + linkopts(native) = "-cclib -lcoqrun" ) @@ -65,7 +77,7 @@ package "kernel" ( directory = "kernel" - requires = "coq.lib, coq.vm" + requires = "dynlink, coq.lib, coq.vm" archive(byte) = "kernel.cma" archive(native) = "kernel.cmxa" @@ -168,7 +180,7 @@ package "parsing" ( description = "Coq Parsing Engine" version = "8.7" - requires = "coq.proofs" + requires = "camlp5.gramlib, coq.proofs" directory = "parsing" archive(byte) = "parsing.cma" @@ -228,32 +240,6 @@ package "stm" ( ) -package "API" ( - - description = "Coq API" - version = "8.7" - - requires = "coq.stm" - directory = "API" - - archive(byte) = "API.cma" - archive(native) = "API.cmxa" - -) - -package "ltac" ( - - description = "Coq LTAC Plugin" - version = "8.7" - - requires = "coq.API" - directory = "plugins/ltac" - - archive(byte) = "ltac_plugin.cmo" - archive(native) = "ltac_plugin.cmx" - -) - package "toplevel" ( description = "Coq Toplevel" @@ -294,3 +280,300 @@ package "ide" ( archive(native) = "ide.cmxa" ) + +package "plugins" ( + + description = "Coq built-in plugins" + version = "8.7" + + directory = "plugins" + + package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.7" + + requires = "coq.stm" + directory = "ltac" + + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" + + ) + + package "tauto" ( + + description = "Coq tauto plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "ltac" + + archive(byte) = "tauto_plugin.cmo" + archive(native) = "tauto_plugin.cmx" + ) + + package "omega" ( + + description = "Coq omega plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "omega" + + archive(byte) = "omega_plugin.cmo" + archive(native) = "omega_plugin.cmx" + ) + + package "romega" ( + + description = "Coq romega plugin" + version = "8.7" + + requires = "coq.plugins.omega" + directory = "romega" + + archive(byte) = "romega_plugin.cmo" + archive(native) = "romega_plugin.cmx" + ) + + package "micromega" ( + + description = "Coq micromega plugin" + version = "8.7" + + requires = "num,coq.plugins.ltac" + directory = "micromega" + + archive(byte) = "micromega_plugin.cmo" + archive(native) = "micromega_plugin.cmx" + ) + + package "quote" ( + + description = "Coq quote plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "quote" + + archive(byte) = "quote_plugin.cmo" + archive(native) = "quote_plugin.cmx" + ) + + package "newring" ( + + description = "Coq newring plugin" + version = "8.7" + + requires = "coq.plugins.quote" + directory = "setoid_ring" + + archive(byte) = "newring_plugin.cmo" + archive(native) = "newring_plugin.cmx" + ) + + package "fourier" ( + + description = "Coq fourier plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "fourier" + + archive(byte) = "fourier_plugin.cmo" + archive(native) = "fourier_plugin.cmx" + ) + + package "extraction" ( + + description = "Coq extraction plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "extraction" + + archive(byte) = "extraction_plugin.cmo" + archive(native) = "extraction_plugin.cmx" + ) + + package "cc" ( + + description = "Coq cc plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "cc" + + archive(byte) = "cc_plugin.cmo" + archive(native) = "cc_plugin.cmx" + ) + + package "ground" ( + + description = "Coq ground plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "firstorder" + + archive(byte) = "ground_plugin.cmo" + archive(native) = "ground_plugin.cmx" + ) + + package "rtauto" ( + + description = "Coq rtauto plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "rtauto" + + archive(byte) = "rtauto_plugin.cmo" + archive(native) = "rtauto_plugin.cmx" + ) + + package "btauto" ( + + description = "Coq btauto plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "btauto" + + archive(byte) = "btauto_plugin.cmo" + archive(native) = "btauto_plugin.cmx" + ) + + package "recdef" ( + + description = "Coq recdef plugin" + version = "8.7" + + requires = "coq.plugins.extraction" + directory = "funind" + + archive(byte) = "recdef_plugin.cmo" + archive(native) = "recdef_plugin.cmx" + ) + + package "nsatz" ( + + description = "Coq nsatz plugin" + version = "8.7" + + requires = "num,coq.plugins.ltac" + directory = "nsatz" + + archive(byte) = "nsatz_plugin.cmo" + archive(native) = "nsatz_plugin.cmx" + ) + + package "natsyntax" ( + + description = "Coq natsyntax plugin" + version = "8.7" + + requires = "" + directory = "syntax" + + archive(byte) = "nat_syntax_plugin.cmo" + archive(native) = "nat_syntax_plugin.cmx" + ) + + package "zsyntax" ( + + description = "Coq zsyntax plugin" + version = "8.7" + + requires = "" + directory = "syntax" + + archive(byte) = "z_syntax_plugin.cmo" + archive(native) = "z_syntax_plugin.cmx" + ) + + package "rsyntax" ( + + description = "Coq rsyntax plugin" + version = "8.7" + + requires = "" + directory = "syntax" + + archive(byte) = "r_syntax_plugin.cmo" + archive(native) = "r_syntax_plugin.cmx" + ) + + package "int31syntax" ( + + description = "Coq int31syntax plugin" + version = "8.7" + + requires = "" + directory = "syntax" + + archive(byte) = "int31_syntax_plugin.cmo" + archive(native) = "int31_syntax_plugin.cmx" + ) + + package "asciisyntax" ( + + description = "Coq asciisyntax plugin" + version = "8.7" + + requires = "" + directory = "syntax" + + archive(byte) = "ascii_syntax_plugin.cmo" + archive(native) = "ascii_syntax_plugin.cmx" + ) + + package "stringsyntax" ( + + description = "Coq stringsyntax plugin" + version = "8.7" + + requires = "coq.plugins.asciisyntax" + directory = "syntax" + + archive(byte) = "string_syntax_plugin.cmo" + archive(native) = "string_syntax_plugin.cmx" + ) + + package "derive" ( + + description = "Coq derive plugin" + version = "8.7" + + requires = "" + directory = "derive" + + archive(byte) = "derive_plugin.cmo" + archive(native) = "derive_plugin.cmx" + ) + + package "ssrmatching" ( + + description = "Coq ssrmatching plugin" + version = "8.7" + + requires = "coq.plugins.ltac" + directory = "ssrmatching" + + archive(byte) = "ssrmatching_plugin.cmo" + archive(native) = "ssrmatching_plugin.cmx" + ) + + package "ssreflect" ( + + description = "Coq ssreflect plugin" + version = "8.7" + + requires = "coq.plugins.ssrmatching" + directory = "ssr" + + archive(byte) = "ssreflect_plugin.cmo" + archive(native) = "ssreflect_plugin.cmx" + ) +) @@ -87,7 +87,7 @@ EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated GENML4FILES:= $(ML4FILES:.ml4=.ml) -export GENMLFILES:=$(LEXFILES:.mll=.ml) tools/tolink.ml kernel/copcodes.ml +export GENMLFILES:=$(LEXFILES:.mll=.ml) kernel/copcodes.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) @@ -139,19 +139,10 @@ endif # This should help preventing weird compilation failures caused by leftover # compiled files after deleting or moving some source files. -ifeq (,$(findstring clean,$(MAKECMDGOALS))) # Skip this for 'make clean' and alii -ifndef ACCEPT_ALIEN_VO EXISTINGVO:=$(call find, '*.vo') KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) -ifdef ALIENVO -$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ -remove them first, for instance via 'make voclean' \ -(or skip this check via 'make ACCEPT_ALIEN_VO=1')) -endif -endif -ifndef ACCEPT_ALIEN_OBJ EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) @@ -159,9 +150,20 @@ KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ $(MLIFILES:.mli=.cmi) \ $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) + +ifeq (,$(findstring clean,$(MAKECMDGOALS))) # Skip this for 'make clean' and alii +ifndef ACCEPT_ALIEN_VO +ifdef ALIENVO +$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ +remove them first, for instance via 'make voclean' or 'make alienclean' \ +(or skip this check via 'make ACCEPT_ALIEN_VO=1')) +endif +endif + +ifndef ACCEPT_ALIEN_OBJ ifdef ALIENOBJS $(error Leftover compiled OCaml files without known sources: $(ALIENOBJS); \ -remove them first, for instance via 'make clean' \ +remove them first, for instance via 'make clean' or 'make alienclean' \ (or skip this check via 'make ACCEPT_ALIEN_OBJ=1')) endif endif @@ -196,7 +198,7 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean alienclean clean: objclean cruftclean depclean docclean devdocclean @@ -231,8 +233,7 @@ docclean: doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t - rm -f doc/faq/axioms.png - rm -rf doc/refman/html doc/stdlib/html doc/faq/html doc/tutorial/tutorial.v.html + rm -rf doc/refman/html doc/stdlib/html doc/tutorial/tutorial.v.html rm -f doc/refman/euclid.ml doc/refman/euclid.mli rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli rm -f doc/common/version.tex @@ -244,7 +245,7 @@ archclean: clean-ide optclean voclean rm -f $(ALLSTDLIB).* optclean: - rm -f $(COQTOPEXE) $(COQMKTOP) $(CHICKEN) + rm -f $(COQTOPEXE) $(CHICKEN) rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) find . -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f @@ -265,7 +266,7 @@ cacheclean: find theories plugins test-suite -name '.*.aux' -delete cleanconfig: - rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp4.dbg config/Info-*.plist + rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp5.dbg config/Info-*.plist distclean: clean cleanconfig cacheclean timingclean @@ -282,6 +283,9 @@ devdocclean: rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html +alienclean: + rm -f $(ALIENOBJS) $(ALIENVO) + ########################################################################### # Continuous Intregration Tests ########################################################################### diff --git a/Makefile.build b/Makefile.build index 39b793d2b..39d177a13 100644 --- a/Makefile.build +++ b/Makefile.build @@ -147,8 +147,14 @@ endif # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). +VDFILE := .vfiles +MLDFILE := .mlfiles +PLUGMLDFILE := plugins/.mlfiles +MLLIBDFILE := .mllibfiles +PLUGMLLIBDFILE := plugins/.mllibfiles + DEPENDENCIES := \ - $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(MLPACKFILES) $(CFILES) $(VFILES)) + $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) $(CFILES) $(VDFILE)) -include $(DEPENDENCIES) @@ -189,15 +195,15 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) COQOPTS=$(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile -LOCALINCLUDES=$(if $(filter plugins/%,$<),-I lib -I API -open API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) -MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) +LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) +MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP5LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$<),, -I ide -I ide/utils) +DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$@),, -I ide -I ide/utils) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -228,20 +234,19 @@ endef define bestocaml $(if $(OPT),\ -$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ -$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^) +$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ -linkpkg $(1) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ +$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^) endef # Camlp5 settings -CAMLP4DEPS:=grammar/grammar.cma -CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) +CAMLP5DEPS:=grammar/grammar.cma +CAMLP5USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) -SYSMOD:=str unix dynlink threads -SYSCMA:=$(addsuffix .cma,$(SYSMOD)) -SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) +# Main packages linked by Coq. +SYSMOD:=-package num,str,unix,dynlink,threads # We do not repeat the dependencies already in SYSMOD here P4CMA:=gramlib.cma @@ -302,7 +307,7 @@ kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h -e '/^}/q' $< $(TOTARGET) kernel/copcodes.ml: kernel/byterun/coq_instruct.h - sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ + tr -d "\r" < $< | sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' | \ awk -f kernel/make-opcodes $(TOTARGET) %.o: %.c @@ -340,14 +345,14 @@ grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \ ## Ocaml compiler with the right options and -I for grammar GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ - -I $(MYCAMLP4LIB) -I grammar + -I $(MYCAMLP5LIB) -I grammar ## Specific rules for grammar.cma grammar/grammar.cma : $(GRAMCMO) $(SHOW)'Testing $@' @touch grammar/test.mlp - $(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test + $(HIDE)$(GRAMC) -pp '$(CAMLP5O) -I $(MYCAMLP5LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test @rm -f grammar/test.* grammar/test $(SHOW)'OCAMLC -a $@' $(HIDE)$(GRAMC) $^ -linkall -a -o $@ @@ -356,7 +361,7 @@ grammar/grammar.cma : $(GRAMCMO) COMPATCMO:= GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) -GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl +GRAMPP:=$(CAMLP5O) -I $(MYCAMLP5LIB) $(GRAMP4USE) $(CAMLP5COMPAT) -impl ## Rules for standard .mlp and .mli files in grammar/ @@ -370,19 +375,30 @@ grammar/%.cmi: grammar/%.mli ########################################################################### -# Main targets (coqmktop, coqtop.opt, coqtop.byte) +# Main targets (coqtop.opt, coqtop.byte) ########################################################################### .PHONY: coqbinaries coqbyte -coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) +coqbinaries: $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) coqbyte: $(COQTOPBYTE) $(CHICKENBYTE) +COQTOP_OPT_MLTOP=toplevel/coqtop_opt_bin.cmx +COQTOP_BYTE_MLTOP=toplevel/coqtop_byte_bin.cmo + +$(COQTOP_BYTE_MLTOP): toplevel/coqtop_byte_bin.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -package compiler-libs.toplevel -c $< + ifeq ($(BEST),opt) -$(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) +$(COQTOPEXE): $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) $(COQTOP_OPT_MLTOP) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@ + $(HIDE)$(OCAMLOPT) -linkall -linkpkg -I toplevel \ + -I kernel/byterun/ -cclib -lcoqrun \ + $(SYSMOD) -package camlp5.gramlib \ + $(LINKCMX) $(OPTFLAGS) $(LINKMETADATA) \ + $(COQTOP_OPT_MLTOP) toplevel/coqtop_bin.ml -o $@ $(STRIP) $@ $(CODESIGN) $@ else @@ -390,31 +406,21 @@ $(COQTOPEXE): $(COQTOPBYTE) cp $< $@ endif -$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) +# VMBYTEFLAGS will either contain -custom of the right -dllpath for the VM +$(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(COQTOP_BYTE_MLTOP) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ - -# coqmktop - -COQMKTOPCMO:=lib/clib.cma lib/cErrors.cmo tools/tolink.cmo tools/coqmktop.cmo - -$(COQMKTOP): $(call bestobj, $(COQMKTOPCMO)) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) + $(HIDE)$(OCAMLC) -linkall -linkpkg -I toplevel \ + -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ + $(SYSMOD) -package camlp5.gramlib,compiler-libs.toplevel \ + $(LINKCMO) $(BYTEFLAGS) \ + $(COQTOP_BYTE_MLTOP) toplevel/coqtop_bin.ml -o $@ -tools/tolink.ml: Makefile.build Makefile.common - $(SHOW)"ECHO... >" $@ - $(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@ - $(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@ - $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ - -# coqc - -COQCCMO:=lib/clib.cma lib/cErrors.cmo toplevel/usage.cmo tools/coqc.cmo +# For coqc +COQCCMO:=clib/clib.cma lib/lib.cma toplevel/usage.cmo tools/coqc.cmo $(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) + $(HIDE)$(call bestocaml, $(SYSMOD)) ########################################################################### # other tools @@ -431,100 +437,99 @@ tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # Remember to update the dependencies below when you add files! COQDEPBOOTSRC := \ - lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo lib/minisys.cmo \ + clib/segmenttree.cmo clib/unicodetable.cmo clib/unicode.cmo clib/minisys.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo -lib/segmenttree.cmo : lib/segmenttree.cmi -lib/segmenttree.cmx : lib/segmenttree.cmi -lib/unicodetable.cmo : lib/segmenttree.cmo -lib/unicodetable.cmx : lib/segmenttree.cmx -lib/unicode.cmo : lib/unicodetable.cmo lib/unicode.cmi -lib/unicode.cmx : lib/unicodetable.cmx lib/unicode.cmi -lib/minisys.cmo : lib/unicode.cmo -lib/minisys.cmx : lib/unicode.cmx -tools/coqdep_lexer.cmo : lib/unicode.cmi tools/coqdep_lexer.cmi -tools/coqdep_lexer.cmx : lib/unicode.cmx tools/coqdep_lexer.cmi -tools/coqdep_common.cmo : lib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi -tools/coqdep_common.cmx : lib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi +clib/segmenttree.cmo : clib/segmenttree.cmi +clib/segmenttree.cmx : clib/segmenttree.cmi +clib/unicodetable.cmo : clib/segmenttree.cmo +clib/unicodetable.cmx : clib/segmenttree.cmx +clib/unicode.cmo : clib/unicodetable.cmo clib/unicode.cmi +clib/unicode.cmx : clib/unicodetable.cmx clib/unicode.cmi +clib/minisys.cmo : clib/unicode.cmo +clib/minisys.cmx : clib/unicode.cmx +tools/coqdep_lexer.cmo : clib/unicode.cmi tools/coqdep_lexer.cmi +tools/coqdep_lexer.cmx : clib/unicode.cmx tools/coqdep_lexer.cmi +tools/coqdep_common.cmo : clib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi +tools/coqdep_common.cmx : clib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi tools/coqdep_boot.cmo : tools/coqdep_common.cmi tools/coqdep_boot.cmx : tools/coqdep_common.cmx $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I tools, unix) + $(HIDE)$(call bestocaml, -I tools -package unix) $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I tools, unix) + $(HIDE)$(call bestocaml, -I tools -package unix) # The full coqdep (unused by this build, but distributed by make install) -COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo \ - lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo lib/minisys.cmo \ - lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ - tools/coqdep.cmo +COQDEPCMO:=clib/clib.cma lib/lib.cma tools/coqdep_lexer.cmo \ + tools/coqdep_common.cmo tools/coqdep.cmo $(COQDEP): $(call bestobj, $(COQDEPCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) + $(HIDE)$(call bestocaml, $(SYSMOD)) $(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,) + $(HIDE)$(call bestocaml,) -COQMAKEFILECMO:=lib/clib.cma tools/coq_makefile.cmo +COQMAKEFILECMO:=clib/clib.cma lib/lib.cma tools/coq_makefile.cmo $(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str unix threads) + $(HIDE)$(call bestocaml, -package str,unix,threads) $(COQTEX): $(call bestobj, tools/coq_tex.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str) + $(HIDE)$(call bestocaml, -package str) $(COQWC): $(call bestobj, tools/coqwc.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,) + $(HIDE)$(call bestocaml, -package str) -COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ +COQDOCCMO:=clib/clib.cma lib/lib.cma $(addprefix tools/coqdoc/, \ cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) $(COQDOC): $(call bestobj, $(COQDOCCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str unix) + $(HIDE)$(call bestocaml, -package str,unix) -$(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) +$(COQWORKMGR): $(call bestobj, clib/clib.cma lib/lib.cma stm/spawned.cmo stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,, $(SYSMOD)) + $(HIDE)$(call bestocaml, $(SYSMOD)) # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ - ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ - ide/richpp.cmo ide/xmlprotocol.cmo tools/fake_ide.cmo +FAKEIDECMO:=clib/clib.cma lib/lib.cma ide/document.cmo \ + ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo \ + ide/xml_printer.cmo ide/richpp.cmo ide/xmlprotocol.cmo \ + tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,-I ide,str unix threads) + $(HIDE)$(call bestocaml, -I ide -package str,unix,threads) # votour: a small vo explorer (based on the checker) -bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo) +bin/votour: $(call bestobj, clib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I checker,) + $(HIDE)$(call bestocaml, -I checker) ########################################################################### # Csdp to micromega special targets ########################################################################### -CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \ +CSDPCERTCMO:=clib/clib.cma $(addprefix plugins/micromega/, \ mutils.cmo micromega.cmo \ sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix) + $(HIDE)$(call bestocaml, -package num,unix) ########################################################################### # tests @@ -570,12 +575,6 @@ kernel/kernel.cma: kernel/kernel.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(VMBYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) -# Specific rule for API/API.cmi -# Make sure that API/API.mli cannot leak types from the Coq codebase. -API/API.cmi : API/API.mli - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) -I lib -I $(MYCAMLP4LIB) -c $< - %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) @@ -594,16 +593,35 @@ API/API.cmi : API/API.mli $(SHOW)'OCAMLOPT -pack -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) +COND_IDEFLAGS=$(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) +COND_PRINTERFLAGS=$(if $(filter dev/%,$<), -I dev,) + COND_BYTEFLAGS= \ - $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(BYTEFLAGS) + $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) COND_OPTFLAGS= \ - $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(OPTFLAGS) + $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) + +plugins/micromega/%.cmi: plugins/micromega/%.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< + +plugins/nsatz/%.cmi: plugins/nsatz/%.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< +plugins/micromega/%.cmo: plugins/micromega/%.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< + +plugins/nsatz/%.cmo: plugins/nsatz/%.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< + %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -637,6 +655,14 @@ plugins/micromega/sos_FORPACK:= plugins/micromega/sos_print_FORPACK:= plugins/micromega/csdpcert_FORPACK:= +plugins/micromega/%.cmx: plugins/micromega/%.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< + +plugins/nsatz/%.cmx: plugins/nsatz/%.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< + plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< @@ -657,10 +683,10 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLLEX $<' $(HIDE)$(OCAMLLEX) -o $@ "$*.mll" -%.ml: %.ml4 $(CAMLP4DEPS) +%.ml: %.ml4 $(CAMLP5DEPS) $(SHOW)'CAMLP5O $<' - $(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) \ - $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ + $(HIDE)$(CAMLP5O) -I $(MYCAMLP5LIB) $(PR_O) \ + $(CAMLP5DEPS) $(CAMLP5USE) $(CAMLP5COMPAT) -impl $< -o $@ ########################################################################### @@ -670,21 +696,24 @@ plugins/%.cmx: plugins/%.ml # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack -%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) +MAINMLFILES := $(filter-out checker/% plugins/%, $(MLFILES) $(MLIFILES)) +MAINMLLIBFILES := $(filter-out checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) + +$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP MLFILES MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(MAINMLFILES) $(TOTARGET) -%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(MLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLLIBFILES) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP MLLIBFILES MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(MAINMLLIBFILES) $(TOTARGET) -%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(PLUGMLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLFILES) $(MLIFILES)) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP plugins/MLFILES plugins/MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(filter plugins/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) -%.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP plugins/MLLIBFILES plugins/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) ########################################################################### # Compilation of .v files @@ -717,26 +746,6 @@ theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) -# MExtraction.v generates the ml core file of the micromega tactic. -# We check that this generated code is still in sync with the version -# of micromega.ml in the archive. - -# Note: we now dump to stdout there via "Recursive Extraction" for better -# control on the name of the generated file, and avoid a .ml that -# would end in our $(MLFILES). The "sed" below is to kill the final -# blank line printed by Recursive Extraction (unlike Extraction "foo"). - -MICROMEGAV:=plugins/micromega/MExtraction.v -MICROMEGAML:=plugins/micromega/micromega.ml -MICROMEGAGEN:=plugins/micromega/.micromega.ml.generated - -$(MICROMEGAV:.v=.vo) $(MICROMEGAV:.v=.glob) : $(MICROMEGAV) theories/Init/Prelude.vo $(VO_TOOLS_DEP) - $(SHOW)'COQC $<' - $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $< | sed -e '$$d' > $(MICROMEGAGEN) - $(HIDE)diff -u --strip-trailing-cr $(MICROMEGAML) $(MICROMEGAGEN) || \ - (2>&1 echo "Error: $(MICROMEGAML) and the code generated by $(MICROMEGAV) differ !" && false) - # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) @@ -756,9 +765,9 @@ endif # Dependencies of .v files -%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) "$<" $(TOTARGET) +$(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.checker b/Makefile.checker index 435d8e8f6..0e429fe86 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -20,16 +20,22 @@ CHICKEN:=bin/coqchk$(EXE) # The sources -CHKLIBS:= -I config -I lib -I checker +CHKLIBS:= -I config -I clib -I lib -I checker ## NB: currently, both $(OPTFLAGS) and $(BYTEFLAGS) contain -thread # The rules +CHECKMLDFILE := checker/.mlfiles +CHECKMLLIBFILE := checker/.mllibfiles + +CHECKERDEPS := $(addsuffix .d, $(CHECKMLDFILE) $(CHECKMLLIBFILE)) +-include $(CHECKERDEPS) + ifeq ($(BEST),opt) -$(CHICKEN): checker/check.cmxa checker/main.ml +$(CHICKEN): checker/check.cmxa checker/main.mli checker/main.ml $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(SYSCMXA) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -o $@ $^ + $(HIDE)$(OCAMLOPT) -linkpkg $(SYSMOD) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -o $@ $^ $(STRIP) $@ $(CODESIGN) $@ else @@ -37,9 +43,9 @@ $(CHICKEN): $(CHICKENBYTE) cp $< $@ endif -$(CHICKENBYTE): checker/check.cma checker/main.ml +$(CHICKENBYTE): checker/check.cma checker/main.mli checker/main.ml $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(SYSCMA) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -o $@ $^ + $(HIDE)$(OCAMLC) -linkpkg $(SYSMOD) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -o $@ $^ checker/check.cma: checker/check.mllib | md5chk $(SHOW)'OCAMLC -a -o $@' @@ -49,17 +55,13 @@ checker/check.cmxa: checker/check.mllib | md5chk $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -checker/%.ml.d: checker/%.ml - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) - -checker/%.mli.d: checker/%.mli - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) +$(CHECKMLDFILE).d: $(filter checker/%, $(MLFILES) $(MLIFILES)) + $(SHOW)'OCAMLDEP checker/MLFILES checker/MLIFILES' + $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) $(filter checker/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) -checker/%.mllib.d: checker/%.mllib | $(OCAMLLIBDEP) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) "$<" $(TOTARGET) +$(CHECKMLLIBFILE).d: $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) | $(OCAMLLIBDEP) + $(SHOW)'OCAMLLIBDEP checker/MLLIBFILES checker/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) checker/%.cmi: checker/%.mli $(SHOW)'OCAMLC $<' @@ -75,8 +77,8 @@ checker/%.cmx: checker/%.ml md5chk: $(SHOW)'MD5SUM cic.mli' - $(HIDE)if grep -q `$(MD5SUM) checker/cic.mli` checker/values.ml; \ - then true; else echo "Error: outdated checker/values.ml"; false; fi + $(HIDE)if grep -q "^MD5 $$($(OCAML) tools/md5sum.ml checker/cic.mli)$$" checker/values.ml; \ + then true; else echo "Error: outdated checker/values.ml" >&2; false; fi .PHONY: md5chk diff --git a/Makefile.ci b/Makefile.ci index a17d4ddf7..4e92264d6 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,10 +1,11 @@ -CI_TARGETS=ci-all \ - ci-bignums \ +CI_TARGETS=ci-bignums \ ci-color \ ci-compcert \ ci-coq-dpdgraph \ ci-coquelicot \ + ci-corn \ ci-cpdt \ + ci-elpi \ ci-equations \ ci-fiat-crypto \ ci-fiat-parsers \ @@ -22,8 +23,23 @@ CI_TARGETS=ci-all \ ci-unimath \ ci-vst -.PHONY: $(CI_TARGETS) +.PHONY: ci-all $(CI_TARGETS) + +ci-color: ci-bignums + +ci-math-classes: ci-bignums + +ci-corn: ci-math-classes + +ci-formal-topology: ci-corn # Generic rule, we use make to ease travis integration with mixed rules $(CI_TARGETS): ci-%: - +./dev/ci/ci-wrapper.sh ci-$*.sh + +./dev/ci/ci-wrapper.sh $* + +ci-all: $(CI_TARGETS) + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/Makefile.common b/Makefile.common index 4d63b08e2..d3a9b0b96 100644 --- a/Makefile.common +++ b/Makefile.common @@ -12,8 +12,6 @@ # Executables ########################################################################### -COQMKTOP:=bin/coqmktop$(EXE) - COQTOPBYTE:=bin/coqtop.byte$(EXE) COQTOPEXE:=bin/coqtop$(EXE) @@ -75,9 +73,9 @@ INSTALLSH:=./install.sh MKDIR:=install -d CORESRCDIRS:=\ - config lib kernel intf kernel/byterun library \ + config clib lib kernel intf kernel/byterun library \ engine pretyping interp proofs parsing printing \ - tactics vernac stm toplevel API + tactics vernac stm toplevel PLUGINDIRS:=\ omega romega micromega quote \ @@ -102,10 +100,10 @@ BYTERUN:=$(addprefix kernel/byterun/, \ # respecting this order is useful for developers that want to load or link # the libraries directly -CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ +CORECMA:=clib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma API/API.cma + stm/stm.cma toplevel/toplevel.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma diff --git a/Makefile.dev b/Makefile.dev index dc4ded397..d35ad7501 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -18,9 +18,9 @@ DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo devel: printers -printers: $(CORECMA) $(DEBUGPRINTERS) dev/camlp4.dbg +printers: $(CORECMA) $(DEBUGPRINTERS) dev/camlp5.dbg -dev/camlp4.dbg: +dev/camlp5.dbg: echo "load_printer gramlib.cma" > $@ ############ @@ -98,7 +98,7 @@ pluginsopt: $(PLUGINSOPT) pluginsbyte: $(PLUGINS) # This should build all the ocaml code but not (most of) the .v files -coqocaml: tools coqbinaries pluginsopt coqide printers bin/votour +coqocaml: tools coqbinaries $(PLUGINSCMO:.cmo=$(DYNOBJ)) coqide printers bin/votour .PHONY: coqlight states miniopt minibyte pluginsopt pluginsbyte coqocaml @@ -119,7 +119,7 @@ pretyping: pretyping/pretyping.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping API +.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping .PHONY: engine stm toplevel ###################### diff --git a/Makefile.doc b/Makefile.doc index faa9c879c..8cb9c9f0f 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -77,23 +77,23 @@ REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png) ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir +.PHONY: stdlib full-stdlib rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt -doc: refman faq tutorial rectutorial stdlib $(INDEXURLS) +doc: refman tutorial rectutorial stdlib $(INDEXURLS) doc-html:\ doc/tutorial/Tutorial.v.html doc/refman/html/index.html \ - doc/faq/html/index.html doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html + doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html doc-pdf:\ doc/tutorial/Tutorial.v.pdf doc/refman/Reference-Manual.pdf \ - doc/faq/FAQ.v.pdf doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf + doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf doc-ps:\ doc/tutorial/Tutorial.v.ps doc/refman/Reference-Manual.ps \ - doc/faq/FAQ.v.ps doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps + doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps refman: \ doc/refman/html/index.html doc/refman/Reference-Manual.ps doc/refman/Reference-Manual.pdf @@ -107,8 +107,6 @@ stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf -faq: doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf - rectutorial: doc/RecTutorial/RecTutorial.html \ doc/RecTutorial/RecTutorial.ps doc/RecTutorial/RecTutorial.pdf @@ -148,9 +146,6 @@ endif HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file" SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^ --' -# Empty subsection levels in faq are on purpose -HEVEAFAQFILTER=2>&1 | grep -v "^Warning: List with no item" - ###################################################################### # Common ###################################################################### @@ -253,33 +248,6 @@ doc/tutorial/Tutorial.v.pdf: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial; $(HEVEA) $(HEVEAOPTS) Tutorial.v) - -###################################################################### -# FAQ -###################################################################### - -doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex doc/faq/axioms.eps - (cd doc/faq;\ - $(LATEX) -interaction=batchmode FAQ.v;\ - $(BIBTEX) -terse FAQ.v;\ - $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ - $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ - ../tools/show_latex_messages FAQ.v.log) - -doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.pdf - (cd doc/faq;\ - $(PDFLATEX) -interaction=batchmode FAQ.v.tex;\ - ../tools/show_latex_messages FAQ.v.log) - -doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi doc/faq/axioms.png # to ensure FAQ.v.bbl - (cd doc/faq; ($(HEVEA) $(HEVEAOPTS) FAQ.v.tex $(HEVEAFAQFILTER))) - -doc/faq/html/index.html: doc/faq/FAQ.v.html - - rm -rf doc/faq/html - $(MKDIR) doc/faq/html - $(INSTALLLIB) doc/faq/interval_discr.v doc/faq/axioms.png doc/faq/html - $(INSTALLLIB) doc/faq/FAQ.v.html doc/faq/html/index.html - ###################################################################### # Standard library ###################################################################### @@ -386,14 +354,13 @@ install-doc-meta: $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc install-doc-html: - $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq) + $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib) (for f in `cd doc/refman/html; find . -type f`; do \ $(MKDIR) $$(dirname $(FULLDOCDIR)/html/refman/$$f);\ $(INSTALLLIB) doc/refman/html/$$f $(FULLDOCDIR)/html/refman/$$f;\ done) $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/RecTutorial/RecTutorial.html $(FULLDOCDIR)/html/RecTutorial.html - $(INSTALLLIB) doc/faq/html/* $(FULLDOCDIR)/html/faq $(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html install-doc-printable: @@ -404,10 +371,8 @@ install-doc-printable: doc/stdlib/Library.ps $(FULLDOCDIR)/ps $(INSTALLLIB) doc/tutorial/Tutorial.v.pdf $(FULLDOCDIR)/pdf/Tutorial.pdf $(INSTALLLIB) doc/RecTutorial/RecTutorial.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf - $(INSTALLLIB) doc/faq/FAQ.v.pdf $(FULLDOCDIR)/pdf/FAQ.pdf $(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps $(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps - $(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps install-doc-index-urls: $(MKDIR) $(FULLDATADIR) @@ -422,7 +387,7 @@ OCAMLDOCDIR=dev/ocamldoc DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \ ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \ - ./parsing/*.mli ./proofs/*.mli API/API.mli \ + ./parsing/*.mli ./proofs/*.mli \ ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli) # Defining options to generate dependencies graphs diff --git a/Makefile.ide b/Makefile.ide index 7d809f67a..4846f5e60 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -41,12 +41,12 @@ IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) -IDEDEPS:=lib/clib.cma lib/cErrors.cmo lib/spawn.cmo +IDEDEPS:=clib/clib.cma lib/lib.cma IDECMA:=ide/ide.cma IDETOPLOOPCMA=ide/coqidetop.cma -LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml -LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml +LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.mli ide/coqide_main.ml +LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.mli ide/coqide_main.ml IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map @@ -106,9 +106,9 @@ $(COQIDEBYTE): $(LINKIDE) $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \ lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^ -ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here - $(SHOW)'CAMLP4O $<' - $(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@ +ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp5deps here + $(SHOW)'CAMLP5O $<' + $(HIDE)$(CAMLP5O) -I $(MYCAMLP5LIB) $(PR_O) $(CAMLP5USE) -D$(IDEINT) -impl $< -o $@ ide/%.cmi: ide/%.mli diff --git a/Makefile.install b/Makefile.install index b590aad54..9a7229d52 100644 --- a/Makefile.install +++ b/Makefile.install @@ -101,12 +101,16 @@ INSTALLCMI = $(sort \ $(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \ $(PLUGINS:.cmo=.cmi) +INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% configure.cmx, $(MLFILES:.ml=.cmx))) + install-devfiles: $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQMKTOP) $(FULLBINDIR) $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(GRAMMARCMA) - $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) # Regular CMI files + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMX) # To avoid warning 58 "-opaque" + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.cmx) # For static linking of plugins + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.o) # For static linking of plugins $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) @@ -136,7 +140,7 @@ install-coq-info: install-coq-manpages install-emacs install-latex MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \ man/coqwc.1 man/coqdoc.1 man/coqide.1 \ - man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 + man/coq_makefile.1 man/coqchk.1 install-coq-manpages: $(MKDIR) $(FULLMANDIR)/man1 @@ -1,6 +1,10 @@ # Coq -[](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) [](https://gitter.im/coq/coq) +[](https://travis-ci.org/coq/coq/builds) +[](https://ci.appveyor.com/project/coq/coq/branch/master) +[](https://circleci.com/gh/coq/workflows/coq/tree/master) +[](https://gitter.im/coq/coq) +[](https://doi.org/10.5281/zenodo.1003420) Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an @@ -12,9 +16,13 @@ read the [help page](https://coq.inria.fr/opam/www/using.html) on how to install or refer to the [`INSTALL` file](/INSTALL) for the procedure to install from source. ## Documentation -The documentation is part of the archive in directory doc. The + +The sources of the documentation can be found in directory [`doc`](/doc). The documentation of the last released version is available on the Coq web site at [coq.inria.fr/documentation](http://coq.inria.fr/documentation). +See also [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), +and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), +for additional user-contributed documentation. ## Changes There is a file named [`CHANGES`](/CHANGES) that explains the differences and the diff --git a/appveyor.yml b/appveyor.yml index 92fc629b3..64c1bedb5 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -12,22 +12,20 @@ environment: matrix: - USEOPAM: true ARCH: 64 -# Comment out until issue #5998 is fixed. -# - USEOPAM: false -# ARCH: 32 -# - USEOPAM: false -# ARCH: 64 + - USEOPAM: false + ARCH: 32 + - USEOPAM: false + ARCH: 64 build_script: - cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat' test: off -# Comment out until issue #5998 is fixed. -#artifacts: -# - path: 'dev\nsis\*.exe' -# name: installer +artifacts: + - path: 'dev\nsis\*.exe' + name: installer -# - path: 'coq-opensource-archive-*.zip' -# name: opensource-archive + - path: 'coq-opensource-archive-*.zip' + name: opensource-archive diff --git a/checker/analyze.ml b/checker/analyze.ml index df75d5b93..7047d8a14 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -55,6 +55,55 @@ let magic_number = "\132\149\166\190" (** Memory reification *) +module LargeArray : +sig + type 'a t + val empty : 'a t + val length : 'a t -> int + val make : int -> 'a -> 'a t + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit +end = +struct + + let max_length = Sys.max_array_length + + type 'a t = 'a array array * 'a array + (** Invariants: + - All subarrays of the left array have length [max_length]. + - The right array has length < [max_length]. + *) + + let empty = [||], [||] + + let length (vl, vr) = + (max_length * Array.length vl) + Array.length vr + + let make n x = + let k = n / max_length in + let r = n mod max_length in + let vl = Array.init k (fun _ -> Array.make max_length x) in + let vr = Array.make r x in + (vl, vr) + + let get (vl, vr) n = + let k = n / max_length in + let r = n mod max_length in + let len = Array.length vl in + if k < len then vl.(k).(r) + else if k == len then vr.(r) + else invalid_arg "index out of bounds" + + let set (vl, vr) n x = + let k = n / max_length in + let r = n mod max_length in + let len = Array.length vl in + if k < len then vl.(k).(r) <- x + else if k == len then vr.(r) <- x + else invalid_arg "index out of bounds" + +end + type repr = | RInt of int | RBlock of (int * int) (* tag × len *) @@ -82,7 +131,7 @@ end module type S = sig type input - val parse : input -> (data * obj array) + val parse : input -> (data * obj LargeArray.t) end module Make(M : Input) = @@ -261,7 +310,7 @@ let parse_object chan = let parse chan = let (magic, len, _, _, size) = parse_header chan in let () = assert (magic = magic_number) in - let memory = Array.make size (Struct ((-1), [||])) in + let memory = LargeArray.make size (Struct ((-1), [||])) in let current_object = ref 0 in let fill_obj = function | RPointer n -> @@ -272,7 +321,7 @@ let parse chan = data, None | RString s -> let data = Ptr !current_object in - let () = memory.(!current_object) <- String s in + let () = LargeArray.set memory !current_object (String s) in let () = incr current_object in data, None | RBlock (tag, 0) -> @@ -282,7 +331,7 @@ let parse chan = | RBlock (tag, len) -> let data = Ptr !current_object in let nblock = Array.make len (Atm (-1)) in - let () = memory.(!current_object) <- Struct (tag, nblock) in + let () = LargeArray.set memory !current_object (Struct (tag, nblock)) in let () = incr current_object in data, Some nblock | RCode addr -> @@ -343,3 +392,32 @@ module PString = Make(IString) let parse_channel = PChannel.parse let parse_string s = PString.parse (s, ref 0) + +let instantiate (p, mem) = + let len = LargeArray.length mem in + let ans = LargeArray.make len (Obj.repr 0) in + (** First pass: initialize the subobjects *) + for i = 0 to len - 1 do + let obj = match LargeArray.get mem i with + | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) + | String str -> Obj.repr str + in + LargeArray.set ans i obj + done; + let get_data = function + | Int n -> Obj.repr n + | Ptr p -> LargeArray.get ans p + | Atm tag -> Obj.new_block tag 0 + | Fun _ -> assert false (** We shouldn't serialize closures *) + in + (** Second pass: set the pointers *) + for i = 0 to len - 1 do + match LargeArray.get mem i with + | Struct (_, blk) -> + let obj = LargeArray.get ans i in + for k = 0 to Array.length blk - 1 do + Obj.set_field obj k (get_data blk.(k)) + done + | String _ -> () + done; + get_data p diff --git a/checker/analyze.mli b/checker/analyze.mli index 42efcf01d..9c837643f 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -8,8 +8,20 @@ type obj = | Struct of int * data array (* tag × data *) | String of string -val parse_channel : in_channel -> (data * obj array) -val parse_string : string -> (data * obj array) +module LargeArray : +sig + type 'a t + val empty : 'a t + val length : 'a t -> int + val make : int -> 'a -> 'a t + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit +end +(** A data structure similar to arrays but allowing to overcome the 2^22 length + limitation on 32-bit architecture. *) + +val parse_channel : in_channel -> (data * obj LargeArray.t) +val parse_string : string -> (data * obj LargeArray.t) (** {6 Functorized version} *) @@ -26,10 +38,13 @@ end module type S = sig type input - val parse : input -> (data * obj array) + val parse : input -> (data * obj LargeArray.t) (** Return the entry point and the reification of the memory out of a marshalled structure. *) end module Make (M : Input) : S with type input = M.t (** Functorized version of the previous code. *) + +val instantiate : data * obj LargeArray.t -> Obj.t +(** Create the OCaml object out of the reified representation. *) diff --git a/checker/check.ml b/checker/check.ml index 180ca1ece..82341ad9b 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -22,6 +22,11 @@ let extend_dirpath p id = DirPath.make (id :: DirPath.repr p) type section_path = { dirpath : string list ; basename : string } + +type object_file = +| PhysicalFile of CUnix.physical_path +| LogicalFile of section_path + let dir_of_path p = DirPath.make (List.map Id.of_string p.dirpath) let path_of_dirpath dir = @@ -69,11 +74,6 @@ let libraries_table = ref LibraryMap.empty let find_library dir = LibraryMap.find dir !libraries_table -let try_find_library dir = - try find_library dir - with Not_found -> - user_err Pp.(str ("Unknown library " ^ (DirPath.to_string dir))) - let library_full_filename dir = (find_library dir).library_filename (* If a library is loaded several time, then the first occurrence must @@ -129,8 +129,6 @@ type logical_path = DirPath.t let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list) -let get_load_paths () = fst !load_paths - (* Hints to partially detects if two paths refer to the same repertory *) let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) @@ -227,13 +225,8 @@ let locate_absolute_library dir = let locate_qualified_library qid = try - let loadpath = - (* Search library in loadpath *) - if qid.dirpath=[] then get_load_paths () - else - (* we assume qid is an absolute dirpath *) - load_paths_of_dir_path (dir_of_path qid) - in + (* we assume qid is an absolute dirpath *) + let loadpath = load_paths_of_dir_path (dir_of_path qid) in if loadpath = [] then raise LibUnmappedDir; let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in @@ -263,7 +256,17 @@ let try_locate_absolute_library dir = | LibUnmappedDir -> error_unmapped_dir (path_of_dirpath dir) | LibNotFound -> error_lib_not_found (path_of_dirpath dir) -let try_locate_qualified_library qid = +let try_locate_qualified_library lib = match lib with +| PhysicalFile f -> + let () = + if not (System.file_exists_respecting_case "" f) then + error_lib_not_found { dirpath = []; basename = f; } + in + let dir = Filename.dirname f in + let base = Filename.chop_extension (Filename.basename f) in + let dir = extend_dirpath (find_logical_path dir) (Id.of_string base) in + (dir, f) +| LogicalFile qid -> try locate_qualified_library qid with @@ -298,18 +301,27 @@ let name_clash_message dir mdir f = (* Dependency graph *) let depgraph = ref LibraryMap.empty +let marshal_in_segment f ch = + try + let stop = input_binary_int ch in + let v = Analyze.instantiate (Analyze.parse_channel ch) in + let digest = Digest.input ch in + Obj.obj v, stop, digest + with _ -> + user_err (str "Corrupted file " ++ quote (str f)) + let intern_from_file (dir, f) = Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try let ch = System.with_magic_number_check raw_intern_library f in - let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in - let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in - let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in - let (discharging:'a option), _, _ = System.marshal_in_segment f ch in - let (tasks:'a option), _, _ = System.marshal_in_segment f ch in + let (sd:Cic.summary_disk), _, digest = marshal_in_segment f ch in + let (md:Cic.library_disk), _, digest = marshal_in_segment f ch in + let (opaque_csts:'a option), _, udg = marshal_in_segment f ch in + let (discharging:'a option), _, _ = marshal_in_segment f ch in + let (tasks:'a option), _, _ = marshal_in_segment f ch in let (table:Cic.opaque_table), pos, checksum = - System.marshal_in_segment f ch in + marshal_in_segment f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in @@ -412,9 +424,3 @@ let recheck_library ~norec ~admit ~check = (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; Flags.if_verbose Feedback.msg_notice (str"Modules were successfully checked") - -open Printf - -let mem s = - let m = try_find_library s in - h 0 (str (sprintf "%dk" (CObj.size_kb m))) diff --git a/checker/check.mli b/checker/check.mli new file mode 100644 index 000000000..28ae385b5 --- /dev/null +++ b/checker/check.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open CUnix +open Names + +type section_path = { + dirpath : string list; + basename : string; +} + +type object_file = +| PhysicalFile of physical_path +| LogicalFile of section_path + +type logical_path = DirPath.t + +val default_root_prefix : DirPath.t + +val add_load_path : physical_path * logical_path -> unit + +val recheck_library : + norec:object_file list -> + admit:object_file list -> + check:object_file list -> unit diff --git a/checker/check.mllib b/checker/check.mllib index 488507a13..f79ba66e3 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,5 +1,6 @@ Coq_config +Analyze Hook Terminal Canary diff --git a/checker/checker.ml b/checker/checker.ml index e960a55fd..e8eff889c 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -18,7 +18,7 @@ let () = at_exit flush_all let chk_pp = Pp.pp_with Format.std_formatter let fatal_error info anomaly = - flush_all (); Feedback.msg_error info; flush_all (); + flush_all (); Format.eprintf "@[Fatal Error: @[%a@]@]%!@\n" Pp.pp_with info; flush_all (); exit (if anomaly then 129 else 1) let coq_root = Id.of_string "Coq" @@ -40,9 +40,10 @@ let dirpath_of_string s = [] -> Check.default_root_prefix | dir -> DirPath.make (List.map Id.of_string dir) let path_of_string s = - match parse_dir s with + if Filename.check_suffix s ".vo" then PhysicalFile s + else match parse_dir s with [] -> invalid_arg "path_of_string" - | l::dir -> {dirpath=dir; basename=l} + | l::dir -> LogicalFile {dirpath=dir; basename=l} let ( / ) = Filename.concat @@ -95,17 +96,13 @@ let add_rec_path ~unix_path ~coq_root = (* By the option -include -I or -R of the command line *) let includes = ref [] -let push_include (s, alias) = includes := (s,alias,false) :: !includes -let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes +let push_include (s, alias) = includes := (s,alias) :: !includes let set_default_include d = push_include (d, Check.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) -let set_rec_include d p = - let p = dirpath_of_string p in - push_rec_include(d,p) (* Initializes the LoadPath *) let init_load_path () = @@ -131,8 +128,7 @@ let init_load_path () = add_path ~unix_path:"." ~coq_root:Check.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter - (fun (unix_path, coq_root, reci) -> - if reci then add_rec_path ~unix_path ~coq_root else add_path ~unix_path ~coq_root) + (fun (unix_path, coq_root) -> add_rec_path ~unix_path ~coq_root) (List.rev !includes); includes := [] @@ -144,15 +140,15 @@ let set_impredicative_set () = impredicative_set := Cic.ImpredicativeSet let engage () = Safe_typing.set_engagement (!impredicative_set) -let admit_list = ref ([] : section_path list) +let admit_list = ref ([] : object_file list) let add_admit s = admit_list := path_of_string s :: !admit_list -let norec_list = ref ([] : section_path list) +let norec_list = ref ([] : object_file list) let add_norec s = norec_list := path_of_string s :: !norec_list -let compile_list = ref ([] : section_path list) +let compile_list = ref ([] : object_file list) let add_compile s = compile_list := path_of_string s :: !compile_list @@ -178,7 +174,9 @@ let print_usage_channel co command = output_string co command; output_string co "coqchk options are:\n"; output_string co -" -R dir coqdir map physical dir to logical coqdir\ +" -Q dir coqdir map physical dir to logical coqdir\ +\n -R dir coqdir synonymous for -Q\ +\n\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ @@ -210,8 +208,7 @@ let usage () = open Type_errors let anomaly_string () = str "Anomaly: " -let report () = (str "." ++ spc () ++ str "Please report" ++ - strbrk "at " ++ str Coq_config.wwwbugtracker ++ str ".") +let report () = strbrk (". Please report at " ^ Coq_config.wwwbugtracker ^ ".") let guill s = str "\"" ++ str s ++ str "\"" @@ -310,6 +307,9 @@ let explain_exn = function report ()) | e -> CErrors.print e (* for anomalies and other uncaught exceptions *) +let deprecated flag = + Feedback.msg_warning (str "Deprecated flag " ++ quote (str flag)) + let parse_args argv = let rec parse = function | [] -> () @@ -323,12 +323,15 @@ let parse_args argv = Flags.coqlib_spec := true; parse rem - | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem + | ("-I"|"-include") :: d :: "-as" :: p :: rem -> deprecated "-I"; set_include d p; parse rem | ("-I"|"-include") :: d :: "-as" :: [] -> usage () - | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem + | ("-I"|"-include") :: d :: rem -> deprecated "-I"; set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem + | "-Q" :: d :: p :: rem -> set_include d p;parse rem + | "-Q" :: ([] | [_]) -> usage () + + | "-R" :: d :: p :: rem -> set_include d p;parse rem | "-R" :: ([] | [_]) -> usage () | "-debug" :: rem -> set_debug (); parse rem diff --git a/checker/checker.mli b/checker/checker.mli new file mode 100644 index 000000000..ceab13774 --- /dev/null +++ b/checker/checker.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val start : unit -> unit diff --git a/checker/cic.mli b/checker/cic.mli index 4a0e706aa..1f4322dff 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -170,6 +170,17 @@ type set_predicativity = ImpredicativeSet | PredicativeSet type engagement = set_predicativity +(** {6 Conversion oracle} *) + +type level = Expand | Level of int | Opaque + +type oracle = { + var_opacity : level Id.Map.t; + cst_opacity : level Cmap.t; + var_trstate : Id.Pred.t; + cst_trstate : Cpred.t; +} + (** {6 Representation of constants (Definition/Axiom) } *) @@ -219,6 +230,7 @@ type typing_flags = { check_guarded : bool; (** If [false] then fixed points and co-fixed points are assumed to be total. *) check_universes : bool; (** If [false] universe constraints are not checked *) + conv_oracle : oracle; (** Unfolding strategies for conversion *) } type constant_body = { @@ -346,9 +358,7 @@ type ('ty,'a) functorize = and won't play any role into the kernel after that : they are kept only for short module printing and for extraction. *) -type with_declaration = - | WithMod of Id.t list * ModPath.t - | WithDef of Id.t list * (constr * Univ.universe_context) +type with_declaration type module_alg_expr = | MEident of ModPath.t diff --git a/checker/closure.ml b/checker/closure.ml index 7982ffa7a..14b31e09d 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -49,13 +49,6 @@ let with_stats c = end else Lazy.force c -type transparent_state = Id.Pred.t * Cpred.t -let all_opaque = (Id.Pred.empty, Cpred.empty) -let all_transparent = (Id.Pred.full, Cpred.full) - -let is_transparent_variable (ids, _) id = Id.Pred.mem id ids -let is_transparent_constant (_, csts) cst = Cpred.mem cst csts - module type RedFlagsSig = sig type reds type red_kind @@ -63,8 +56,6 @@ module type RedFlagsSig = sig val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind - val fCONST : Constant.t -> red_kind - val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val mkflags : red_kind list -> reds @@ -80,51 +71,33 @@ module RedFlags = (struct type reds = { r_beta : bool; r_delta : bool; - r_const : transparent_state; r_zeta : bool; r_evar : bool; r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA - | CONST of Constant.t | VAR of Id.t + let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA let fZETA = ZETA - let fCONST kn = CONST kn - let fVAR id = VAR id let no_red = { r_beta = false; r_delta = false; - r_const = all_opaque; r_zeta = false; r_evar = false; r_iota = false } let red_add red = function | BETA -> { red with r_beta = true } - | DELTA -> { red with r_delta = true; r_const = all_transparent } - | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.add kn l2 } + | DELTA -> { red with r_delta = true} | IOTA -> { red with r_iota = true } | ZETA -> { red with r_zeta = true } - | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.add id l1, l2 } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta - | CONST kn -> - let (_,l) = red.r_const in - let c = Cpred.mem kn l in - incr_cnt c delta - | VAR id -> (* En attendant d'avoir des kn pour les Var *) - let (l,_) = red.r_const in - let c = Id.Pred.mem id l in - incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota | DELTA -> (* Used for Rel/Var defined in context *) @@ -279,7 +252,6 @@ and fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -306,7 +278,6 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack @@ -456,13 +427,10 @@ let rec to_constr constr_fun lfts v = | FFlex (ConstKey op) -> Const op | FInd op -> Ind op | FConstruct op -> Construct op - | FCase (ci,p,c,ve) -> - Case (ci, constr_fun lfts p, - constr_fun lfts c, - Array.map (constr_fun lfts) ve) - | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *) - to_constr constr_fun lfts - {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)} + | FCaseT (ci,p,c,ve,e) -> + let fp = mk_clos2 e p in + let fve = mk_clos_vect e ve in + Case (ci, constr_fun lfts fp, constr_fun lfts c, Array.map (constr_fun lfts) fve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in @@ -532,9 +500,6 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s - | Zcase(ci,p,br)::s -> - let t = FCase(ci, p, m, br) in - zip {norm=neutr m.norm; term=t} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s @@ -616,7 +581,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ + | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> @@ -708,6 +673,9 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) +let unfold_projection env p = + let pb = lookup_projection p env in + Zproj (pb.proj_npars, pb.proj_arg, p) (*********************************************************************) (* A machine that inspects the head of a term until it finds an @@ -720,7 +688,6 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) - | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with @@ -729,10 +696,9 @@ let rec knh info m stk = | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> - if red_set info.i_flags (fCONST (Projection.constant p)) then - (let pb = lookup_projection p (info.i_env) in - knh info c (Zproj (pb.proj_npars, pb.proj_arg, p) - :: zupdate m stk)) + if red_set info.i_flags fDELTA then + let s = unfold_projection info.i_env p in + knh info c (s :: zupdate m stk) else (m,stk) (* cases where knh stops *) @@ -764,11 +730,11 @@ let rec knr info m stk = (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey kn) when red_set info.i_flags (fCONST (fst kn)) -> + | FFlex(ConstKey kn) when red_set info.i_flags fDELTA -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> + | FFlex(VarKey id) when red_set info.i_flags fDELTA -> (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) @@ -778,10 +744,6 @@ let rec knr info m stk = | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (depth, args, Zcase(ci,_,br)::s) -> - assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - kni info br.(c-1) (rargs@s) | (depth, args, ZcaseT(ci,_,br,env)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in @@ -798,7 +760,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, (((Zcase _|ZcaseT _)::_) as stk')) -> + (_, args, (((ZcaseT _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) @@ -835,6 +797,7 @@ type clos_infos = fconstr infos let infos_env x = x.i_env let infos_flags x = x.i_flags +let oracle_of_infos x = x.i_env.env_conv_oracle let create_clos_infos flgs env = create (fun _ -> inject) flgs env diff --git a/checker/closure.mli b/checker/closure.mli index 957cc4adb..7bdc21b60 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -24,14 +24,6 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) -type transparent_state = Id.Pred.t * Cpred.t - -val all_opaque : transparent_state -val all_transparent : transparent_state - -val is_transparent_variable : transparent_state -> variable -> bool -val is_transparent_constant : transparent_state -> Constant.t -> bool - (* Sets of reduction kinds. *) module type RedFlagsSig = sig type reds @@ -42,8 +34,6 @@ module type RedFlagsSig = sig val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind - val fCONST : Constant.t -> red_kind - val fVAR : Id.t -> red_kind (* No reduction at all *) val no_red : reds @@ -98,7 +88,6 @@ type fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -115,7 +104,6 @@ type fterm = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack @@ -133,6 +121,8 @@ val eta_expand_stack : stack -> stack val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (fconstr * stack) -> stack * stack +val unfold_projection : env -> Projection.t -> stack_member + (* To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) @@ -149,6 +139,8 @@ type clos_infos val create_clos_infos : reds -> env -> clos_infos val infos_env : clos_infos -> env val infos_flags : clos_infos -> reds +val oracle_of_infos : clos_infos -> oracle + (* Reduction function *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 884a1ef18..2fe930dca 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -484,8 +484,8 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true - | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 - | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 + | Mrec i1, Mrec i2 -> Names.eq_ind_chk i1 i2 + | Imbr i1, Imbr i2 -> Names.eq_ind_chk i1 i2 | _ -> false let eq_wf_paths = Rtree.equal eq_recarg @@ -573,14 +573,10 @@ let implem_map fs fa = function | Algebraic a -> Algebraic (fa a) | impl -> impl -let subst_with_body sub = function - | WithMod(id,mp) -> WithMod(id,subst_mp sub mp) - | WithDef(id,(c,ctx)) -> WithDef(id,(subst_mps sub c,ctx)) - let rec subst_expr sub = function | MEident mp -> MEident (subst_mp sub mp) | MEapply (me1,mp2)-> MEapply (subst_expr sub me1, subst_mp sub mp2) - | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd) + | MEwith (me,wd)-> MEwith (subst_expr sub me, wd) let rec subst_expression sub me = functor_map (subst_module_type sub) (subst_expr sub) me diff --git a/checker/environ.ml b/checker/environ.ml index 9db0d60e8..bbd043c8e 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -21,7 +21,15 @@ type env = { env_globals : globals; env_rel_context : rel_context; env_stratification : stratification; - env_imports : Cic.vodigest MPmap.t } + env_imports : Cic.vodigest MPmap.t; + env_conv_oracle : oracle; } + +let empty_oracle = { + var_opacity = Id.Map.empty; + cst_opacity = Cmap.empty; + var_trstate = Id.Pred.empty; + cst_trstate = Cpred.empty; +} let empty_env = { env_globals = @@ -34,7 +42,8 @@ let empty_env = { env_stratification = { env_universes = Univ.initial_universes; env_engagement = PredicativeSet }; - env_imports = MPmap.empty } + env_imports = MPmap.empty; + env_conv_oracle = empty_oracle } let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes @@ -51,6 +60,8 @@ let set_engagement (impr_set as c) env = { env with env_stratification = { env.env_stratification with env_engagement = c } } +let set_oracle env oracle = { env with env_conv_oracle = oracle } + (* Digests *) let add_digest env dp digest = @@ -115,7 +126,7 @@ let add_constant kn cs env = env_constants = new_constants } in { env with env_globals = new_globals } -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque (* Constant types *) @@ -137,18 +148,16 @@ exception NotEvaluableConst of const_evaluation_result let constant_value env (kn,u) = let cb = lookup_constant kn env in - if cb.const_proj = None then - match cb.const_body with - | Def l_body -> - let b = force_constr l_body in - begin - match cb.const_universes with - | Monomorphic_const _ -> b - | Polymorphic_const _ -> subst_instance_constr u (force_constr l_body) - end - | OpaqueDef _ -> raise (NotEvaluableConst Opaque) - | Undef _ -> raise (NotEvaluableConst NoBody) - else raise (NotEvaluableConst IsProj) + match cb.const_body with + | Def l_body -> + let b = force_constr l_body in + begin + match cb.const_universes with + | Monomorphic_const _ -> b + | Polymorphic_const _ -> subst_instance_constr u (force_constr l_body) + end + | OpaqueDef _ -> raise (NotEvaluableConst Opaque) + | Undef _ -> raise (NotEvaluableConst NoBody) (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = diff --git a/checker/environ.mli b/checker/environ.mli index 6bda838f8..36e0ea027 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -18,6 +18,7 @@ type env = { env_rel_context : rel_context; env_stratification : stratification; env_imports : Cic.vodigest MPmap.t; + env_conv_oracle : Cic.oracle; } val empty_env : env @@ -25,6 +26,10 @@ val empty_env : env val engagement : env -> Cic.engagement val set_engagement : Cic.engagement -> env -> env +(** Oracle *) + +val set_oracle : env -> Cic.oracle -> env + (* Digests *) val add_digest : env -> DirPath.t -> Cic.vodigest -> env val lookup_digest : env -> DirPath.t -> Cic.vodigest @@ -47,7 +52,7 @@ val check_constraints : Univ.constraints -> env -> bool val lookup_constant : Constant.t -> env -> Cic.constant_body val add_constant : Constant.t -> Cic.constant_body -> env -> env val constant_type : env -> Constant.t puniverses -> constr Univ.constrained -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result val constant_value : env -> Constant.t puniverses -> constr val evaluable_constant : Constant.t -> env -> bool diff --git a/checker/include b/checker/include index 09bf2826c..da0346359 100644 --- a/checker/include +++ b/checker/include @@ -13,7 +13,6 @@ #directory "kernel";; #directory "checker";; #directory "+threads";; -#directory "+camlp4";; #directory "+camlp5";; #load "unix.cma";; diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 22c843812..1807ae0ec 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -502,10 +502,19 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc indlc in mk_paths (Mrec ind) irecargs +let prrecarg = function + | Norec -> str "Norec" + | Mrec (mind,i) -> + str "Mrec[" ++ MutInd.debug_print mind ++ pr_comma () ++ int i ++ str "]" + | Imbr (mind,i) -> + str "Imbr[" ++ MutInd.debug_print mind ++ pr_comma () ++ int i ++ str "]" + let check_subtree t1 t2 = let cmp_labels l1 l2 = l1 == Norec || eq_recarg l1 l2 in if not (Rtree.equiv eq_recarg cmp_labels t1 t2) - then failwith "bad recursive trees" + then user_err Pp.(str "Bad recursive tree: found " ++ fnl () + ++ Rtree.pp_tree prrecarg t1 ++ fnl () ++ str " when expected " ++ fnl () + ++ Rtree.pp_tree prrecarg t2) (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*) let check_positivity env_ar mind params nrecp inds = @@ -555,14 +564,23 @@ let check_subtyping cumi paramsctxt env inds = We must produce the substitution σ : [ Var(i) -> Var (i + n) | 0 <= i < n] and push the constraints [ Var(n) ... Var(2n - 1) |- cst{σ} ], together with the cumulativity constraints [ cumul_cst ]. *) - let len = AUContext.size (ACumulativityInfo.univ_context cumi) in - let inst = Instance.of_array (Array.init len (fun i -> Level.var (i + len))) in + let uctx = ACumulativityInfo.univ_context cumi in + let len = AUContext.size uctx in + let inst = Instance.of_array @@ Array.init len (fun i -> Level.var (i + len)) in + let other_context = ACumulativityInfo.univ_context cumi in let uctx_other = UContext.make (inst, AUContext.instantiate inst other_context) in - let cumul_context = AUContext.repr (ACumulativityInfo.subtyp_context cumi) in - let cumul_cst = UContext.constraints cumul_context in + let cumul_cst = + Array.fold_left_i (fun i csts var -> + match var with + | Variance.Irrelevant -> csts + | Variance.Covariant -> Constraint.add (Level.var i,Le,Level.var (i+len)) csts + | Variance.Invariant -> Constraint.add (Level.var i,Eq,Level.var (i+len)) csts) + Constraint.empty (ACumulativityInfo.variance cumi) + in let env = Environ.push_context uctx_other env in let env = Environ.add_constraints cumul_cst env in + (* process individual inductive types: *) Array.iter (fun { mind_user_lc = lc; mind_arity = arity } -> match arity with @@ -586,6 +604,8 @@ let check_inductive env kn mib = Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) in let env = Environ.push_context ind_ctx env in + (** Locally set the oracle for further typechecking *) + let env0 = Environ.set_oracle env mib.mind_typing_flags.conv_oracle in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) @@ -593,13 +613,13 @@ let check_inductive env kn mib = user_err Pp.(str "not the right number of packets"); (* check mind_params_ctxt *) let params = mib.mind_params_ctxt in - let _ = check_ctxt env params in + let _ = check_ctxt env0 params in (* check mind_nparams *) if rel_context_nhyps params <> mib.mind_nparams then user_err Pp.(str "number the right number of parameters"); (* mind_packets *) (* - check arities *) - let env_ar = typecheck_arity env params mib.mind_packets in + let env_ar = typecheck_arity env0 params mib.mind_packets in (* - check constructor types *) Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets; (* check the inferred subtyping relation *) diff --git a/checker/inductive.ml b/checker/inductive.ml index 1271a02b0..8d426a3c0 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -381,7 +381,7 @@ let type_case_branches env (pind,largs) (p,pj) c = let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if - not (eq_ind indsp ci.ci_ind) || + not (eq_ind_chk indsp ci.ci_ind) || (mib.mind_nparams <> ci.ci_npar) || (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) || (mip.mind_consnrealargs <> ci.ci_cstr_nargs) @@ -435,20 +435,14 @@ type subterm_spec = | Dead_code | Not_subterm -let eq_recarg r1 r2 = match r1, r2 with -| Norec, Norec -> true -| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 -| Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 -| _ -> false - let eq_wf_paths = Rtree.equal eq_recarg let inter_recarg r1 r2 = match r1, r2 with | Norec, Norec -> Some r1 | Mrec i1, Mrec i2 | Imbr i1, Imbr i2 -| Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None -| Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None +| Mrec i1, Imbr i2 -> if Names.eq_ind_chk i1 i2 then Some r1 else None +| Imbr i1, Mrec i2 -> if Names.eq_ind_chk i1 i2 then Some r2 else None | _ -> None let inter_wf_paths = Rtree.inter eq_recarg inter_recarg Norec @@ -544,7 +538,7 @@ let lookup_subterms env ind = let match_inductive ind ra = match ra with - | (Mrec i | Imbr i) -> eq_ind ind i + | (Mrec i | Imbr i) -> eq_ind_chk ind i | Norec -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} @@ -645,7 +639,7 @@ let get_recargs_approx env tree ind args = (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with - | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> + | Imbr kn' | Mrec kn' when eq_ind_chk (fst ind_kn) kn' -> build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end @@ -1070,8 +1064,8 @@ let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) = done (* -let cfkey = Profile.declare_profile "check_fix";; -let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; +let cfkey = CProfile.declare_profile "check_fix";; +let check_fix env fix = CProfile.profile3 cfkey check_fix env fix;; *) (************************************************************************) diff --git a/checker/main.mli b/checker/main.mli new file mode 100644 index 000000000..e1555ba2e --- /dev/null +++ b/checker/main.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 4357a690e..7685863ea 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -26,6 +26,9 @@ let refresh_arity ar = let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ prcon kn); + (** Locally set the oracle for further typechecking *) + let oracle = env.env_conv_oracle in + let env = Environ.set_oracle env cb.const_typing_flags.conv_oracle in (** [env'] contains De Bruijn universe variables *) let env' = match cb.const_universes with @@ -53,8 +56,12 @@ let check_constant_declaration env kn cb = conv_leq envty j ty) | None -> () in - if constant_is_polymorphic cb then add_constant kn cb env - else add_constant kn cb env' + let env = + if constant_is_polymorphic cb then add_constant kn cb env + else add_constant kn cb env' + in + (** Reset the value of the oracle *) + Environ.set_oracle env oracle (** {6 Checking modules } *) diff --git a/checker/print.mli b/checker/print.mli new file mode 100644 index 000000000..3b2715de9 --- /dev/null +++ b/checker/print.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Cic + +val print_pure_constr : constr -> unit diff --git a/checker/reduction.ml b/checker/reduction.ml index 6d8783d7e..2297c90b3 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -42,8 +42,8 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1, - (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) -> + | ((ZcaseT(c1,_,_,_))::s1, + (ZcaseT(c2,_,_,_))::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -78,8 +78,7 @@ let pure_stack lfts stk = (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,env),(l,pstk)) -> (l,Zlcase(ci,l,mk_clos env p,mk_clos_vect env br)::pstk) - | (Zcase(ci,p,br),(l,pstk)) -> - (l,Zlcase(ci,l,p,br)::pstk)) in + ) in snd (pure_rec lfts stk) (****************************************************************************) @@ -159,24 +158,17 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = let convert_inductive_instances cv_pb cumi u u' univs = let len_instance = Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in - let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in if not ((len_instance = Univ.Instance.length u) && (len_instance = Univ.Instance.length u')) then anomaly (Pp.str "Invalid inductive subtyping encountered!") else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in + let variance = Univ.ACumulativityInfo.variance cumi in let comp_cst = match cv_pb with - CONV -> - let comp_cst' = - let comp_subst = (Univ.Instance.append u' u) in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in - Univ.Constraint.union comp_cst comp_cst' - | CUMUL -> comp_cst + | CONV -> + Univ.Variance.eq_constraints variance u u' Univ.Constraint.empty + | CUMUL -> + Univ.Variance.leq_constraints variance u u' Univ.Constraint.empty in if (Univ.check_constraints comp_cst univs) then () else raise NotConvertible @@ -243,7 +235,6 @@ let rec no_arg_available = function | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -256,7 +247,6 @@ let rec no_nth_arg_available n = function if n >= k then no_nth_arg_available (n-k) stk else false | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -266,13 +256,12 @@ let rec no_case_available = function | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zproj (_,_,_) :: _ -> false - | Zcase _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with - | (FLetIn _ | FCase _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false + | (FLetIn _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk @@ -280,16 +269,29 @@ let in_whnf (t,stk) = | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false -let oracle_order fl1 fl2 = - match fl1,fl2 with - ConstKey c1, ConstKey c2 -> (*height c1 > height c2*)false - | _, ConstKey _ -> true - | _ -> false - -let unfold_projection infos p c = - let pb = lookup_projection p (infos_env infos) in - let s = Zproj (pb.proj_npars, pb.proj_arg, p) in - (c, s) +let default_level = Level 0 + +let get_strategy { var_opacity; cst_opacity } = function + | VarKey id -> + (try Names.Id.Map.find id var_opacity + with Not_found -> default_level) + | ConstKey (c, _) -> + (try Names.Cmap.find c cst_opacity + with Not_found -> default_level) + | RelKey _ -> Expand + +let oracle_order infos l2r k1 k2 = + let o = Closure.oracle_of_infos infos in + match get_strategy o k1, get_strategy o k2 with + | Expand, Expand -> l2r + | Expand, (Opaque | Level _) -> true + | (Opaque | Level _), Expand -> false + | Opaque, Opaque -> l2r + | Level _, Opaque -> true + | Opaque, Level _ -> false + | Level n1, Level n2 -> + if Int.equal n1 n2 then l2r + else n1 < n2 (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = @@ -343,7 +345,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = - if oracle_order fl1 fl2 then + if oracle_order infos false fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) | None -> @@ -360,12 +362,12 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = eqappr univ cv_pb infos app1 app2) | (FProj (p1,c1), _) -> - let (def1, s1) = unfold_projection infos p1 c1 in - eqappr univ cv_pb infos (lft1, whd_stack infos def1 (s1 :: v1)) appr2 + let s1 = unfold_projection (infos_env infos) p1 in + eqappr univ cv_pb infos (lft1, whd_stack infos c1 (s1 :: v1)) appr2 | (_, FProj (p2,c2)) -> - let (def2, s2) = unfold_projection infos p2 c2 in - eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 (s2 :: v2)) + let s2 = unfold_projection (infos_env infos) p2 in + eqappr univ cv_pb infos appr1 (lft2, whd_stack infos c2 (s2 :: v2)) (* other constructors *) | (FLambda _, FLambda _) -> @@ -504,8 +506,8 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) - | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) - | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) + | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) + | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 98a9c8250..77201c25b 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -108,6 +108,14 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let env = check_polymorphic_instance error env auctx auctx' in env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> + (** Currently there is no way to control variance of inductive types, but + just in case we require that they are in a subtyping relation. *) + let () = + let v = Univ.ACumulativityInfo.variance cumi in + let v' = Univ.ACumulativityInfo.variance cumi' in + if not (Array.for_all2 Univ.Variance.check_subtype v' v) then + CErrors.anomaly Pp.(str "Variance mismatch for " ++ MutInd.print kn) + in let auctx = Univ.ACumulativityInfo.univ_context cumi in let auctx' = Univ.ACumulativityInfo.univ_context cumi' in let env = check_polymorphic_instance error env auctx auctx' in diff --git a/checker/univ.ml b/checker/univ.ml index 4f3131813..ebc37bc10 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -881,14 +881,6 @@ type universe_level_subst = universe_level universe_map (** A full substitution might involve algebraic universes *) type universe_subst = universe universe_map -let level_subst_of f = - fun l -> - try let u = f l in - match Universe.level u with - | None -> l - | Some l -> l - with Not_found -> l - module Instance : sig type t = Level.t array @@ -1011,12 +1003,49 @@ end type abstract_universe_context = AUContext.t +module Variance = +struct + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + + let check_subtype x y = match x, y with + | (Irrelevant | Covariant | Invariant), Irrelevant -> true + | Irrelevant, Covariant -> false + | (Covariant | Invariant), Covariant -> true + | (Irrelevant | Covariant), Invariant -> false + | Invariant, Invariant -> true + + let leq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant -> Constraint.add (u, Le, u') csts + | Invariant -> Constraint.add (u, Eq, u') csts + + let eq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant | Invariant -> Constraint.add (u, Eq, u') csts + + let leq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 leq_constraint csts variance u u' + + let eq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 eq_constraint csts variance u u' +end + module CumulativityInfo = struct - type t = universe_context * universe_context + type t = universe_context * Variance.t array let univ_context (univcst, subtypcst) = univcst - let subtyp_context (univcst, subtypcst) = subtypcst + let variance (univs, variance) = variance end diff --git a/checker/univ.mli b/checker/univ.mli index 0eadc6801..32e48f593 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -150,8 +150,6 @@ type universe_level_subst_fn = universe_level -> universe_level type universe_subst = universe universe_map type universe_level_subst = universe_level universe_map -val level_subst_of : universe_subst_fn -> universe_level_subst_fn - (** {6 Universe instances} *) module Instance : @@ -220,12 +218,25 @@ end type abstract_universe_context = AUContext.t +module Variance : +sig + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + val check_subtype : t -> t -> bool + val leq_constraints : t array -> Instance.t constraint_function + val eq_constraints : t array -> Instance.t constraint_function +end + + module ACumulativityInfo : sig type t val univ_context : t -> abstract_universe_context - val subtyp_context : t -> abstract_universe_context + val variance : t -> Variance.t array end diff --git a/checker/validate.ml b/checker/validate.ml index 820040587..2624e6d49 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -49,8 +49,6 @@ let (/) (ctx:error_context) s : error_context = s::ctx exception ValidObjError of string * error_context * Obj.t let fail ctx o s = raise (ValidObjError(s,ctx,o)) -type func = error_context -> Obj.t -> unit - (* Check that object o is a block with tag t *) let val_tag t ctx o = if Obj.is_block o && Obj.tag o = t then () diff --git a/checker/validate.mli b/checker/validate.mli new file mode 100644 index 000000000..7eed692a0 --- /dev/null +++ b/checker/validate.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val validate : bool -> Values.value -> 'a -> unit diff --git a/checker/values.ml b/checker/values.ml index 5a371164c..283adca03 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 56ac4cade33eff3d26ed5cdadb580c7e checker/cic.mli +MD5 79ed7b5c069b1994bf1a8d2cec22bdce checker/cic.mli *) @@ -70,6 +70,8 @@ let v_map vk vd = let v_hset v = v_map Int (v_set v) let v_hmap vk vd = v_map Int (v_map vk vd) +let v_pred v = v_pair v_bool (v_set v) + (* lib/future *) let v_computation f = Annot ("Future.computation", @@ -108,10 +110,12 @@ let v_cstrs = (v_tuple "univ_constraint" [|v_level;v_enum "order_request" 3;v_level|])) +let v_variance = v_enum "variance" 3 + let v_instance = Annot ("instance", Array v_level) let v_context = v_tuple "universe_context" [|v_instance;v_cstrs|] let v_abs_context = v_context (* only for clarity *) -let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; v_context|] +let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; Array v_variance|] let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] (** kernel/term *) @@ -199,6 +203,17 @@ let v_lazy_constr = let v_impredicative_set = v_enum "impr-set" 2 let v_engagement = v_impredicative_set +let v_conv_level = + v_sum "conv_level" 2 [|[|Int|]|] + +let v_oracle = + v_tuple "oracle" [| + v_map v_id v_conv_level; + v_hmap v_cst v_conv_level; + v_pred v_id; + v_pred v_cst; + |] + let v_pol_arity = v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] @@ -213,7 +228,7 @@ let v_projbody = v_constr|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_oracle|] let v_const_univs = v_sum "constant_universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -280,16 +295,11 @@ let v_ind_pack = v_tuple "mutual_inductive_body" Opt v_bool; v_typing_flags|] -let v_with = - Sum ("with_declaration_body",0, - [|[|List v_id;v_mp|]; - [|List v_id;v_tuple "with_def" [|v_constr;v_context|]|]|]) - let rec v_mae = Sum ("module_alg_expr",0, [|[|v_mp|]; (* SEBident *) [|v_mae;v_mp|]; (* SEBapply *) - [|v_mae;v_with|] (* SEBwith *) + [|v_mae; Any|] (* SEBwith *) |]) let rec v_sfb = @@ -372,22 +382,3 @@ let v_lib = let v_opaques = Array (v_computation v_constr) let v_univopaques = Opt (Tuple ("univopaques",[|Array (v_computation v_context_set);v_context_set;v_bool|])) - -(** Registering dynamic values *) - -module IntOrd = -struct - type t = int - let compare (x : t) (y : t) = compare x y -end - -module IntMap = Map.Make(IntOrd) - -let dyn_table : value IntMap.t ref = ref IntMap.empty - -let register_dyn name t = - dyn_table := IntMap.add name t !dyn_table - -let find_dyn name = - try IntMap.find name !dyn_table - with Not_found -> Any diff --git a/checker/values.mli b/checker/values.mli new file mode 100644 index 000000000..aad8fd5f4 --- /dev/null +++ b/checker/values.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type value = + | Any + | Fail of string + | Tuple of string * value array + | Sum of string * int * value array array + | Array of value + | List of value + | Opt of value + | Int + | String + | Annot of string * value + | Dyn + +val v_univopaques : value +val v_libsum : value +val v_lib : value +val v_opaques : value +val v_stm_seg : value diff --git a/checker/votour.ml b/checker/votour.ml index b7c898232..8cb97a2b1 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -77,8 +77,8 @@ struct type obj = data - let memory = ref [||] - let sizes = ref [||] + let memory = ref LargeArray.empty + let sizes = ref LargeArray.empty (** size, in words *) let ws = Sys.word_size / 8 @@ -86,10 +86,10 @@ struct let rec init_size seen k = function | Int _ | Atm _ | Fun _ -> k 0 | Ptr p -> - if seen.(p) then k 0 + if LargeArray.get seen p then k 0 else - let () = seen.(p) <- true in - match (!memory).(p) with + let () = LargeArray.set seen p true in + match LargeArray.get !memory p with | Struct (tag, os) -> let len = Array.length os in let rec fold i accu k = @@ -97,30 +97,30 @@ struct else init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i) in - fold 0 1 (fun size -> let () = (!sizes).(p) <- size in k size) + fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size) | String s -> let size = 2 + (String.length s / ws) in - let () = (!sizes).(p) <- size in + let () = LargeArray.set !sizes p size in k size let size = function | Int _ | Atm _ | Fun _ -> 0 - | Ptr p -> (!sizes).(p) + | Ptr p -> LargeArray.get !sizes p let repr = function | Int i -> INT i | Atm t -> BLOCK (t, [||]) | Fun _ -> OTHER | Ptr p -> - match (!memory).(p) with + match LargeArray.get !memory p with | Struct (tag, os) -> BLOCK (tag, os) | String s -> STRING s let input ch = let obj, mem = parse_channel ch in let () = memory := mem in - let () = sizes := Array.make (Array.length mem) (-1) in - let seen = Array.make (Array.length mem) false in + let () = sizes := LargeArray.make (LargeArray.length mem) (-1) in + let seen = LargeArray.make (LargeArray.length mem) false in let () = init_size seen ignore obj in obj @@ -210,7 +210,6 @@ let access_list v o pos = let access_block o = match Repr.repr o with | BLOCK (tag, os) -> (tag, os) | _ -> raise Exit -let access_int o = match Repr.repr o with INT i -> i | _ -> raise Exit (** raises Exit if the object has not the expected structure *) exception Forbidden @@ -249,8 +248,7 @@ let rec get_children v o pos = match v with |Dyn -> begin match Repr.repr o with | BLOCK (0, [|id; o|]) -> - let n = access_int id in - let tpe = find_dyn n in + let tpe = Any in [|(Int, id, 0 :: pos); (tpe, o, 1 :: pos)|] | _ -> raise Exit end @@ -395,7 +393,7 @@ let visit_vo f = | None -> () done -let main = +let () = if not !Sys.interactive then Arg.parse [] visit_vo ("votour: guided tour of a Coq .vo or .vi file\n"^ diff --git a/checker/votour.mli b/checker/votour.mli new file mode 100644 index 000000000..e1555ba2e --- /dev/null +++ b/checker/votour.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/lib/backtrace.ml b/clib/backtrace.ml index be9f40c1f..be9f40c1f 100644 --- a/lib/backtrace.ml +++ b/clib/backtrace.ml diff --git a/lib/backtrace.mli b/clib/backtrace.mli index dd82165b6..dd82165b6 100644 --- a/lib/backtrace.mli +++ b/clib/backtrace.mli diff --git a/lib/bigint.ml b/clib/bigint.ml index 4f8b95d59..4f8b95d59 100644 --- a/lib/bigint.ml +++ b/clib/bigint.ml diff --git a/lib/bigint.mli b/clib/bigint.mli index 2a5a5f122..2a5a5f122 100644 --- a/lib/bigint.mli +++ b/clib/bigint.mli diff --git a/lib/cArray.ml b/clib/cArray.ml index 013585735..013585735 100644 --- a/lib/cArray.ml +++ b/clib/cArray.ml diff --git a/lib/cArray.mli b/clib/cArray.mli index 325ff8edc..325ff8edc 100644 --- a/lib/cArray.mli +++ b/clib/cArray.mli diff --git a/lib/cEphemeron.ml b/clib/cEphemeron.ml index 8b253a790..8b253a790 100644 --- a/lib/cEphemeron.ml +++ b/clib/cEphemeron.ml diff --git a/lib/cEphemeron.mli b/clib/cEphemeron.mli index d8a1f2757..d8a1f2757 100644 --- a/lib/cEphemeron.mli +++ b/clib/cEphemeron.mli diff --git a/lib/cList.ml b/clib/cList.ml index ca69628af..627a3e3e0 100644 --- a/lib/cList.ml +++ b/clib/cList.ml @@ -62,6 +62,7 @@ sig val fold_right_and_left : ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a + val fold_left2_set : exn -> ('a -> 'b -> 'c -> 'b list -> 'c list -> 'a) -> 'a -> 'b list -> 'c list -> 'a val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool val except : 'a eq -> 'a -> 'a list -> 'a list val remove : 'a eq -> 'a -> 'a list -> 'a list @@ -96,6 +97,8 @@ sig val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list @@ -446,6 +449,12 @@ let rec fold_left3 f accu l1 l2 l3 = | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3 | (_, _, _) -> invalid_arg "List.fold_left3" +let rec fold_left4 f accu l1 l2 l3 l4 = + match (l1, l2, l3, l4) with + ([], [], [], []) -> accu + | (a1::l1, a2::l2, a3::l3, a4::l4) -> fold_left4 f (f accu a1 a2 a3 a4) l1 l2 l3 l4 + | (_,_, _, _) -> invalid_arg "List.fold_left4" + (* [fold_right_and_left f [a1;...;an] hd = f (f (... (f (f hd an @@ -464,6 +473,19 @@ let fold_right_and_left f l hd = | a::l -> let hd = aux (a::tl) l in f hd a tl in aux [] l +(* Match sets as lists according to a matching function, also folding a side effect *) +let rec fold_left2_set e f x l1 l2 = + match l1 with + | a1::l1 -> + let rec find seen = function + | [] -> raise e + | a2::l2 -> + try fold_left2_set e f (f x a1 a2 l1 l2) l1 (List.rev_append seen l2) + with e' when e' = e -> find (a2::seen) l2 in + find [] l2 + | [] -> + if l2 = [] then x else raise e + let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l let for_all_i p = @@ -765,12 +787,13 @@ let share_tails l1 l2 = in shr_rev [] (List.rev l1, List.rev l2) +(* Poor man's monadic map *) let rec fold_left_map f e = function - | [] -> (e,[]) - | h::t -> - let e',h' = f e h in - let e'',t' = fold_left_map f e' t in - e'',h'::t' + | [] -> (e,[]) + | h::t -> + let e',h' = f e h in + let e'',t' = fold_left_map f e' t in + e'',h'::t' let fold_map = fold_left_map @@ -790,12 +813,26 @@ let fold_right_map f l e = let fold_map' = fold_right_map +let on_snd f (x,y) = (x,f y) + let fold_left2_map f e l l' = - List.fold_left2 (fun (e,l) x x' -> let (e,y) = f e x x' in (e,y::l)) (e,[]) l l' + on_snd List.rev @@ + List.fold_left2 (fun (e,l) x x' -> + let (e,y) = f e x x' in + (e, y::l) + ) (e, []) l l' let fold_right2_map f l l' e = List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) +let fold_left3_map f e l l' l'' = + on_snd List.rev @@ + fold_left3 (fun (e,l) x x' x'' -> let (e,y) = f e x x' x'' in (e,y::l)) (e,[]) l l' l'' + +let fold_left4_map f e l1 l2 l3 l4 = + on_snd List.rev @@ + fold_left4 (fun (e,l) x1 x2 x3 x4 -> let (e,y) = f e x1 x2 x3 x4 in (e,y::l)) (e,[]) l1 l2 l3 l4 + let map_assoc f = List.map (fun (x,a) -> (x,f a)) let rec assoc_f f a = function diff --git a/lib/cList.mli b/clib/cList.mli index 8cb07da79..b3ee28548 100644 --- a/lib/cList.mli +++ b/clib/cList.mli @@ -121,6 +121,14 @@ sig val fold_right_and_left : ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a + + (** Fold sets, i.e. lists up to order; the folding function tells + when elements match by returning a value and raising the given + exception otherwise; sets should have the same size; raise the + given exception if no pairing of the two sets is found;; + complexity in O(n^2) *) + val fold_left2_set : exn -> ('a -> 'b -> 'c -> 'b list -> 'c list -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool val except : 'a eq -> 'a -> 'a list -> 'a list val remove : 'a eq -> 'a -> 'a list -> 'a list @@ -211,7 +219,14 @@ sig val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a (** Same with two lists, folding on the right *) + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + (** Same with three lists, folding on the left *) + + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list + (** Same with four lists, folding on the left *) + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (* [@@ocaml.deprecated "Same as [fold_left_map]"] *) (** @deprecated Same as [fold_left_map] *) val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a diff --git a/lib/cMap.ml b/clib/cMap.ml index 0ecb40209..b4c4aedd0 100644 --- a/lib/cMap.ml +++ b/clib/cMap.ml @@ -26,7 +26,7 @@ sig include CSig.MapS module Set : CSig.SetS with type elt = key val get : key -> 'a t -> 'a - val update : key -> 'a -> 'a t -> 'a t + val set : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t val domain : 'a t -> Set.t val bind : (key -> 'a) -> Set.t -> 'a t @@ -50,7 +50,7 @@ end module MapExt (M : Map.OrderedType) : sig type 'a map = 'a Map.Make(M).t - val update : M.t -> 'a -> 'a map -> 'a map + val set : M.t -> 'a -> 'a map -> 'a map val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map val domain : 'a map -> Set.Make(M).t val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map @@ -93,19 +93,19 @@ struct let set_prj : set -> _set = Obj.magic let set_inj : _set -> set = Obj.magic - let rec update k v (s : 'a map) : 'a map = match map_prj s with + let rec set k v (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found | MNode (l, k', v', r, h) -> let c = M.compare k k' in if c < 0 then - let l' = update k v l in + let l' = set k v l in if l == l' then s else map_inj (MNode (l', k', v', r, h)) else if c = 0 then if v' == v then s else map_inj (MNode (l, k', v, r, h)) else - let r' = update k v r in + let r' = set k v r in if r == r' then s else map_inj (MNode (l, k', v', r', h)) diff --git a/lib/cMap.mli b/clib/cMap.mli index f65036139..5e65bd200 100644 --- a/lib/cMap.mli +++ b/clib/cMap.mli @@ -34,7 +34,7 @@ sig val get : key -> 'a t -> 'a (** Same as {!find} but fails an assertion instead of raising [Not_found] *) - val update : key -> 'a -> 'a t -> 'a t + val set : key -> 'a -> 'a t -> 'a t (** Same as [add], but expects the key to be present, and thus faster. @raise Not_found when the key is unbound in the map. *) diff --git a/lib/cObj.ml b/clib/cObj.ml index 7f3ee1855..7f3ee1855 100644 --- a/lib/cObj.ml +++ b/clib/cObj.ml diff --git a/lib/cObj.mli b/clib/cObj.mli index 16933a4aa..16933a4aa 100644 --- a/lib/cObj.mli +++ b/clib/cObj.mli diff --git a/lib/cSet.ml b/clib/cSet.ml index ed65edf16..ed65edf16 100644 --- a/lib/cSet.ml +++ b/clib/cSet.ml diff --git a/lib/cSet.mli b/clib/cSet.mli index 2eb9bce86..2eb9bce86 100644 --- a/lib/cSet.mli +++ b/clib/cSet.mli diff --git a/lib/cSig.mli b/clib/cSig.mli index 6910cbbf0..32e9d2af0 100644 --- a/lib/cSig.mli +++ b/clib/cSig.mli @@ -56,6 +56,12 @@ sig val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t + (* when Coq requires OCaml 4.06 or later, can add: + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + + allowing Coq to use OCaml's "update" + *) val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: diff --git a/lib/cStack.ml b/clib/cStack.ml index 4acb2930c..4acb2930c 100644 --- a/lib/cStack.ml +++ b/clib/cStack.ml diff --git a/lib/cStack.mli b/clib/cStack.mli index 8dde1d1a1..8dde1d1a1 100644 --- a/lib/cStack.mli +++ b/clib/cStack.mli diff --git a/lib/cString.ml b/clib/cString.ml index f2242460e..f2242460e 100644 --- a/lib/cString.ml +++ b/clib/cString.ml diff --git a/lib/cString.mli b/clib/cString.mli index 29d3a4499..29d3a4499 100644 --- a/lib/cString.mli +++ b/clib/cString.mli diff --git a/lib/cThread.ml b/clib/cThread.ml index 0221e690e..0221e690e 100644 --- a/lib/cThread.ml +++ b/clib/cThread.ml diff --git a/lib/cThread.mli b/clib/cThread.mli index 66f039bb5..66f039bb5 100644 --- a/lib/cThread.mli +++ b/clib/cThread.mli diff --git a/lib/cUnix.ml b/clib/cUnix.ml index 34fb660db..34fb660db 100644 --- a/lib/cUnix.ml +++ b/clib/cUnix.ml diff --git a/lib/cUnix.mli b/clib/cUnix.mli index d08dc4c40..d08dc4c40 100644 --- a/lib/cUnix.mli +++ b/clib/cUnix.mli diff --git a/lib/canary.ml b/clib/canary.ml index 0ed1d28f3..0ed1d28f3 100644 --- a/lib/canary.ml +++ b/clib/canary.ml diff --git a/lib/canary.mli b/clib/canary.mli index 904b88213..904b88213 100644 --- a/lib/canary.mli +++ b/clib/canary.mli diff --git a/lib/clib.mllib b/clib/clib.mllib index 5c1f7d9af..0b5d9826f 100644 --- a/lib/clib.mllib +++ b/clib/clib.mllib @@ -1,37 +1,39 @@ -Coq_config - -Terminal Canary -Hook +CObj +CEphemeron + Hashset Hashcons + CSet CMap +CList +CString +CStack + Int -Dyn +Range HMap +Bigint + +CArray Option +CUnix + +Segmenttree +Unicodetable +Unicode +Minisys +CThread +Trie +Predicate +Heap +Unionfind + +Dyn Store Exninfo Backtrace IStream -Flags -Control -Loc -CAst -DAst -CList -CString -Deque -CObj -CArray -CStack -Util -Stateid -Pp -Feedback -CUnix -Envars -Aux_file +Terminal Monad -CoqProject_file diff --git a/lib/deque.ml b/clib/deque.ml index 373269b4f..373269b4f 100644 --- a/lib/deque.ml +++ b/clib/deque.ml diff --git a/lib/deque.mli b/clib/deque.mli index 23cb1e491..23cb1e491 100644 --- a/lib/deque.mli +++ b/clib/deque.mli diff --git a/lib/dyn.ml b/clib/dyn.ml index 83e673d2c..64535d35f 100644 --- a/lib/dyn.ml +++ b/clib/dyn.ml @@ -55,6 +55,8 @@ sig include PreS module Easy : sig + + val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag val make_dyn : string -> ('a -> t) * (t -> 'a) val inj : 'a -> 'a tag -> t val prj : t -> 'a tag -> 'a option @@ -129,8 +131,9 @@ end include Self module Easy = struct + (* now tags are opaque, we can do the trick *) -let make_dyn (s : string) = +let make_dyn_tag (s : string) = (fun (type a) (tag : a tag) -> let infun : (a -> t) = fun x -> Dyn (tag, x) in let outfun : (t -> a) = fun (Dyn (t, x)) -> @@ -138,9 +141,12 @@ let make_dyn (s : string) = | None -> assert false | Some CSig.Refl -> x in - (infun, outfun)) + infun, outfun, tag) (create s) +let make_dyn (s : string) = + let inf, outf, _ = make_dyn_tag s in inf, outf + let inj x tag = Dyn(tag,x) let prj : type a. t -> a tag -> a option = fun (Dyn(tag',x)) tag -> diff --git a/lib/dyn.mli b/clib/dyn.mli index e0e1a9d14..2206394e2 100644 --- a/lib/dyn.mli +++ b/clib/dyn.mli @@ -53,6 +53,7 @@ val dump : unit -> (int * string) list module Easy : sig (* To create a dynamic type on the fly *) + val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag val make_dyn : string -> ('a -> t) * (t -> 'a) (* For types declared with the [create] function above *) diff --git a/lib/exninfo.ml b/clib/exninfo.ml index 167d3d6dc..167d3d6dc 100644 --- a/lib/exninfo.ml +++ b/clib/exninfo.ml diff --git a/lib/exninfo.mli b/clib/exninfo.mli index c960ac7c0..c960ac7c0 100644 --- a/lib/exninfo.mli +++ b/clib/exninfo.mli diff --git a/lib/hMap.ml b/clib/hMap.ml index c69efdb71..37079af78 100644 --- a/lib/hMap.ml +++ b/clib/hMap.ml @@ -47,7 +47,7 @@ struct try let m = Int.Map.find h s in let m = Set.add x m in - Int.Map.update h m s + Int.Map.set h m s with Not_found -> let m = Set.singleton x in Int.Map.add h m s @@ -65,7 +65,7 @@ struct if Set.is_empty m then Int.Map.remove h s else - Int.Map.update h m s + Int.Map.set h m s with Not_found -> s let height s = Int.Map.height s @@ -135,7 +135,7 @@ struct let s' = Int.Map.find h accu in let si = Set.filter (fun e -> not (Set.mem e s)) s' in if Set.is_empty si then Int.Map.remove h accu - else Int.Map.update h si accu + else Int.Map.set h si accu with Not_found -> accu in Int.Map.fold fold s2 s1 @@ -242,11 +242,19 @@ struct try let m = Int.Map.find h s in let m = Map.add k x m in - Int.Map.update h m s + Int.Map.set h m s with Not_found -> let m = Map.singleton k x in Int.Map.add h m s + (* when Coq requires OCaml 4.06 or later, the module type + CSig.MapS may include the signature of OCaml's "update", + requiring an implementation here, which could be just: + + let update k f s = assert false (* not implemented *) + + *) + let singleton k x = let h = M.hash k in Int.Map.singleton h (Map.singleton k x) @@ -259,7 +267,7 @@ struct if Map.is_empty m then Int.Map.remove h s else - Int.Map.update h m s + Int.Map.set h m s with Not_found -> s let merge f s1 s2 = @@ -359,7 +367,7 @@ struct let h = M.hash k in let m = Int.Map.find h s in let m = Map.modify k f m in - Int.Map.update h m s + Int.Map.set h m s let bind f s = let fb m = Map.bind f m in @@ -367,11 +375,11 @@ struct let domain s = Int.Map.map Map.domain s - let update k x s = + let set k x s = let h = M.hash k in let m = Int.Map.find h s in - let m = Map.update k x m in - Int.Map.update h m s + let m = Map.set k x m in + Int.Map.set h m s let smartmap f s = let fs m = Map.smartmap f m in diff --git a/lib/hMap.mli b/clib/hMap.mli index c77bfced8..c77bfced8 100644 --- a/lib/hMap.mli +++ b/clib/hMap.mli diff --git a/lib/hashcons.ml b/clib/hashcons.ml index ee2232581..ee2232581 100644 --- a/lib/hashcons.ml +++ b/clib/hashcons.ml diff --git a/lib/hashcons.mli b/clib/hashcons.mli index fbd2ebcf9..fbd2ebcf9 100644 --- a/lib/hashcons.mli +++ b/clib/hashcons.mli diff --git a/lib/hashset.ml b/clib/hashset.ml index 7f96627a6..7f96627a6 100644 --- a/lib/hashset.ml +++ b/clib/hashset.ml diff --git a/lib/hashset.mli b/clib/hashset.mli index ec79205a5..ec79205a5 100644 --- a/lib/hashset.mli +++ b/clib/hashset.mli diff --git a/lib/heap.ml b/clib/heap.ml index a6109972d..a6109972d 100644 --- a/lib/heap.ml +++ b/clib/heap.ml diff --git a/lib/heap.mli b/clib/heap.mli index 93d504c5a..93d504c5a 100644 --- a/lib/heap.mli +++ b/clib/heap.mli diff --git a/lib/iStream.ml b/clib/iStream.ml index d3a54332a..d3a54332a 100644 --- a/lib/iStream.ml +++ b/clib/iStream.ml diff --git a/lib/iStream.mli b/clib/iStream.mli index cd7940e8d..cd7940e8d 100644 --- a/lib/iStream.mli +++ b/clib/iStream.mli diff --git a/lib/int.ml b/clib/int.ml index 63f62154d..63f62154d 100644 --- a/lib/int.ml +++ b/clib/int.ml diff --git a/lib/int.mli b/clib/int.mli index b65367f7d..b65367f7d 100644 --- a/lib/int.mli +++ b/clib/int.mli diff --git a/lib/minisys.ml b/clib/minisys.ml index 389b18ad4..389b18ad4 100644 --- a/lib/minisys.ml +++ b/clib/minisys.ml diff --git a/lib/monad.ml b/clib/monad.ml index 2e55e9698..2e55e9698 100644 --- a/lib/monad.ml +++ b/clib/monad.ml diff --git a/lib/monad.mli b/clib/monad.mli index 7b0a3e600..7b0a3e600 100644 --- a/lib/monad.mli +++ b/clib/monad.mli diff --git a/lib/option.ml b/clib/option.ml index 98b168035..98b168035 100644 --- a/lib/option.ml +++ b/clib/option.ml diff --git a/lib/option.mli b/clib/option.mli index 66f05023f..66f05023f 100644 --- a/lib/option.mli +++ b/clib/option.mli diff --git a/lib/predicate.ml b/clib/predicate.ml index 1aa7db6af..1aa7db6af 100644 --- a/lib/predicate.ml +++ b/clib/predicate.ml diff --git a/lib/predicate.mli b/clib/predicate.mli index cee3b0bd3..cee3b0bd3 100644 --- a/lib/predicate.mli +++ b/clib/predicate.mli diff --git a/clib/range.ml b/clib/range.ml new file mode 100644 index 000000000..86a078633 --- /dev/null +++ b/clib/range.ml @@ -0,0 +1,91 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type 'a tree = +| Leaf of 'a +| Node of 'a * 'a tree * 'a tree + +type 'a t = Nil | Cons of int * 'a tree * 'a t + +let oob () = invalid_arg "index out of bounds" + +let empty = Nil + +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 is_empty = function +| Nil -> true +| _ -> false + +let rec tree_get h t i = match t with +| Leaf x -> + if i = 0 then x else oob () +| Node (x, t1, t2) -> + if i = 0 then x + else + let h = h / 2 in + if i <= h then tree_get h t1 (i - 1) else tree_get h t2 (i - h - 1) + +let rec get l i = match l with +| Nil -> oob () +| Cons (h, t, rem) -> + if i < h then tree_get h t i else get rem (i - h) + +let length l = + let rec length accu = function + | Nil -> accu + | Cons (h, _, l) -> length (h + accu) l + in + length 0 l + +let rec tree_map f = function +| Leaf x -> Leaf (f x) +| Node (x, t1, t2) -> Node (f x, tree_map f t1, tree_map f t2) + +let rec map f = function +| Nil -> Nil +| Cons (h, t, l) -> Cons (h, tree_map f t, map f l) + +let rec tree_fold_left f accu = function +| Leaf x -> f accu x +| Node (x, t1, t2) -> + tree_fold_left f (tree_fold_left f (f accu x) t1) t2 + +let rec fold_left f accu = function +| Nil -> accu +| Cons (_, t, l) -> fold_left f (tree_fold_left f accu t) l + +let rec tree_fold_right f t accu = match t with +| Leaf x -> f x accu +| Node (x, t1, t2) -> + f x (tree_fold_right f t1 (tree_fold_right f t2 accu)) + +let rec fold_right f l accu = match l with +| Nil -> accu +| Cons (_, t, l) -> tree_fold_right f t (fold_right f l accu) + +let hd = function +| Nil -> failwith "hd" +| Cons (_, Leaf x, _) -> x +| Cons (_, Node (x, _, _), _) -> x + +let tl = function +| Nil -> failwith "tl" +| Cons (_, Leaf _, l) -> l +| Cons (h, Node (_, t1, t2), l) -> + let h = h / 2 in + Cons (h, t1, Cons (h, t2, l)) + +let rec skipn n l = + if n = 0 then l + else if is_empty l then failwith "List.skipn" + else skipn (pred n) (tl l) diff --git a/clib/range.mli b/clib/range.mli new file mode 100644 index 000000000..ae7684ffa --- /dev/null +++ b/clib/range.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Skewed lists + + This is a purely functional datastructure isomorphic to usual lists, except + that it features a O(log n) lookup while preserving the O(1) cons operation. + +*) + +(** {5 Constructors} *) + +type +'a t + +val empty : 'a t +val cons : 'a -> 'a t -> 'a t + +(** {5 List operations} *) + +val is_empty : 'a t -> bool +val length : 'a t -> int +val map : ('a -> 'b) -> 'a t -> 'b t +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b +val hd : 'a t -> 'a +val tl : 'a t -> 'a t + +val skipn : int -> 'a t -> 'a t + +(** {5 Indexing operations} *) + +val get : 'a t -> int -> 'a diff --git a/lib/segmenttree.ml b/clib/segmenttree.ml index d0ded4cb5..d0ded4cb5 100644 --- a/lib/segmenttree.ml +++ b/clib/segmenttree.ml diff --git a/lib/segmenttree.mli b/clib/segmenttree.mli index e274a6fdc..e274a6fdc 100644 --- a/lib/segmenttree.mli +++ b/clib/segmenttree.mli diff --git a/lib/store.ml b/clib/store.ml index 97a8fea08..97a8fea08 100644 --- a/lib/store.ml +++ b/clib/store.ml diff --git a/lib/store.mli b/clib/store.mli index 5cc5bb859..5cc5bb859 100644 --- a/lib/store.mli +++ b/clib/store.mli diff --git a/lib/terminal.ml b/clib/terminal.ml index 34efddfbc..34efddfbc 100644 --- a/lib/terminal.ml +++ b/clib/terminal.ml diff --git a/lib/terminal.mli b/clib/terminal.mli index b1b76e6e2..b1b76e6e2 100644 --- a/lib/terminal.mli +++ b/clib/terminal.mli diff --git a/lib/trie.ml b/clib/trie.ml index 0b0ba2761..0b0ba2761 100644 --- a/lib/trie.ml +++ b/clib/trie.ml diff --git a/lib/trie.mli b/clib/trie.mli index a87acc8a6..a87acc8a6 100644 --- a/lib/trie.mli +++ b/clib/trie.mli diff --git a/lib/unicode.ml b/clib/unicode.ml index f193c4e0f..f193c4e0f 100644 --- a/lib/unicode.ml +++ b/clib/unicode.ml diff --git a/lib/unicode.mli b/clib/unicode.mli index 32ffbb8e9..32ffbb8e9 100644 --- a/lib/unicode.mli +++ b/clib/unicode.mli diff --git a/lib/unicodetable.ml b/clib/unicodetable.ml index b607058c6..b607058c6 100644 --- a/lib/unicodetable.ml +++ b/clib/unicodetable.ml diff --git a/lib/unionfind.ml b/clib/unionfind.ml index f9c92d6a8..f9c92d6a8 100644 --- a/lib/unionfind.ml +++ b/clib/unionfind.ml diff --git a/lib/unionfind.mli b/clib/unionfind.mli index b242232ed..b242232ed 100644 --- a/lib/unionfind.mli +++ b/clib/unionfind.mli diff --git a/config/coq_config.mli b/config/coq_config.mli index 6a834a304..5f9ebdc1a 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -28,11 +28,10 @@ val ocamllex : string val camlbin : string (* base directory of OCaml binaries *) val camllib : string (* for Dynlink *) -val camlp4 : string (* exact name of camlp4: either "camlp4" ou "camlp5" *) -val camlp4o : string (* name of the camlp4o/camlp5o executable *) -val camlp4bin : string (* base directory for Camlp4/5 binaries *) -val camlp4lib : string (* where is the library of Camlp4 *) -val camlp4compat : string (* compatibility argument to camlp4/5 *) +val camlp5o : string (* name of the camlp5o executable *) +val camlp5bin : string (* base directory for camlp5 binaries *) +val camlp5lib : string (* where is the library of camlp5 *) +val camlp5compat : string (* compatibility argument to camlp5 *) val coqideincl : string (* arguments for building coqide (e.g. lablgtk) *) val cflags : string (* arguments passed to gcc *) @@ -41,12 +40,8 @@ val caml_flags : string (* arguments passed to ocamlc (ie. CAMLFLAGS) *) val best : string (* byte/opt *) val arch : string (* architecture *) val arch_is_win32 : bool -val osdeplibs : string (* OS dependent link options for ocamlc *) val vmbyteflags : string list (* -custom/-dllib -lcoqrun *) - -(* val defined : string list (* options for lib/ocamlpp *) *) - val version : string (* version number of Coq *) val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) @@ -56,7 +51,6 @@ val vo_magic_number : int val state_magic_number : int val core_src_dirs : string list -val api_dirs : string list val plugins_dirs : string list val all_src_dirs : string list @@ -80,4 +74,5 @@ val wwwbugtracker : string val wwwstdlib : string val localwwwrefman : string -val no_native_compiler : bool +val bytecode_compiler : bool +val native_compiler : bool diff --git a/configure.ml b/configure.ml index 1ccb69106..69db9407a 100644 --- a/configure.ml +++ b/configure.ml @@ -16,7 +16,7 @@ let coq_macos_version = "8.7.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8791 let state_magic = 58791 -let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; +let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] let verbose = ref false (* for debugging this script *) @@ -178,8 +178,22 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false +(** Choose a command among a list of candidates + (command name, mandatory arguments, arguments for this test). + Chooses the first one whose execution outputs a non-empty (first) line. + Dies with message [msg] if none is found. *) + +let select_command msg candidates = + let rec search = function + | [] -> die msg + | (p, x, y) :: tl -> + if fst (tryrun p (x @ y)) <> "" + then List.fold_left (Printf.sprintf "%s %s") p x + else search tl + in search candidates + (** As per bug #4828, ocamlfind on Windows/Cygwin barfs if you pass it - a quoted path to camlpXo via -pp. So we only quote camlpXo on not + a quoted path to camlp5o via -pp. So we only quote camlp5o on not Windows, and warn on Windows if the path contains spaces *) let contains_suspicious_characters str = List.fold_left (fun b ch -> String.contains str ch || b) false [' '; '\t'] @@ -262,7 +276,9 @@ module Prefs = struct let flambda_flags = ref [] let debug = ref true let profile = ref false - let annotate = ref false + let bin_annot = ref false + let annot = ref false + let bytecodecompiler = ref true let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false @@ -327,8 +343,14 @@ let args_options = Arg.align [ " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, " Add profiling information in the Coq executables"; - "-annotate", Arg.Set Prefs.annotate, - " Dumps ml annotation files while compiling Coq"; + "-annotate", Arg.Unit (fun () -> printf "*Warning* -annotate is deprecated. Please use -annot or -bin-annot instead.\n"), + " Deprecated. Please use -annot or -bin-annot instead"; + "-annot", Arg.Set Prefs.annot, + " Dumps ml text annotation files while compiling Coq (e.g. for Tuareg)"; + "-bin-annot", Arg.Set Prefs.bin_annot, + " Dumps ml binary annotation files while compiling Coq (e.g. for Merlin)"; + "-bytecode-compiler", arg_bool Prefs.bytecodecompiler, + "(yes|no) Enable Coq's bytecode reduction machine (VM)"; "-native-compiler", arg_bool Prefs.nativecompiler, "(yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, @@ -371,10 +393,8 @@ let reset_caml_find c o = c.find <- o let coq_debug_flag = if !Prefs.debug then "-g" else "" let coq_profile_flag = if !Prefs.profile then "-p" else "" -let coq_annotate_flag = - if !Prefs.annotate - then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" - else "" +let coq_annot_flag = if !Prefs.annot then "-annot" else "" +let coq_bin_annot_flag = if !Prefs.bin_annot then "-bin-annot" else "" (* This variable can be overriden only for debug purposes, use with care. *) @@ -431,6 +451,22 @@ let vcs = else if dir_exists "{arch}" then "gnuarch" else "none" +(** * Git Precommit Hook *) +let _ = + let f = ".git/hooks/pre-commit" in + if vcs = "git" && dir_exists ".git/hooks" && not (Sys.file_exists f) then begin + printf "Creating pre-commit hook in %s\n" f; + let o = open_out f in + let pr s = fprintf o s in + pr "#!/bin/sh\n"; + pr "\n"; + pr "if [ -x dev/tools/pre-commit ]; then\n"; + pr " exec dev/tools/pre-commit\n"; + pr "fi\n"; + close_out o; + Unix.chmod f 0o775 + end + (** * Browser command *) let browser = @@ -467,7 +503,7 @@ let camlbin, caml_version, camllib, findlib_version = then reset_caml_top camlexec (camlbin / "ocaml") in camlbin, caml_version, camllib, findlib_version -let camlp4compat = "-loc loc" +let camlp5compat = "-loc loc" (** Caml version as a list of string, e.g. ["4";"00";"1"] *) @@ -544,15 +580,15 @@ let coq_warn_error = (* Flags used to compile Coq and plugins (via coq_makefile) *) let caml_flags = - Printf.sprintf "-thread -rectypes %s %s %s" coq_warnings coq_annotate_flag coq_safe_string + Printf.sprintf "-thread -rectypes %s %s %s %s" coq_warnings coq_annot_flag coq_bin_annot_flag coq_safe_string (* Flags used to compile Coq but _not_ plugins (via coq_makefile) *) let coq_caml_flags = coq_warn_error -(** * CamlpX configuration *) +(** * Camlp5 configuration *) -(* Convention: we use camldir as a prioritary location for camlpX, if given *) +(* Convention: we use camldir as a prioritary location for camlp5, if given *) (* i.e., in the case of camlp5, we search for a copy of camlp5o which *) (* answers the right camlp5 lib dir *) @@ -568,7 +604,7 @@ let which_camlp5o_for camlp5lib = if fst (tryrun camlp5o ["-where"]) = camlp5lib then camlp5o else die ("Error: cannot find Camlp5 binaries corresponding to Camlp5 library " ^ camlp5lib) -let which_camlpX base = +let which_camlp5 base = let file = Filename.concat camlbin base in if is_executable file then file else which base @@ -589,7 +625,7 @@ let check_camlp5 testcma = match !Prefs.camlp5dir with in die msg | None -> try - let camlp5o = which_camlpX "camlp5o" in + let camlp5o = which_camlp5 "camlp5o" in let dir,_ = tryrun camlp5o ["-where"] in dir, camlp5o with Not_found -> @@ -603,15 +639,14 @@ let check_camlp5_version camlp5o = printf "You have Camlp5 %s. Good!\n" version; version | _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n" -let config_camlpX () = +let config_camlp5 () = let camlp5mod = "gramlib" in let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in let camlp5_version = check_camlp5_version camlp5o in - "camlp5", "Camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version + camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version -let camlpX, capitalized_camlpX, camlpXo, - camlpXbindir, fullcamlpXlibdir, - camlpXmod, camlpX_version = config_camlpX () +let camlp5o, camlp5bindir, fullcamlp5libdir, + camlp5mod, camlp5_version = config_camlp5 () let shorten_camllib s = if starts_with s (camllib^"/") then @@ -619,7 +654,7 @@ let shorten_camllib s = "+" ^ String.sub s l (String.length s - l) else s -let camlpXlibdir = shorten_camllib fullcamlpXlibdir +let camlp5libdir = shorten_camllib fullcamlp5libdir (** * Native compiler *) @@ -629,8 +664,8 @@ let msg_byteonly () = let msg_no_ocamlopt () = printf "Cannot find the OCaml native-code compiler.\n"; msg_byteonly () -let msg_no_camlpX_cmxa () = - printf "Cannot find the native-code library of %s.\n" camlpX; msg_byteonly () +let msg_no_camlp5_cmxa () = + printf "Cannot find the native-code library of camlp5.\n"; msg_byteonly () let msg_no_dynlink_cmxa () = printf "Cannot find native-code dynlink library.\n"; msg_byteonly (); @@ -642,8 +677,8 @@ let check_native () = let () = if !Prefs.byteonly then raise Not_found in let version, _ = tryrun camlexec.find ["opt";"-version"] in if version = "" then let () = msg_no_ocamlopt () in raise Not_found - else if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa")) - then let () = msg_no_camlpX_cmxa () in raise Not_found + else if not (Sys.file_exists (fullcamlp5libdir/camlp5mod^".cmxa")) + then let () = msg_no_camlp5_cmxa () in raise Not_found else if fst (tryrun camlexec.find ["query";"dynlink"]) = "" then let () = msg_no_dynlink_cmxa () in raise Not_found else @@ -666,18 +701,32 @@ let natdynlinkflag = (** * OS dependent libraries *) -let osdeplibs = "-cclib -lunix" - -let operating_system, osdeplibs = +let operating_system = if starts_with arch "sun4" then let os, _ = run "uname" ["-r"] in if starts_with os "5" then - "Sun Solaris "^os, osdeplibs^" -cclib -lnsl -cclib -lsocket" + "Sun Solaris "^os else - "Sun OS "^os, osdeplibs + "Sun OS "^os else - (try Sys.getenv "OS" with Not_found -> ""), osdeplibs + (try Sys.getenv "OS" with Not_found -> "") + +(** Num library *) + +(* since 4.06, the Num library is no longer distributed with OCaml (replaced + by Zarith) +*) + +let check_for_numlib () = + if caml_version_nums >= [4;6;0] then + let numlib,_ = tryrun camlexec.find ["query";"num"] in + match numlib with + | "" -> + die "Num library not installed, required for OCaml 4.06 or later" + | _ -> printf "You have the Num library installed. Good!\n" +let numlib = + check_for_numlib () (** * lablgtk2 and CoqIDE *) @@ -711,11 +760,11 @@ let get_lablgtkdir () = else "", msg | None -> let msg = OCamlFind in - let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in + let d1,_ = tryrun camlexec.find ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else (* In debian wheezy, ocamlfind knows only of lablgtk2 *) - let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in + let d2,_ = tryrun camlexec.find ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else let msg = Stdlib in @@ -727,24 +776,22 @@ let get_lablgtkdir () = let check_lablgtk_version src dir = match src with | Manual | Stdlib -> - let test accu f = - if accu then - let test = sprintf "grep -q -w %s %S/glib.mli" f dir in - Sys.command test = 0 - else false - in - let heuristics = [ - "convert_with_fallback"; - "wrap_poll_func"; (** Introduced in lablgtk 2.16 *) - ] in - let ans = List.fold_left test true heuristics in - if ans then printf "Warning: could not check the version of lablgtk2.\n"; - (ans, "an unknown version") + printf "Warning: could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3.\n"; + (true, "an unknown version") | OCamlFind -> - let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in + let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in try let vi = List.map s2i (numeric_prefix_list v) in - ([2; 16] <= vi, v) + if vi < [2; 16; 0] then + (false, v) + else if vi < [2; 18; 3] then + begin + (* Version 2.18.3 is known to report incorrectly as 2.18.0, and Launchpad packages report as version 2.16.0 due to a misconfigured META file; see https://bugs.launchpad.net/ubuntu/+source/lablgtk2/+bug/1577236 *) + printf "Warning: Your installed lablgtk reports as %s.\n It is possible that the installed version is actually more recent\n but reports an incorrect version. If the installed version is\n actually more recent than 2.18.3, that's fine; if it is not,\n CoqIDE will compile but may be very unstable.\n" v; + (true, "an unknown version") + end + else + (true, v) with _ -> (false, v) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -771,7 +818,7 @@ let check_coqide () = if dir = "" then set_ide No "LablGtk2 not found"; let (ok, version) = check_lablgtk_version via dir in let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in - if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); + if not ok then set_ide No (found^", but too old (required >= 2.18.3, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); @@ -798,7 +845,7 @@ let coqide_flags () = if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir; match coqide, arch with | "opt", "Darwin" when !Prefs.macintegration -> - let osxdir,_ = tryrun "ocamlfind" ["query";"lablgtkosx"] in + let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in if osxdir <> "" then begin lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir; idearchflags := "lablgtkosx.cma"; @@ -834,12 +881,6 @@ let strip = if strip = "" then "strip" else strip end -(** * md5sum command *) - -let md5sum = - if List.mem arch ["Darwin"; "FreeBSD"; "OpenBSD"] - then "md5 -q" else "md5sum" - (** * Documentation : do we have latex, hevea, ... *) @@ -985,14 +1026,13 @@ let print_summary () = pr " Operating system : %s\n" operating_system; pr " Coq VM bytecode link flags : %s\n" (String.concat " " vmbyteflags); pr " Other bytecode link flags : %s\n" custom_flag; - pr " OS dependent libraries : %s\n" osdeplibs; pr " OCaml version : %s\n" caml_version; pr " OCaml binaries in : %s\n" (esc camlbin); pr " OCaml library in : %s\n" (esc camllib); pr " OCaml flambda flags : %s\n" (String.concat " " !Prefs.flambda_flags); - pr " %s version : %s\n" capitalized_camlpX camlpX_version; - pr " %s binaries in : %s\n" capitalized_camlpX (esc camlpXbindir); - pr " %s library in : %s\n" capitalized_camlpX (esc camlpXlibdir); + pr " Camlp5 version : %s\n" camlp5_version; + pr " Camlp5 binaries in : %s\n" (esc camlp5bindir); + pr " Camlp5 library in : %s\n" (esc camlp5libdir); if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then @@ -1003,9 +1043,9 @@ let print_summary () = pr " Documentation : %s\n" (if withdoc then "All" else "None"); pr " Web browser : %s\n" browser; - pr " Coq web site : %s\n\n" !Prefs.coqwebsite; - if not !Prefs.nativecompiler then - pr " Native compiler for conversion and normalization disabled\n\n"; + pr " Coq web site : %s\n" !Prefs.coqwebsite; + pr " Bytecode VM enabled : %B\n" !Prefs.bytecodecompiler; + pr " Native Compiler enabled : %B\n\n" !Prefs.nativecompiler; if !Prefs.local then pr " Local build, no installation...\n" else @@ -1025,14 +1065,14 @@ let _ = print_summary () let write_dbg_wrapper f = safe_remove f; - let o = open_out f in + let o = open_out_bin f in (* _bin to avoid adding \r on Cygwin/Windows *) let pr s = fprintf o s in pr "#!/bin/sh\n\n"; pr "###### ocamldebug-coq : a wrapper around ocamldebug for Coq ######\n\n"; pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure #\n\n"; pr "export COQTOP=%S\n" coqtop; pr "OCAMLDEBUG=%S\n" (camlbin^"/ocamldebug"); - pr "CAMLP4LIB=%S\n\n" camlpXlibdir; + pr "CAMLP5LIB=%S\n\n" camlp5libdir; pr ". $COQTOP/dev/ocamldebug-coq.run\n"; close_out o; Unix.chmod f 0o555 @@ -1070,15 +1110,13 @@ let write_configml f = pr_s "ocamllex" camlexec.lex; pr_s "camlbin" camlbin; pr_s "camllib" camllib; - pr_s "camlp4" camlpX; - pr_s "camlp4o" camlpXo; - pr_s "camlp4bin" camlpXbindir; - pr_s "camlp4lib" camlpXlibdir; - pr_s "camlp4compat" camlp4compat; + pr_s "camlp5o" camlp5o; + pr_s "camlp5bin" camlp5bindir; + pr_s "camlp5lib" camlp5libdir; + pr_s "camlp5compat" camlp5compat; pr_s "cflags" cflags; pr_s "caml_flags" caml_flags; pr_s "best" best_compiler; - pr_s "osdeplibs" osdeplibs; pr_s "version" coq_version; pr_s "caml_version" caml_version; pr_li "caml_version_nums" caml_version_nums; @@ -1101,9 +1139,10 @@ let write_configml f = pr_s "wwwrefman" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/refman/"); pr_s "wwwstdlib" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/stdlib/"); pr_s "localwwwrefman" ("file:/" ^ docdir ^ "/html/refman"); - pr_b "no_native_compiler" (not !Prefs.nativecompiler); + pr_b "bytecode_compiler" !Prefs.bytecodecompiler; + pr_b "native_compiler" !Prefs.nativecompiler; - let core_src_dirs = [ "config"; "dev"; "kernel"; "library"; + let core_src_dirs = [ "config"; "dev"; "lib"; "clib"; "kernel"; "library"; "engine"; "pretyping"; "interp"; "parsing"; "proofs"; "tactics"; "toplevel"; "printing"; "intf"; "grammar"; "ide"; "stm"; "vernac" ] in @@ -1112,7 +1151,6 @@ let write_configml f = core_src_dirs in pr "\nlet core_src_dirs = [\n%s]\n" core_src_dirs; - pr "\nlet api_dirs = [\"API\"; \"lib\"]\n"; pr "\nlet plugins_dirs = [\n"; let plugins = Sys.readdir "plugins" in @@ -1124,7 +1162,7 @@ let write_configml f = plugins; pr "]\n"; - pr "\nlet all_src_dirs = core_src_dirs @ api_dirs @ plugins_dirs\n"; + pr "\nlet all_src_dirs = core_src_dirs @ plugins_dirs\n"; close_out o; Unix.chmod f 0o444 @@ -1196,12 +1234,11 @@ let write_makefile f = pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag; pr "# Compilation profile flag\n"; pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag; - pr "# Camlp4 : flavor, binaries, libraries ...\n"; - pr "# NB : avoid using CAMLP4LIB (conflict under Windows)\n"; - pr "CAMLP4=%s\n" camlpX; - pr "CAMLP4O=%s\n" (win_aware_quote_executable camlpXo); - pr "CAMLP4COMPAT=%s\n" camlp4compat; - pr "MYCAMLP4LIB=%S\n\n" camlpXlibdir; + pr "# Camlp5 : flavor, binaries, libraries ...\n"; + pr "# NB : avoid using CAMLP5LIB (conflict under Windows)\n"; + pr "CAMLP5O=%s\n" (win_aware_quote_executable camlp5o); + pr "CAMLP5COMPAT=%s\n" camlp5compat; + pr "MYCAMLP5LIB=%S\n\n" camlp5libdir; pr "# Your architecture\n"; pr "# Can be obtain by UNIX command arch\n"; pr "ARCH=%s\n" arch; @@ -1209,7 +1246,6 @@ let write_makefile f = pr "# Supplementary libs for some systems, currently:\n"; pr "# . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket\n"; pr "# . others : -cclib -lunix\n"; - pr "OSDEPLIBS=%s\n\n" osdeplibs; pr "# executable files extension, currently:\n"; pr "# Unix systems:\n"; pr "# Win32 systems : .exe\n"; @@ -1221,8 +1257,6 @@ let write_makefile f = pr "# Unix systems and profiling: true\n"; pr "# Unix systems and no profiling: strip\n"; pr "STRIP=%s\n\n" strip; - pr "#the command md5sum\n"; - pr "MD5SUM=%s\n\n" md5sum; pr "# LablGTK\n"; pr "COQIDEINCLUDES=%s\n\n" !lablgtkincludes; pr "# CoqIde (no/byte/opt)\n"; diff --git a/default.nix b/default.nix index 9efabdbc2..af2a13a84 100644 --- a/default.nix +++ b/default.nix @@ -36,19 +36,28 @@ stdenv.mkDerivation rec { ocaml findlib camlp5_strict + num ]) ++ (if buildIde then [ # CoqIDE dependencies ocamlPackages.lablgtk - ] else []) ++ (if doCheck then [ + ] else []) ++ (if doCheck then # Test-suite dependencies + let inherit (stdenv.lib) versionAtLeast optional; in + /* ncurses is required to build an OCaml REPL */ + optional (!versionAtLeast ocaml.version "4.07") ncurses + ++ [ python rsync which + ] else []) ++ (if lib.inNixShell then [ + ocamlPackages.merlin + ocamlPackages.ocpIndent + ocamlPackages.ocp-index ] else []); src = diff --git a/dev/README b/dev/README index b446c3e97..453f85f0d 100644 --- a/dev/README +++ b/dev/README @@ -1,4 +1,4 @@ -This directory contains informations and tools to help developing the +This directory contains information and tools to help develop the Coq system ====================== @@ -6,30 +6,30 @@ This directory contains informations and tools to help developing the Debugging and profiling (in current directory - see doc/debugging.txt) ----------------------- -ocamldebug-coq: to launch ocaml debugger +ocamldebug-coq: to launch ocaml debugger (generated by the configure script) -db: to install pretty-printers from ocaml debugger -base_db: to install raw pretty-printers from ocaml debugger +db: to install pretty-printers from ocaml debugger +base_db: to install raw pretty-printers from ocaml debugger -include: to install pretty-printers from ocaml toplevel +include: to install pretty-printers from ocaml toplevel (use with the coq Drop command) base_include: to install raw pretty-printers from ocaml toplevel -vm_printers.ml, dev_printers.ml: ML pretty-printers for debugging +vm_printers.ml, top_printers.ml: ML pretty-printers for debugging -Miscellaneous informations about the code (directory doc) +Miscellaneous information about the code (directory doc) ----------------------------------------- -changes.txt: (partial) per-version summary of the evolutions of Coq ML source -style.txt: a few style recommendations for writing Coq ML files -debugging.txt: help for debugging or profiling -universes.txt: help to debug universes -translate.txt: help to use coq translator +changes.md: (partial) per-version summary of the evolution of Coq ML source +style.txt: a few style recommendations for writing Coq ML files +debugging.md: help for debugging or profiling +universes.txt: help for debugging universes +translate.txt: help for using coq translator extensions.txt: some help about TACTIC EXTEND -header: standard header for Coq ML files -perf-analysis: analysis of perfs measured on the compilation of user contribs -cic.dtd: official dtd of the calc. of ind. constr. for im/ex-portation +header: standard header for Coq ML files +perf-analysis: analysis of perfs measured on the compilation of user contribs +cic.dtd: official dtd of the calc. of ind. constr. for im/ex-portation Documentation of ML interfaces using ocamldoc (directory ocamldoc/html) @@ -40,7 +40,11 @@ Documentation of ML interfaces using ocamldoc (directory ocamldoc/html) Other development tools (directory tools) ----------------------- +coqdev.el: helper customizations for everyday Coq development, eg + making `compile' work in subdirectories + objects.el: various development utilities at emacs level + anomaly-traces-parser.el: a .emacs-ready elisp snippet to parse location of Anomaly backtraces and jump to them conveniently from the Emacs *compilation* output. diff --git a/dev/base_include b/dev/base_include index 1da5e3ed1..350ccaa10 100644 --- a/dev/base_include +++ b/dev/base_include @@ -18,12 +18,9 @@ #directory "intf";; #directory "stm";; #directory "vernac";; -#directory "../API";; -#directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) -#load "API.cma";; #use "top_printers.ml";; #use "vm_printers.ml";; @@ -54,7 +51,7 @@ #install_printer ppvblock;; #install_printer (* bigint *) ppbigint;; #install_printer (* loc *) pploc;; -#install_printer (* substitution *) prsubst;; +#install_printer (* substitution *) ppsubst;; (* Open main files *) @@ -170,7 +167,7 @@ open Eqschemes open ExplainErr open Class -open Command +open ComDefinition open Indschemes open Ind_tables open Auto_ind_decl @@ -193,8 +190,8 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; -let parse_tac = API.Pcoq.parse_string Ltac_plugin.Pltac.tactic;; +let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac_control;; +let parse_tac = Pcoq.parse_string Ltac_plugin.Pltac.tactic;; (* build a term of type glob_constr without type-checking or resolution of implicit syntax *) @@ -232,7 +229,7 @@ let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Id.Set.empty r));; -let go () = Coqloop.loop Option.(get !Coqtop.drop_last_doc) +let go () = Coqloop.loop ~time:false ~state:Option.(get !Coqtop.drop_last_doc) let _ = print_string diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index cfcc09b32..dc33838f1 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -25,4 +25,4 @@ mkdir -p _build # Temporary countermeasure to hdiutil error 5341 # head -c9703424 /dev/urandom > $DMGDIR/.padding -hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO _build/CoqIDE_$VERSION.dmg +hdiutil create -imagekey zlib-level=9 -volname coq-$VERSION-installer-macos -srcfolder $DMGDIR -ov -format UDZO _build/coq-$VERSION-installer-macos.dmg diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index f91b301b8..665d54176 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -345,7 +345,7 @@ IF "%COQREGTESTING%" == "Y" ( SET "EXTRAPACKAGES= " IF NOT "%APPVEYOR%" == "True" ( - SET EXTRAPACKAGES="-P wget,curl,git,gcc-core,gcc-g++,automake1.5" + SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 ) IF "%RUNSETUP%"=="Y" ( diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt index a6d8e4462..7e80e33c6 100644 --- a/dev/build/windows/ReadMe.txt +++ b/dev/build/windows/ReadMe.txt @@ -418,7 +418,6 @@ Binary file ./bin/coqchk.exe matches Binary file ./bin/coqdep.exe matches Binary file ./bin/coqdoc.exe matches Binary file ./bin/coqide.exe matches -Binary file ./bin/coqmktop.exe matches Binary file ./bin/coqtop.byte.exe matches Binary file ./bin/coqtop.exe matches Binary file ./bin/coqworkmgr.exe matches @@ -438,7 +437,6 @@ Binary file ./bin/ocamldoc.exe matches Binary file ./bin/ocamldoc.opt.exe matches Binary file ./bin/ocamlfind.exe matches Binary file ./bin/ocamlmklib.exe matches -Binary file ./bin/ocamlmktop.exe matches Binary file ./bin/ocamlobjinfo.exe matches Binary file ./bin/ocamlopt.exe matches Binary file ./bin/ocamlopt.opt.exe matches diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index f12cbe0a7..d8cde39f8 100644 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -794,8 +794,8 @@ function make_ocaml { # TODO: this might not work if PREFIX contains spaces sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile - # We don't want to mess up Coq's dirctory structure so put the OCaml library in a separate folder - # If we refer to the make variable ${PREFIX} below, camlp4 ends up having a wrong path: + # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder + # If we refer to the make variable ${PREFIX} below, camlp5 ends up having the wrong path: # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 # So we put an explicit path in there @@ -1087,7 +1087,7 @@ function copy_coq_license { install -D README "$PREFIXCOQ/license_readme/coq/ReadMe.txt" || true install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" || true install -D README.win "$PREFIXCOQ/license_readme/coq/ReadMeWindows.txt" || true - install -D README.doc "$PREFIXCOQ/license_readme/coq/ReadMeDoc.txt" + install -D README.doc "$PREFIXCOQ/license_readme/coq/ReadMeDoc.txt" || true install -D CHANGES "$PREFIXCOQ/license_readme/coq/Changes.txt" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" install -D INSTALL.doc "$PREFIXCOQ/license_readme/coq/InstallDoc.txt" @@ -1174,7 +1174,7 @@ function make_mingw_make { if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then # The config.h.win32 file is fine - don't edit it # We need to copy the mingw gcc here as "gcc" - then the batch file will use it - cp /usr/bin/${ARCH}-w64-mingw32-gcc-5.4.0.exe ./gcc.exe + cp /usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe ./gcc.exe # By some magic cygwin bash can run batch files logn build ./build_w32.bat gcc # Copy make to Coq folder diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi index b88aa066d..2c2f0fa47 100644 --- a/dev/build/windows/patches_coq/coq_new.nsi +++ b/dev/build/windows/patches_coq/coq_new.nsi @@ -15,7 +15,7 @@ SetCompressor lzma !define MY_PRODUCT "Coq" ;Define your own software name here -!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" +!define OUTFILE "coq-${VERSION}-installer-windows-${ARCH}.exe" !include "MUI2.nsh" !include "FileAssociation.nsh" @@ -188,7 +188,7 @@ SectionEnd Section "Uninstall" ; Files and folders RMDir /r "$INSTDIR\bin" - RMDir /r "$INSTDIR\dev" + RMDir /r "$INSTDIR\doc" RMDir /r "$INSTDIR\etc" RMDir /r "$INSTDIR\lib" RMDir /r "$INSTDIR\libocaml" diff --git a/dev/ci/README.md b/dev/ci/README.md index f4423558c..bb13587e9 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -103,6 +103,8 @@ The process to merge your PR is then to submit PRs to the external development repositories, merge the latter first (if the fixes are backward-compatible), drop the overlay commit and merge the PR on Coq then. +See also [`test-suite/README.md`](/test-suite/README.md) for information about adding new tests to the test-suite. + Travis specific information --------------------------- diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat index e2fbf1f6d..dec6f0d18 100644 --- a/dev/ci/appveyor.bat +++ b/dev/ci/appveyor.bat @@ -25,7 +25,7 @@ if %USEOPAM% == false ( -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ -setup %CYGROOT%\%SETUP% || GOTO ErrorExit copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit - 7z a coq-opensource-archive-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit + 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit ) if %USEOPAM% == true ( @@ -37,5 +37,5 @@ if %USEOPAM% == true ( GOTO :EOF :ErrorExit - ECHO ERROR MakeCoq_MinGW.bat failed + ECHO ERROR %0 failed EXIT /b 1 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 168a34e6e..48e01e9e9 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -4,140 +4,149 @@ # Maybe we should just use Ruby to have real objects... +# : "${foo:=bar}" sets foo to "bar" if it is unset or null + ######################################################################## # MathComp ######################################################################## -: ${mathcomp_CI_BRANCH:=master} -: ${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git} +: "${mathcomp_CI_BRANCH:=master}" +: "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git}" ######################################################################## # UniMath ######################################################################## -: ${UniMath_CI_BRANCH:=master} -: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git} +: "${UniMath_CI_BRANCH:=master}" +: "${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git}" ######################################################################## # Unicoq + Metacoq ######################################################################## -: ${unicoq_CI_BRANCH:=master} -: ${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git} +: "${unicoq_CI_BRANCH:=master}" +: "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git}" -: ${metacoq_CI_BRANCH:=master} -: ${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git} +: "${metacoq_CI_BRANCH:=master}" +: "${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git}" ######################################################################## # Mathclasses + Corn ######################################################################## -: ${math_classes_CI_BRANCH:=master} -: ${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git} +: "${math_classes_CI_BRANCH:=master}" +: "${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git}" -: ${Corn_CI_BRANCH:=master} -: ${Corn_CI_GITURL:=https://github.com/c-corn/corn.git} +: "${Corn_CI_BRANCH:=master}" +: "${Corn_CI_GITURL:=https://github.com/c-corn/corn.git}" ######################################################################## # Iris ######################################################################## -: ${stdpp_CI_BRANCH:=master} -: ${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git} +: "${stdpp_CI_BRANCH:=master}" +: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git}" -: ${Iris_CI_BRANCH:=master} -: ${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git} +: "${Iris_CI_BRANCH:=master}" +: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git}" -: ${lambdaRust_CI_BRANCH:=master} -: ${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/FP/LambdaRust-coq.git} +: "${lambdaRust_CI_BRANCH:=master}" +: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/FP/LambdaRust-coq.git}" ######################################################################## # HoTT ######################################################################## -: ${HoTT_CI_BRANCH:=master} -: ${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git} +: "${HoTT_CI_BRANCH:=master}" +: "${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git}" ######################################################################## # Ltac2 ######################################################################## -: ${ltac2_CI_BRANCH:=master} -: ${ltac2_CI_GITURL:=https://github.com/ppedrot/ltac2.git} +: "${ltac2_CI_BRANCH:=master}" +: "${ltac2_CI_GITURL:=https://github.com/ppedrot/ltac2.git}" ######################################################################## # GeoCoq ######################################################################## -: ${GeoCoq_CI_BRANCH:=master} -: ${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq.git} +: "${GeoCoq_CI_BRANCH:=master}" +: "${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq.git}" ######################################################################## # Flocq ######################################################################## -: ${Flocq_CI_BRANCH:=master} -: ${Flocq_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git} +: "${Flocq_CI_BRANCH:=master}" +: "${Flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq.git}" ######################################################################## # Coquelicot ######################################################################## -: ${Coquelicot_CI_BRANCH:=master} -: ${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git} +: "${Coquelicot_CI_BRANCH:=master}" +: "${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git}" ######################################################################## # CompCert ######################################################################## -: ${CompCert_CI_BRANCH:=master} -: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} +: "${CompCert_CI_BRANCH:=master}" +: "${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git}" ######################################################################## # VST ######################################################################## -: ${VST_CI_BRANCH:=master} -: ${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git} +: "${VST_CI_BRANCH:=master}" +: "${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git}" ######################################################################## # fiat_parsers ######################################################################## -: ${fiat_parsers_CI_BRANCH:=master} -: ${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git} +: "${fiat_parsers_CI_BRANCH:=master}" +: "${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git}" ######################################################################## # fiat_crypto ######################################################################## -: ${fiat_crypto_CI_BRANCH:=master} -: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git} +: "${fiat_crypto_CI_BRANCH:=master}" +: "${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git}" ######################################################################## # formal-topology ######################################################################## -: ${formal_topology_CI_BRANCH:=ci} -: ${formal_topology_CI_GITURL:=https://github.com/bmsherman/topology.git} +: "${formal_topology_CI_BRANCH:=ci}" +: "${formal_topology_CI_GITURL:=https://github.com/bmsherman/topology.git}" ######################################################################## # coq-dpdgraph ######################################################################## -: ${coq_dpdgraph_CI_BRANCH:=coq-trunk} -: ${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph.git} +: "${coq_dpdgraph_CI_BRANCH:=coq-trunk}" +: "${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph.git}" ######################################################################## # CoLoR ######################################################################## -: ${Color_CI_SVNURL:=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color} +: "${CoLoR_CI_BRANCH:=master}" +: "${CoLoR_CI_GITURL:=https://github.com/fblanqui/color.git}" ######################################################################## # SF ######################################################################## -: ${sf_lf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/lf-current/lf.tgz} -: ${sf_plf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/plf-current/plf.tgz} -: ${sf_vfa_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/vfa-current/vfa.tgz} +: "${sf_lf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/lf-current/lf.tgz}" +: "${sf_plf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/plf-current/plf.tgz}" +: "${sf_vfa_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/vfa-current/vfa.tgz}" ######################################################################## # TLC ######################################################################## -: ${tlc_CI_BRANCH:=master} -: ${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git} +: "${tlc_CI_BRANCH:=master}" +: "${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git}" ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=master} -: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} +: "${bignums_CI_BRANCH:=master}" +: "${bignums_CI_GITURL:=https://github.com/coq/bignums.git}" ######################################################################## # Equations ######################################################################## -: ${Equations_CI_BRANCH:=8.8+alpha} -: ${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations.git} +: "${Equations_CI_BRANCH:=8.8+alpha}" +: "${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations.git}" + +######################################################################## +# Elpi +######################################################################## +: "${Elpi_CI_BRANCH:=coq-master}" +: "${Elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi.git}" diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh index d68674381..c90e516ae 100755 --- a/dev/ci/ci-bignums.sh +++ b/dev/ci/ci-bignums.sh @@ -13,4 +13,4 @@ bignums_CI_DIR=${CI_BUILD_DIR}/Bignums git_checkout ${bignums_CI_BRANCH} ${bignums_CI_GITURL} ${bignums_CI_DIR} -( cd ${bignums_CI_DIR} && make -j ${NJOBS} && make install) +( cd ${bignums_CI_DIR} && make && make install) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 309050057..558e8cbb8 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,33 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -Color_CI_DIR=${CI_BUILD_DIR}/color +CoLoR_CI_DIR=${CI_BUILD_DIR}/color -# Setup Bignums - -source ${ci_dir}/ci-bignums.sh - -# Compiles CoLoR - -svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} - -sed -i -e "s/From Coq Require Import BigN/From Bignums Require Import BigN/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Export BigN/From Bignums Require Export BigN/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Import BigZ/From Bignums Require Import BigZ/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Export BigZ/From Bignums Require Export BigZ/" ${Color_CI_DIR}/Util/*/*.v - -# Adapt to PR #220 (FunInd not loaded in Prelude anymore) -sed -i -e "15i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/basis/ordered_set.v -sed -i -e "8i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/equational_extension.v -sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/more_list_extention.v -sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/ring_extention.v -sed -i -e "27i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/dickson.v -sed -i -e "26i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_permut.v -sed -i -e "23i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_set.v -sed -i -e "25i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_sort.v -sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/more_list.v -sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/List/ListUtil.v -sed -i -e "17i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Multiset/MultisetOrder.v -sed -i -e "13i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Set/SetUtil.v - -( cd ${Color_CI_DIR} && make ) +# Compile CoLoR +git_checkout ${CoLoR_CI_BRANCH} ${CoLoR_CI_GITURL} ${CoLoR_CI_DIR} +( cd ${CoLoR_CI_DIR} && make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 1bfdf7dfb..d7a356930 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -2,12 +2,27 @@ set -xe +# default value for NJOBS +: "${NJOBS:=1}" +export NJOBS + if [ -n "${GITLAB_CI}" ]; then - export COQBIN=`pwd`/_install_ci/bin - export TRAVIS_BRANCH="$CI_COMMIT_REF_NAME" + export COQBIN="$PWD/_install_ci/bin" + export CI_BRANCH="$CI_COMMIT_REF_NAME" else - export COQBIN=`pwd`/bin + if [ -n "${TRAVIS}" ]; + then + export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" + export CI_BRANCH="$TRAVIS_BRANCH" + elif [ -n "${CIRCLECI}" ]; + then + export CI_PULL_REQUEST="$CIRCLE_PR_NUMBER" + export CI_BRANCH="$CIRCLE_BRANCH" + else # assume local + export CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" + fi + export COQBIN="$PWD/bin" fi export PATH="$COQBIN:$PATH" @@ -17,14 +32,16 @@ export COQBIN="$COQBIN/" ls "$COQBIN" # Where we clone and build external developments -CI_BUILD_DIR=`pwd`/_build_ci +CI_BUILD_DIR="$PWD/_build_ci" -for overlay in ${ci_dir}/user-overlays/*.sh; do - source ${overlay} +# shellcheck source=ci-basic-overlay.sh +source "${ci_dir}/ci-basic-overlay.sh" +for overlay in "${ci_dir}"/user-overlays/*.sh; do + # shellcheck source=/dev/null + source "${overlay}" done -source ${ci_dir}/ci-basic-overlay.sh -mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp +mathcomp_CI_DIR="${CI_BUILD_DIR}/math-comp" # git_checkout branch url dest will create a git repository # in <dest> (if it does not exist already) and checkout the @@ -37,15 +54,16 @@ git_checkout() # Allow an optional 4th argument for the commit local _COMMIT=${4:-FETCH_HEAD} - local _DEPTH=$(if [ -z "${4}" ]; then echo "--depth 1"; fi) - - mkdir -p ${_DEST} - ( cd ${_DEST} && \ - if [ ! -d .git ] ; then git clone ${_DEPTH} ${_URL} . ; fi && \ - echo "Checking out ${_DEST}" && \ - git fetch ${_URL} ${_BRANCH} && \ - git checkout ${_COMMIT} && \ - echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) + local _DEPTH=() + if [ -z "${4}" ]; then _DEPTH=(--depth 1); fi + + mkdir -p "${_DEST}" + ( cd "${_DEST}" && \ + if [ ! -d .git ] ; then git clone "${_DEPTH[@]}" "${_URL}" . ; fi && \ + echo "Checking out ${_DEST}" && \ + git fetch "${_URL}" "${_BRANCH}" && \ + git checkout "${_COMMIT}" && \ + echo "${_DEST}: $(git log -1 --format='%s | %H | %cd | %aN')" ) } checkout_mathcomp() @@ -53,13 +71,25 @@ checkout_mathcomp() git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} } +make() +{ + # +x: add x only if defined + if [ -z "${MAKEFLAGS+x}" ] && [ -n "${NJOBS}" ]; + then + # Not submake and parallel make requested + command make -j "$NJOBS" "$@" + else + command make "$@" + fi +} + # this installs just the ssreflect library of math-comp install_ssreflect() { echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' - checkout_mathcomp ${mathcomp_CI_DIR} - ( cd ${mathcomp_CI_DIR}/mathcomp && \ + checkout_mathcomp "${mathcomp_CI_DIR}" + ( cd "${mathcomp_CI_DIR}/mathcomp" && \ sed -i.bak '/ssrtest/d' Make && \ sed -i.bak '/odd_order/d' Make && \ sed -i.bak '/all\/all.v/d' Make && \ diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 4cfe0911b..6a0ce2aef 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -5,9 +5,7 @@ source ${ci_dir}/ci-common.sh CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert -opam install -j ${NJOBS} -y menhir +opam install -j "$NJOBS" -y menhir git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} -# Patch to avoid the upper version limit -( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make ) - +( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq-dpdgraph.sh index b610f7000..5d6bd6a36 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq-dpdgraph.sh @@ -7,4 +7,4 @@ coq_dpdgraph_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph git_checkout ${coq_dpdgraph_CI_BRANCH} ${coq_dpdgraph_CI_GITURL} ${coq_dpdgraph_CI_DIR} -( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make -j ${NJOBS} && make test-suite ) +( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make && make test-suite ) diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh new file mode 100755 index 000000000..54cad5df4 --- /dev/null +++ b/dev/ci/ci-corn.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Corn_CI_DIR=${CI_BUILD_DIR}/corn + +git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} + +( cd ${Corn_CI_DIR} && make && make install ) diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh new file mode 100755 index 000000000..c44e0a655 --- /dev/null +++ b/dev/ci/ci-elpi.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Elpi_CI_DIR=${CI_BUILD_DIR}/elpi + +git_checkout ${Elpi_CI_BRANCH} ${Elpi_CI_GITURL} ${Elpi_CI_DIR} + +( cd ${Elpi_CI_DIR} && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index f7470463d..62854afac 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -7,4 +7,4 @@ Equations_CI_DIR=${CI_BUILD_DIR}/Equations git_checkout ${Equations_CI_BRANCH} ${Equations_CI_GITURL} ${Equations_CI_DIR} -( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} && make -j ${NJOBS} test-suite && make -j ${NJOBS} examples && make install) +( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make && make test-suite && make examples && make install) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh index 2556f84a5..53eb55fc4 100755 --- a/dev/ci/ci-formal-topology.sh +++ b/dev/ci/ci-formal-topology.sh @@ -3,30 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes - -Corn_CI_DIR=${CI_BUILD_DIR}/corn - formal_topology_CI_DIR=${CI_BUILD_DIR}/formal-topology -# Setup Bignums - -source ${ci_dir}/ci-bignums.sh - -# Setup Math-Classes - -git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} - -( cd ${math_classes_CI_DIR} && make && make install ) - -# Setup Corn - -git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} - -( cd ${Corn_CI_DIR} && make && make install ) - -# Setup formal-topology - git_checkout ${formal_topology_CI_BRANCH} ${formal_topology_CI_GITURL} ${formal_topology_CI_DIR} ( cd ${formal_topology_CI_DIR} && make ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 1bf6e9a87..693135a4c 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} -( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} ) +( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-iris-lambda-rust.sh index cf24d202d..267e13359 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-iris-lambda-rust.sh @@ -34,8 +34,8 @@ git_checkout ${stdpp_CI_BRANCH} ${stdpp_URL_PARTS[0]} ${stdpp_CI_DIR} ${stdpp_UR # Build std++ ( cd ${stdpp_CI_DIR} && make && make install ) -# Build iris -( cd ${Iris_CI_DIR} && make && make install ) +# Build and validate (except on Travis, i.e., skip if TRAVIS is non-empty) Iris +( cd ${Iris_CI_DIR} && make && (test -n "${TRAVIS}" || make validate) && make install ) # Build lambdaRust ( cd ${lambdaRust_CI_DIR} && make && make install ) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh index 4865be31e..820ff89ee 100755 --- a/dev/ci/ci-ltac2.sh +++ b/dev/ci/ci-ltac2.sh @@ -3,8 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -ltac2_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph +ltac2_CI_DIR=${CI_BUILD_DIR}/ltac2 git_checkout ${ltac2_CI_BRANCH} ${ltac2_CI_GITURL} ${ltac2_CI_DIR} -( cd ${ltac2_CI_DIR} && make -j ${NJOBS} && make tests && make install ) +( cd ${ltac2_CI_DIR} && make && make tests && make install ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index 2837dee96..db4a31e54 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -5,20 +5,6 @@ source ${ci_dir}/ci-common.sh math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes -Corn_CI_DIR=${CI_BUILD_DIR}/corn - -# Setup Bignums - -source ${ci_dir}/ci-bignums.sh - -# Setup Math-Classes - git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} ( cd ${math_classes_CI_DIR} && make && make install ) - -# Setup Corn - -git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} - -( cd ${Corn_CI_DIR} && make ) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 217540cc1..4e8c7e145 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -3,13 +3,10 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# XXX: Needs fixing to properly set the build directory. -wget ${sf_lf_CI_TARURL} -wget ${sf_plf_CI_TARURL} -wget ${sf_vfa_CI_TARURL} -tar xvfz lf.tgz -tar xvfz plf.tgz -tar xvfz vfa.tgz +mkdir -p ${CI_BUILD_DIR} && cd ${CI_BUILD_DIR} +wget -qO- ${sf_lf_CI_TARURL} | tar xvz +wget -qO- ${sf_plf_CI_TARURL} | tar xvz +wget -qO- ${sf_vfa_CI_TARURL} | tar xvz sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 5bfc408e9..5760fbafb 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -8,6 +8,6 @@ VST_CI_DIR=${CI_BUILD_DIR}/VST # opam install -j ${NJOBS} -y menhir git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} -# Targets are: msl veric floyd +# Targets are: msl veric floyd progs , we remove progs to save time # Patch to avoid the upper version limit -( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true ) +( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true .loadpath version.vo msl veric floyd ) diff --git a/dev/ci/ci-wrapper.sh b/dev/ci/ci-wrapper.sh index 96acc5a11..12a70176c 100755 --- a/dev/ci/ci-wrapper.sh +++ b/dev/ci/ci-wrapper.sh @@ -13,11 +13,14 @@ function travis_fold { fi } -CI_SCRIPT="$1" +CI_NAME="$1" +CI_SCRIPT="ci-${CI_NAME}.sh" + DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" # assume this script is in dev/ci/, cd to the root Coq directory cd "${DIR}/../.." +export TIMED=1 "${DIR}/${CI_SCRIPT}" 2>&1 | tee time-of-build.log travis_fold 'start' 'coq.test.timing' && echo 'Aggregating timing log...' python ./tools/make-one-time-file.py time-of-build.log diff --git a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh index af4a96f4a..7716bcb59 100644 --- a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh +++ b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh @@ -1,4 +1,4 @@ -if [ "$TRAVIS_PULL_REQUEST" = "669" ] || [ "$TRAVIS_BRANCH" = "ssr-merge" ]; then +if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then mathcomp_CI_BRANCH=ssr-merge mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp.git fi diff --git a/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh b/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh deleted file mode 100644 index 5c4dd1324..000000000 --- a/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$TRAVIS_PULL_REQUEST" = "1033" ] || [ "$TRAVIS_BRANCH" = "restrict-harder" ]; then - formal_topology_CI_BRANCH=ci - formal_topology_CI_GITURL=https://github.com/SkySkimmer/topology.git - - HoTT_CI_BRANCH=coq-pr-1033 - HoTT_CI_GITURL=https://github.com/SkySkimmer/HoTT.git - - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations.git -fi diff --git a/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh b/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh deleted file mode 100644 index c9f1272be..000000000 --- a/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$TRAVIS_PULL_REQUEST" = "6197" ] || [ "$TRAVIS_BRANCH" = "plugins+remove_locality_hack" ]; then - ltac2_CI_BRANCH=localityfixyou - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2.git -fi diff --git a/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh b/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh new file mode 100644 index 000000000..c2e367038 --- /dev/null +++ b/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "6405" ] || [ "$CI_BRANCH" = "rm-local-polymorphic-flag" ]; then + Equations_CI_BRANCH=rm-local-polymorphic-flag + Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations +fi diff --git a/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh b/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh new file mode 100644 index 000000000..78789a6fc --- /dev/null +++ b/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh @@ -0,0 +1,4 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6483" ] || [ "$TRAVIS_BRANCH" = "check-poly-effects" ]; then + HoTT_CI_BRANCH=check-poly-effects + HoTT_CI_GITURL=https://github.com/ppedrot/HoTT.git +fi diff --git a/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh b/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh new file mode 100644 index 000000000..9677b3525 --- /dev/null +++ b/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh @@ -0,0 +1,8 @@ +if [ "$CI_PULL_REQUEST" = "6493" ] || [ "$CI_BRANCH" = "API/remove-big-file" ]; then + Equations_CI_BRANCH=API-removal + Equations_CI_GITURL=https://github.com/gares/Coq-Equations.git + coq_dpdgraph_CI_BRANCH=API-removal + coq_dpdgraph_CI_GITURL=https://github.com/gares/coq-dpdgraph.git + ltac2_CI_BRANCH=API-removal + ltac2_CI_GITURL=https://github.com/gares/ltac2.git +fi diff --git a/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh b/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh new file mode 100644 index 000000000..8a50fb111 --- /dev/null +++ b/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "6535" ] || [ "$CI_BRANCH" = "fix-push-rel-to-named" ]; then + Equations_CI_BRANCH=fix-6535 + Equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations +fi diff --git a/dev/ci/user-overlays/06686-ccnv-no-proj.sh b/dev/ci/user-overlays/06686-ccnv-no-proj.sh new file mode 100644 index 000000000..3a3ab44e0 --- /dev/null +++ b/dev/ci/user-overlays/06686-ccnv-no-proj.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "6686" ] || [ "$CI_BRANCH" = "ccnv-no-proj" ]; then + Equations_CI_BRANCH=ccnv-fixes + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 9146d3d52..9f0377cee 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -7,8 +7,10 @@ The name of your overlay file should be of the form `five_digit_PR_number-GitHub Example: `00669-maximedenes-ssr-merge.sh` containing ``` -if [ "$TRAVIS_PULL_REQUEST" = "669" ] || [ "$TRAVIS_BRANCH" = "ssr-merge" ]; then +if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then mathcomp_CI_BRANCH=ssr-merge mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp.git fi ``` + +(`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](/dev/ci/ci-common.sh)) diff --git a/dev/core.dbg b/dev/core.dbg index 18e82c352..57c136900 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -1,4 +1,4 @@ -source camlp4.dbg +source camlp5.dbg load_printer threads.cma load_printer str.cma load_printer clib.cma @@ -17,5 +17,4 @@ load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma load_printer intf.cma -load_printer API.cma load_printer ltac_plugin.cmo @@ -1,37 +1,67 @@ source core.dbg load_printer top_printers.cmo +install_printer Top_printers.pP install_printer Top_printers.ppfuture - install_printer Top_printers.ppid -install_printer Top_printers.ppidset -install_printer Top_printers.ppevar -install_printer Top_printers.ppevarsubst -install_printer Top_printers.ppexistentialfilter -install_printer Top_printers.ppexistentialset -install_printer Top_printers.ppintset install_printer Top_printers.pplab -install_printer Top_printers.ppdir install_printer Top_printers.ppmbid +install_printer Top_printers.ppdir install_printer Top_printers.ppmp -install_printer Top_printers.ppkn install_printer Top_printers.ppcon -install_printer Top_printers.ppwf_paths +install_printer Top_printers.ppproj +install_printer Top_printers.ppkn install_printer Top_printers.ppmind +install_printer Top_printers.ppind install_printer Top_printers.ppsp install_printer Top_printers.ppqualid install_printer Top_printers.ppclindex -install_printer Top_printers.ppbigint -install_printer Top_printers.pp_transparent_state - -install_printer Top_printers.pppattern -install_printer Top_printers.ppglob_constr - +install_printer Top_printers.ppscheme +install_printer Top_printers.ppwf_paths +install_printer Top_printers.ppevar install_printer Top_printers.ppconstr +install_printer Top_printers.ppsconstr install_printer Top_printers.ppeconstr +install_printer Top_printers.ppconstr_expr +install_printer Top_printers.ppglob_constr +install_printer Top_printers.pppattern +install_printer Top_printers.ppfconstr +install_printer Top_printers.ppbigint +install_printer Top_printers.ppintset +install_printer Top_printers.ppidset +install_printer Top_printers.ppidmapgen +install_printer Top_printers.ppididmap +install_printer Top_printers.ppconstrunderbindersidmap +install_printer Top_printers.ppevarsubst +install_printer Top_printers.ppunbound_ltac_var_map +install_printer Top_printers.ppclosure +install_printer Top_printers.ppclosedglobconstr +install_printer Top_printers.ppclosedglobconstridmap +install_printer Top_printers.ppglobal +install_printer Top_printers.ppconst +install_printer Top_printers.ppvar +install_printer Top_printers.ppj +install_printer Top_printers.ppsubst +install_printer Top_printers.ppdelta +install_printer Top_printers.pp_idpred +install_printer Top_printers.pp_cpred +install_printer Top_printers.pp_transparent_state +install_printer Top_printers.pp_stack_t +install_printer Top_printers.pp_cst_stack_t +install_printer Top_printers.pp_state_t +install_printer Top_printers.ppmetas +install_printer Top_printers.ppevm +install_printer Top_printers.ppexistentialset +install_printer Top_printers.ppexistentialfilter +install_printer Top_printers.ppclenv +install_printer Top_printers.ppgoalgoal +install_printer Top_printers.ppgoal +install_printer Top_printers.pphintdb +install_printer Top_printers.ppproofview +install_printer Top_printers.ppopenconstr +install_printer Top_printers.pproof install_printer Top_printers.ppuni -install_printer Top_printers.ppuniverses -install_printer Top_printers.ppconstraints +install_printer Top_printers.ppuni_level install_printer Top_printers.ppuniverse_set install_printer Top_printers.ppuniverse_instance install_printer Top_printers.ppuniverse_context @@ -40,34 +70,19 @@ install_printer Top_printers.ppuniverse_subst install_printer Top_printers.ppuniverse_opt_subst install_printer Top_printers.ppuniverse_level_subst install_printer Top_printers.ppevar_universe_context +install_printer Top_printers.ppconstraints +install_printer Top_printers.ppuniverseconstraints +install_printer Top_printers.ppuniverse_context_future install_printer Top_printers.ppcumulativity_info install_printer Top_printers.ppabstract_cumulativity_info -install_printer Top_printers.pptype -install_printer Top_printers.ppj -install_printer Top_printers.ppenv +install_printer Top_printers.ppuniverses install_printer Top_printers.ppnamedcontextval -install_printer Top_printers.pp_stack_t -install_printer Top_printers.pp_cst_stack_t - -install_printer Top_printers.ppmetas -install_printer Top_printers.ppevm -install_printer Top_printers.ppgoalgoal -install_printer Top_printers.ppgoal -install_printer Top_printers.ppproofview -install_printer Top_printers.pphintdb - +install_printer Top_printers.ppenv install_printer Top_printers.pptac install_printer Top_printers.ppobj install_printer Top_printers.pploc -install_printer Top_printers.prsubst -install_printer Top_printers.prdelta -install_printer Top_printers.ppfconstr +install_printer Top_printers.pp_argument_type +install_printer Top_printers.pp_generic_argument install_printer Top_printers.ppgenarginfo install_printer Top_printers.ppgenargargt install_printer Top_printers.ppist -install_printer Top_printers.ppconstrunderbindersidmap -install_printer Top_printers.ppunbound_ltac_var_map -install_printer Top_printers.ppididmap -install_printer Top_printers.ppidmapgen -install_printer Top_printers.ppclosure -install_printer Top_printers.ppclosedglobconstr diff --git a/COMPATIBILITY b/dev/doc/COMPATIBILITY index b5fed7f01..a81afca32 100644 --- a/COMPATIBILITY +++ b/dev/doc/COMPATIBILITY @@ -1,3 +1,6 @@ +Note: this file isn't used anymore. Incompatibilities are documented +as part of CHANGES. + Potential sources of incompatibilities between Coq V8.6 and V8.7 ---------------------------------------------------------------- @@ -5,10 +8,6 @@ Potential sources of incompatibilities between Coq V8.6 and V8.7 error rather than a warning when the superfluous name is already in use. The easy fix is to remove the superfluous name. -- Proofs ending in "Qed exporting ident, .., ident" are not supported - anymore. Constants generated during `abstract` are kept private to the - local environment. - Potential sources of incompatibilities between Coq V8.5 and V8.6 ---------------------------------------------------------------- diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt index f3fc13e96..abba13428 100644 --- a/dev/doc/build-system.dev.txt +++ b/dev/doc/build-system.dev.txt @@ -46,7 +46,7 @@ see build-system.txt . .ml4 files ---------- -.ml4 are converted to .ml by camlp4. By default, they are produced +.ml4 are converted to .ml by camlp5. By default, they are produced in the binary ast format understood by ocamlc/ocamlopt/ocamldep. Pros: - faster than parsing clear-text source file. diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt index 873adc1b2..1c4fd2eba 100644 --- a/dev/doc/build-system.txt +++ b/dev/doc/build-system.txt @@ -88,7 +88,7 @@ bootstrapped. The dependencies of a file FOO are in FOO.d . This enables partial recalculation of dependencies (only the dependencies of changed files are recomputed). -If you add a dependency to a Coq camlp4 extension (grammar.cma or +If you add a dependency to a Coq camlp5 extension (grammar.cma or q_constr.cmo), then see sections ".ml4 files" and "new files". Cleaning Targets @@ -127,7 +127,7 @@ of a grammar extension via a line of the form: The use of (*i camlp4use: ... i*) to mention uses of standard extension such as IFDEF has also been discontinued, the Makefile now -always calls camlp4 with pa_macros.cmo and a few others by default. +always calls camlp5 with pa_macros.cmo and a few others by default. For debugging a Coq grammar extension, it could be interesting to use the READABLE_ML4=1 option, otherwise the generated .ml are diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 707adce30..16a31790a 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -12,16 +12,6 @@ All the bugs with a number below 1154 had to be renumbered, you can find a correspondence table [here](/dev/bugzilla2github_stripped.csv). All the other bugs kept their number. -### Plugin API - -Coq 8.8 offers a new module overlay containing a proposed plugin API -in `API/API.ml`; this overlay is enabled by adding the `-open API` -flag to the OCaml compiler; this happens automatically for -developments in the `plugin` folder and `coq_makefile`. - -However, `coq_makefile` can be instructed not to enable this flag by -passing `-bypass-API`. - ### ML API General deprecation @@ -30,6 +20,14 @@ General deprecation removed. Please, make sure your plugin is warning-free in 8.7 before trying to port it over 8.8. +Proof engine + + Due to the introduction of `EConstr` in 8.7, it is not necessary to + track "goal evar normal form status" anymore, thus the type `'a + Proofview.Goal.t` loses its ghost argument. This may introduce some + minor incompatibilities at the typing level. Code-wise, things + should remain the same. + We removed the following functions: - `Universes.unsafe_constr_of_global`: use `Global.constr_of_global_in_context` @@ -46,9 +44,14 @@ We changed the type of the following functions: - `Global.body_of_constant`: same as above. -We renamed the following datatypes: +- `Constrinterp.*` generally, many functions that used to take an + `evar_map ref` have been now switched to functions that will work in + a functional way. The old style of passing `evar_map`s as references + is not supported anymore. + +We have changed the representation of the following types: -- `Pp.std_ppcmds` -> `Pp.t` +- `Lib.object_prefix` is now a record instead of a nested tuple. Some tactics and related functions now support static configurability, e.g.: @@ -63,6 +66,24 @@ Declaration of printers for arguments used only in vernac command happen. An alternative is to register the corresponding argument as a value, using "Geninterp.register_val0 wit None". +### STM API + +The STM API has seen a general overhaul. The main change is the +introduction of a "Coq document" type, which all operations now take +as a parameter. This effectively functionalize the STM API and will +allow in the future to handle several documents simultaneously. + +The main remarkable point is that key implicit global parameters such +as load-paths and required modules are now arguments to the document +creation function. This helps enforcing some key invariants. + +### XML IDE Protocol + +- Before 8.8, `Query` only executed the first command present in the + `query` string; starting with 8.8, the caller may include several + statements. This is useful for instance for temporarily setting an + option and then executing a command. + ## Changes between Coq 8.6 and Coq 8.7 ### Ocaml diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index 2dbd132da..b3d49b7e5 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -25,7 +25,7 @@ intf : grammar : - Camlp4 syntax extensions. The file grammar/grammar.cma is used + Camlp5 syntax extensions. The file grammar/grammar.cma is used to pre-process .ml4 files containing EXTEND constructions, either TACTIC EXTEND, ARGUMENTS EXTEND or VERNAC ... EXTEND. This grammar.cma incorporates many files from other directories diff --git a/dev/doc/debugging.md b/dev/doc/debugging.md index 7d3d811cc..fd3cbd1bc 100644 --- a/dev/doc/debugging.md +++ b/dev/doc/debugging.md @@ -22,8 +22,8 @@ Debugging from Coq toplevel using Caml trace mechanism printers too. -Debugging from Caml debugger -============================ +Debugging with ocamldebug from Emacs +==================================== Requires [Tuareg mode](https://github.com/ocaml/tuareg) in Emacs.\ Coq must be configured with `-local` (`./configure -local`) and the @@ -59,6 +59,29 @@ Debugging from Caml debugger from the debugger. If this happens, unset the variable, re-start Emacs, and run the debugger again. +Debugging with ocamldebug from the command line +=============================================== + +In the `coq` directory: +1. (on Cygwin/Windows) Pass the `-no-custom` option to the `configure` script before building Coq. +2. Run `make` (to compile the .v files) +3. Run `make byte` +4. (on Cygwin/Windows) Add the full pathname of the directory `.../kernel/byterun` to your bash PATH. + Alternatively, copy the file `kernel/byterun/dllcoqrun.dll` to a directory that is in the PATH. (The + CAML_LD_LIBRARY_PATH mechanism described at the end of INSTALL isn't working.) +5. Run `dev/ocamldebug-coq bin/coqtop.byte` (on Cygwin/Windows, use `... bin/coqtop.byte.exe`) +6. Enter `source db` to load printers +7. Enter `set arguments -coqlib .` so Coq can find plugins, theories, etc. +8. See the ocamldebug manual for more information. A few points: + - use `break @ Printer 501` to set a breakpoint on line 501 in the Printer module (printer.ml). + `break` can be abbreviated as `b`. + - `backtrace` or `bt` to see the call stack + - `step` or `s` goes into called functions; `next` or `n` skips over them + - `list` or `li` shows the code just before and after the current stack frame + - `print <var>` or `p <var>` to see the value of a variable +Note that `make byte` doesn't recompile .v files. `make` recompiles all of them if there +are changes in any .ml file--safer but much slower. + Global gprof-based profiling ============================ @@ -73,8 +96,8 @@ Per function profiling To profile function foo in file bar.ml, add the following lines, just after the definition of the function: - let fookey = Profile.declare_profile "foo";; - let foo a b c = Profile.profile3 fookey foo a b c;; + let fookey = CProfile.declare_profile "foo";; + let foo a b c = CProfile.profile3 fookey foo a b c;; where foo is assumed to have three arguments (adapt using Profile.profile1, Profile. profile2, etc). diff --git a/dev/doc/setup.txt b/dev/doc/setup.txt index 0c6d3ee80..0003a2c21 100644 --- a/dev/doc/setup.txt +++ b/dev/doc/setup.txt @@ -58,30 +58,12 @@ behave as expected. A note about rlwrap ------------------- -Running "coqtop" under "rlwrap" is possible, but (on Debian) there is a catch. If you try: - - cd ~/git/coq - rlwrap bin/coqtop - -you will get an error: +When using "rlwrap coqtop" make sure the version of rlwrap is at least +0.42, otherwise you will get rlwrap: error: Couldn't read completions from /usr/share/rlwrap/completions/coqtop: No such file or directory -This is a known issue: - - https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=779692 - -It was fixed upstream in version 0.42, and in a Debian package that, at the time of writing, is not part of Debian stable/testing/sid archives but only of Debian experimental. - - https://packages.debian.org/experimental/rlwrap - -The quick solution is to grab it from there, since it installs fine on Debian stable (jessie). - - cd /tmp - wget http://ftp.us.debian.org/debian/pool/main/r/rlwrap/rlwrap_0.42-1_amd64.deb - sudo dpkg -i rlwrap_0.42-1_amd64.deb - -After that, "rlwrap" works fine with "coqtop". +If this happens either update or use an alternate readline wrapper like "ledit". How to install and configure Merlin (for Emacs) @@ -279,7 +261,7 @@ You can load them by switching to the window holding the "ocamldebug" shell and Some of the functions were you might want to set a breakpoint and see what happens next --------------------------------------------------------------------------------------- -- Coqtop.start : This function is called by the code produced by "coqmktop". +- Coqtop.start : This function is the main entry point of coqtop. - Coqtop.parse_args : This function is responsible for parsing command-line arguments. - Coqloop.loop : This function implements the read-eval-print loop. - Vernacentries.interp : This function is called to execute the Vernacular command user have typed.\ diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index 6a69c5793..ca3d520c7 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -12,7 +12,7 @@ type pinductive = inductive puniverses type pconstructor = constructor puniverses type constr = ... - | Const of puniversess + | Const of puniverses | Ind of pinductive | Constr of pconstructor | Proj of constant * constr diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 18f6288f6..b35571e9c 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -330,6 +330,12 @@ the STM API, `force` triggers a `Join`. <string>${message}</string> </value> ``` + +Before 8.8, `Query` only executed the first command present in the +`query` string; starting with 8.8, the caller may include several +statements. This is useful for instance for temporarily setting an +option and then executing a command. + ------------------------------- diff --git a/dev/include b/dev/include index 0d34595f4..b982f4c9f 100644 --- a/dev/include +++ b/dev/include @@ -36,7 +36,6 @@ #install_printer (* constraints *) ppconstraints;; #install_printer (* univ constraints *) ppuniverseconstraints;; #install_printer (* universe *) ppuni;; -#install_printer (* universes *) ppuniverse;; #install_printer (* universes *) ppuniverses;; #install_printer (* univ level *) ppuni_level;; #install_printer (* univ context *) ppuniverse_context;; diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index ecf7880e2..ee9c8777a 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -9,20 +9,26 @@ CODE=0 -if [ "(" "-n" "${TRAVIS_PULL_REQUEST}" ")" "-a" "(" "${TRAVIS_PULL_REQUEST}" "!=" "false" ")" ]; +if [ -n "${TRAVIS_PULL_REQUEST}" ] && [ "${TRAVIS_PULL_REQUEST}" != false ]; then + # skip PRs from before the linter existed + if [ -z "$(git ls-tree --name-only "${TRAVIS_PULL_REQUEST_SHA}" dev/lint-commits.sh)" ]; + then + 1>&2 echo "Linting skipped: pull request older than the linter." + exit 0 + fi + # Some problems are too widespread to fix in one commit, but we # can still check that they don't worsen. CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} PR_HEAD=${TRAVIS_COMMIT_RANGE##*...} - MERGE_BASE=$(git merge-base $CUR_HEAD $PR_HEAD) - dev/lint-commits.sh $MERGE_BASE $PR_HEAD || CODE=1 + MERGE_BASE=$(git merge-base "$CUR_HEAD" "$PR_HEAD") + dev/lint-commits.sh "$MERGE_BASE" "$PR_HEAD" || CODE=1 fi # Check that the files with 'whitespace' gitattribute end in a newline. # xargs exit status is 123 if any file failed the test -find . "(" -path ./.git -prune ")" -type f \ --o "(" -exec dev/tools/should-check-whitespace.sh '{}' ';' ")" \ --print0 | xargs -0 -L 1 dev/tools/check-eof-newline.sh || CODE=1 +find . "(" -path ./.git -prune ")" -o -type f -print0 | + xargs -0 dev/tools/check-eof-newline.sh || CODE=1 exit $CODE diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index 80da84517..f48013cf2 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -13,7 +13,7 @@ SetCompressor lzma !define MY_PRODUCT "Coq" ;Define your own software name here !define COQ_SRC_PATH "..\.." -!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" +!define OUTFILE "coq-${VERSION}-installer-windows-${ARCH}.exe" !include "MUI2.nsh" !include "FileAssociation.nsh" diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index f4799f7b2..f3e60edea 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -3,27 +3,26 @@ # Wrapper around ocamldebug for Coq # This file is to be launched via the generated script ocamldebug-coq, -# which will set the env variables $OCAMLDEBUG, $CAMLP4LIB, $COQTOP +# which will set the env variables $OCAMLDEBUG, $CAMLP5LIB, $COQTOP # Anyway, just in case someone tries to use this script directly, # here are some reasonable default values [ -z "$OCAMLDEBUG" ] && OCAMLDEBUG=ocamldebug -[ -z "$CAMLP4LIB" ] && CAMLP4LIB=+camlp5 +[ -z "$CAMLP5LIB" ] && CAMLP5LIB=+camlp5 [ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD [ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD` export CAML_LD_LIBRARY_PATH=$COQTOP/kernel/byterun:$CAML_LD_LIBRARY_PATH exec $OCAMLDEBUG \ - -I $CAMLP4LIB -I +threads \ + -I $CAMLP5LIB -I +threads \ -I $COQTOP \ - -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \ + -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ - -I $COQTOP/API \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ diff --git a/dev/set_raw_db b/dev/set_raw_db deleted file mode 100644 index 5caff7e5d..000000000 --- a/dev/set_raw_db +++ /dev/null @@ -1 +0,0 @@ -install_printer Top_printers.ppconstrdb diff --git a/dev/tools/anomaly-traces-parser.el b/dev/tools/anomaly-traces-parser.el deleted file mode 100644 index 68f54266f..000000000 --- a/dev/tools/anomaly-traces-parser.el +++ /dev/null @@ -1,28 +0,0 @@ -;; This Elisp snippet adds a regexp parser for the format of Anomaly -;; backtraces (coqc -bt ...), to the error parser of the Compilation -;; mode (C-c C-c: "Compile command: ..."). Once the -;; coq-change-error-alist-for-backtraces function has run, file -;; locations in traces are recognized and can be jumped from easily -;; from the *compilation* buffer. - -;; You can just copy everything below to your .emacs and this will be -;; enabled from any compilation command launched from an OCaml file. - -(defun coq-change-error-alist-for-backtraces () - "Hook to change the compilation-error-regexp-alist variable, to - search the coq backtraces for error locations" - (interactive) - (add-to-list - 'compilation-error-regexp-alist-alist - '(coq-backtrace - "^ *\\(?:raise\\|frame\\) @ file \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1,\ - lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\ - \\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:?\\)?\\)" - 2 (3 . 4) (5 . 6))) - (add-to-list 'compilation-error-regexp-alist 'coq-backtrace)) - -;; this Anomaly parser should be available when one is hacking -;; on the *OCaml* code of Coq (adding bugs), so we enable it -;; through the OCaml mode hooks. -(add-hook 'caml-mode-hook 'coq-change-error-alist-for-backtraces) -(add-hook 'tuareg-mode-hook 'coq-change-error-alist-for-backtraces) diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh index bc6ee3191..e4359f703 100755 --- a/dev/tools/backport-pr.sh +++ b/dev/tools/backport-pr.sh @@ -1,10 +1,11 @@ #!/usr/bin/env bash -# Usage: git-backport <PR number> +# Usage: dev/tools/backport-pr.sh <PR number> [--stop-before-merging] set -e PRNUM=$1 +OPTION=$2 if ! git log master --grep "Merge PR #${PRNUM}" | grep "." > /dev/null; then echo "PR #${PRNUM} does not exist." @@ -49,6 +50,19 @@ else fi +if ! git diff --exit-code HEAD ${BRANCH} -- "*.mli"; then + echo + read -p "Some mli files are modified. Bypass? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi +fi + +if [[ "${OPTION}" == "--stop-before-merging" ]]; then + exit 0 +fi + git merge -S --no-ff ${BRANCH} -m "${MESSAGE}" git branch -d ${BRANCH} diff --git a/dev/tools/check-eof-newline.sh b/dev/tools/check-eof-newline.sh index 1c578c05c..e244d9ab8 100755 --- a/dev/tools/check-eof-newline.sh +++ b/dev/tools/check-eof-newline.sh @@ -1,9 +1,41 @@ #!/usr/bin/env bash -if [ -z "$(tail -c 1 "$1")" ] +# Usage: check-eof-newline.sh [--fix] FILES... +# Detect missing end of file newlines for FILES. +# Files are skipped if untracked by git and depending on gitattributes. +# With --fix, automatically append a newline. +# Exit status: +# Without --fix: 1 if any file had a missing newline, 0 otherwise. +# With --fix: 1 if any non writable file had a missing newline, 0 otherwise. + +FIX= +if [ "$1" = --fix ]; then - exit 0 -else - echo "No newline at end of file $1!" - exit 1 + FIX=1 + shift fi + +CODE=0 +for f in "$@"; do + if git ls-files --error-unmatch "$f" >/dev/null 2>&1 && \ + git check-attr whitespace -- "$f" | grep -q -v -e 'unset$' -e 'unspecified$' && \ + [ -n "$(tail -c 1 "$f")" ] + then + if [ -n "$FIX" ]; + then + if [ -w "$f" ]; + then + echo >> "$f" + echo "Newline appended to file $f!" + else + echo "File $f is missing a newline and not writable!" + CODE=1 + fi + else + echo "No newline at end of file $f!" + CODE=1 + fi + fi +done + +exit "$CODE" diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el new file mode 100644 index 000000000..8c55be283 --- /dev/null +++ b/dev/tools/coqdev.el @@ -0,0 +1,106 @@ +;;; coqdev.el --- Emacs helpers for Coq development -*- lexical-binding:t -*- + +;; Copyright (C) 2018 The Coq Development Team + +;; Maintainer: coqdev@inria.fr + +;;; Commentary: + +;; Helpers to set compilation commands, proof general variables, etc +;; for Coq development + +;; You can disable individual features without editing this file by +;; using `remove-hook', for instance +;; (remove-hook 'hack-local-variables-hook #'coqdev-setup-compile-command) + +;;; Installation: + +;; To use this, with coqdev.el located at /path/to/coqdev.el, add the +;; following to your init: + +;; (add-to-list 'load-path "/path/to/coqdev/") +;; (require 'coqdev) + +;; If you load this file from a git repository, checking out an old +;; commit will make it disappear and cause errors for your Emacs +;; startup. To ignore those errors use (require 'coqdev nil t). If you +;; check out a malicious commit Emacs startup would allow it to run +;; arbitrary code, to avoid this you can copy coqdev.el to any +;; location and adjust the load path accordingly (of course if you run +;; ./configure to compile Coq it is already too late). + +;;; Code: + +(defun coqdev-default-directory () + "Return the Coq repository containing `default-directory'." + (let ((dir (locate-dominating-file default-directory "META.coq"))) + (when dir (expand-file-name dir)))) + +(defun coqdev-setup-compile-command () + "Setup `compile-command' for Coq development." + (let ((dir (coqdev-default-directory))) + (when dir (setq-local compile-command (concat "make -C " (shell-quote-argument dir)))))) +(add-hook 'hack-local-variables-hook #'coqdev-setup-compile-command) + +(defvar camldebug-command-name) ; from camldebug.el (caml package) +(defvar ocamldebug-command-name) ; from ocamldebug.el (tuareg package) +(defun coqdev-setup-camldebug () + "Setup ocamldebug for Coq development. + +Specifically `camldebug-command-name' and `ocamldebug-command-name'." + (let ((dir (coqdev-default-directory))) + (when dir + (setq-local camldebug-command-name + (concat dir "dev/ocamldebug-coq")) + (setq-local ocamldebug-command-name + (concat dir "dev/ocamldebug-coq"))))) +(add-hook 'hack-local-variables-hook #'coqdev-setup-camldebug) + +(defun coqdev-setup-tags () + "Setup `tags-file-name' for Coq development." + (let ((dir (coqdev-default-directory))) + (when dir (setq-local tags-file-name (concat dir "TAGS"))))) +(add-hook 'hack-local-variables-hook #'coqdev-setup-tags) + +(defvar coq-prog-args) +(defvar coq-prog-name) + +;; Lets us detect whether there are file local variables +;; even though PG sets it with `setq' when there's a _Coqproject. +;; Also makes sense generally, so might make it into PG someday. +(make-variable-buffer-local 'coq-prog-args) +(setq-default coq-prog-args nil) + +(defun coqdev-setup-proofgeneral () + "Setup Proofgeneral variables for Coq development. + +Note that this function is executed before _Coqproject is read if it exists." + (let ((dir (coqdev-default-directory))) + (when dir + (unless coq-prog-args + (setq coq-prog-args + `("-coqlib" ,dir "-R" ,(concat dir "plugins") + "Coq" "-R" ,(concat dir "theories") + "Coq"))) + (setq-local coq-prog-name (concat dir "bin/coqtop"))))) +(add-hook 'hack-local-variables-hook #'coqdev-setup-proofgeneral) + +;; This Elisp snippet adds a regexp parser for the format of Anomaly +;; backtraces (coqc -bt ...), to the error parser of the Compilation +;; mode (C-c C-c: "Compile command: ..."). File locations in traces +;; are recognized and can be jumped from easily in the *compilation* +;; buffer. +(defvar compilation-error-regexp-alist-alist) +(defvar compilation-error-regexp-alist) +(with-eval-after-load 'compile + (add-to-list + 'compilation-error-regexp-alist-alist + '(coq-backtrace + "^ *\\(?:raise\\|frame\\) @ file \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1,\ + lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\ + \\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:?\\)?\\)" + 2 (3 . 4) (5 . 6))) + (add-to-list 'compilation-error-regexp-alist 'coq-backtrace)) + +(provide 'coqdev) +;;; coqdev ends here diff --git a/dev/tools/github-check-prs.py b/dev/tools/github-check-prs.py new file mode 100755 index 000000000..beb26d910 --- /dev/null +++ b/dev/tools/github-check-prs.py @@ -0,0 +1,47 @@ +#!/usr/bin/env python3 + +# Requires PyGithub https://pypi.python.org/pypi/PyGithub, for instance +# debian package: python3-github +# nix: nix-shell -p python3 python3Packages.PyGithub --run ./github-check-rebase.py +from github import Github +import argparse + +REPO = "coq/coq" +REBASE_LABEL="needs: rebase" + +parser = argparse.ArgumentParser() +parser.add_argument("--token-file", type=argparse.FileType('r')) +args = parser.parse_args() + +if args.token_file is None: + token = input("Github access token: ").strip() +else: + token = args.token_file.read().rstrip("\n") + args.token_file.close() + +if token == "": + print ("Warning: using the GitHub API without a token") + print ("We may run into rate limit issues") + g = Github() +else: + g = Github(token) + +repo = g.get_repo(REPO) + +for pull in repo.get_pulls(): + # if conflicts then dirty + # otherwise blocked (because I have no rights) + dirty = pull.mergeable_state == "dirty" + labelled = False + for label in repo.get_issue(pull.number).get_labels(): + if label.name == REBASE_LABEL: + labelled = True + if labelled and not dirty: + print ("PR #" + str(pull.number) + " is not dirty but is labelled") + print ("("+ pull.html_url +")") + elif dirty and not labelled: + print ("PR #" + str(pull.number) + " is dirty and not labelled") + print ("("+ pull.html_url +")") + else: + # give some feedback so the user can see we didn't crash + print ("PR #" + str(pull.number) + " OK") diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index f770004a5..9f24960ff 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -1,4 +1,6 @@ -#!/bin/sh -e +#!/usr/bin/env bash + +set -e # This script depends (at least) on git and jq. # It should be used like this: dev/tools/merge-pr.sh /PR number/ @@ -7,20 +9,20 @@ PR=$1 -CURRENT_LOCAL_BRANCH=`git rev-parse --abbrev-ref HEAD` -REMOTE=`git config --get branch.$CURRENT_LOCAL_BRANCH.remote` -git fetch $REMOTE refs/pull/$PR/head +CURRENT_LOCAL_BRANCH=$(git rev-parse --abbrev-ref HEAD) +REMOTE=$(git config --get "branch.$CURRENT_LOCAL_BRANCH.remote") +git fetch "$REMOTE" "refs/pull/$PR/head" API=https://api.github.com/repos/coq/coq -BASE_BRANCH=`curl -s $API/pulls/$PR | jq -r '.base.label'` +BASE_BRANCH=$(curl -s "$API/pulls/$PR" | jq -r '.base.label') -COMMIT=`git rev-parse $REMOTE/pr/$PR` -STATUS=`curl -s $API/commits/$COMMIT/status | jq -r '.state'` +COMMIT=$(git rev-parse FETCH_HEAD) +STATUS=$(curl -s "$API/commits/$COMMIT/status" | jq -r '.state') -if [ $BASE_BRANCH != "coq:$CURRENT_LOCAL_BRANCH" ]; then +if [ "$BASE_BRANCH" != "coq:$CURRENT_LOCAL_BRANCH" ]; then echo "Wrong base branch" - read -p "Bypass? [y/n] " -n 1 -r + read -p "Bypass? [y/N] " -n 1 -r echo if [[ ! $REPLY =~ ^[Yy]$ ]] then @@ -28,9 +30,9 @@ if [ $BASE_BRANCH != "coq:$CURRENT_LOCAL_BRANCH" ]; then fi fi; -if [ $STATUS != "success" ]; then +if [ "$STATUS" != "success" ]; then echo "CI status is \"$STATUS\"" - read -p "Bypass? [y/n] " -n 1 -r + read -p "Bypass? [y/N] " -n 1 -r echo if [[ ! $REPLY =~ ^[Yy]$ ]] then @@ -38,10 +40,10 @@ if [ $STATUS != "success" ]; then fi fi; -git merge -S --no-ff $REMOTE/pr/$PR -m "Merge PR #$PR: `curl -s $API/pulls/$PR | jq -r '.title'`" -e +git merge -S --no-ff FETCH_HEAD -m "Merge PR #$PR: $(curl -s "$API/pulls/$PR" | jq -r '.title')" -e # TODO: improve this check -if [[ `git diff $REMOTE/$CURRENT_LOCAL_BRANCH dev/ci` ]]; then +if ! git diff --quiet "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci; then echo "******************************************" echo "** WARNING: does this PR have overlays? **" echo "******************************************" diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit new file mode 100755 index 000000000..c9cdee84a --- /dev/null +++ b/dev/tools/pre-commit @@ -0,0 +1,73 @@ +#!/bin/sh + +# configure automatically sets up a wrapper at .git/hooks/pre-commit +# which calls this script (if it exists). + +set -e + +if ! git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh || + ! git diff-index --check --cached HEAD >/dev/null 2>&1 ; +then + 1>&2 echo "Auto fixing whitespace issues..." + + # We fix whitespace in the index and in the working tree + # separately to preserve non-added changes. + index=$(mktemp "git-fix-ws-index.XXXXX") + fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXX") + tree=$(mktemp "git-fix-ws-tree.XXXXX") + 1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." + 1>&2 echo "If an error destroys your changes you can recover using them." + 1>&2 echo "(The files are cleaned up on success.)" + 1>&2 echo #newline + + git diff-index -p --cached HEAD > "$index" + git diff-index -p HEAD > "$tree" + + # reset work tree and index + # NB: untracked files which were not added are untouched + git apply --cached -R "$index" + git apply -R "$tree" + + # Fix index + # For end of file newlines we must go through the worktree + 1>&2 echo "Fixing staged changes..." + git apply --cached --whitespace=fix "$index" + git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself + git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + git add -u + 1>&2 echo #newline + + # reset work tree + git diff-index -p --cached HEAD > "$fixed_index" + # If all changes were bad whitespace changes the patch is empty + # making git fail. Don't fail now: we fix the worktree first. + if [ -s "$fixed_index" ] + then + git apply -R "$fixed_index" + fi + + # Fix worktree + 1>&2 echo "Fixing unstaged changes..." + git apply --whitespace=fix "$tree" + git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + 1>&2 echo #newline + + if ! [ -s "$fixed_index" ] + then + 1>&2 echo "No changes after fixing whitespace issues!" + exit 1 + fi + + # Check that we did fix whitespace + if ! git diff-index --check --cached HEAD; + then + 1>&2 echo "Auto-fixing whitespace failed: errors remain." + 1>&2 echo "This may fix itself if you try again." + 1>&2 echo "(Consider whether the number of errors decreases after each run.)" + exit 1 + fi + 1>&2 echo "Whitespace issues fixed!" + + # clean up temporary files + rm "$index" "$tree" "$fixed_index" +fi diff --git a/dev/tools/should-check-whitespace.sh b/dev/tools/should-check-whitespace.sh deleted file mode 100755 index d85d65107..000000000 --- a/dev/tools/should-check-whitespace.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -# determine if a file has whitespace checking enabled in .gitattributes - -git ls-files --error-unmatch "$1" >/dev/null 2>&1 && -git check-attr whitespace -- "$1" | grep -q -v -e 'unset$' -e 'unspecified$' diff --git a/dev/tools/sudo-apt-get-update.sh b/dev/tools/sudo-apt-get-update.sh new file mode 100755 index 000000000..f8bf6bed4 --- /dev/null +++ b/dev/tools/sudo-apt-get-update.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +(sudo apt-get update "$@" 2>&1 || echo 'E: update failed') | tee /tmp/apt.err +! grep -q '^\(E:\|W: Failed to fetch\)' /tmp/apt.err || exit $? diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 832040ad2..f99e2593d 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -50,13 +50,13 @@ let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) -let pprecarg = function +let prrecarg = function | Declarations.Norec -> str "Norec" | Declarations.Mrec (mind,i) -> str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" | Declarations.Imbr (mind,i) -> str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" -let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) +let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) (* term printers *) let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma @@ -65,8 +65,6 @@ let ppevar evk = pp (Evar.print evk) let ppconstr x = pp (Termops.print_constr (EConstr.of_constr x)) let ppeconstr x = pp (Termops.print_constr x) let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) -let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr (EConstr.of_constr x)) -let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) @@ -111,7 +109,7 @@ let prconstrunderbindersidmap = pridmap (fun _ (l,c) -> let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l) let ppunbound_ltac_var_map l = ppidmap (fun _ arg -> - str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">") + str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">") l open Ltac_pretype let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = @@ -149,8 +147,8 @@ let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) let ppj j = pp (genppj (envpp pr_ljudge_env) j) -let prsubst s = pp (Mod_subst.debug_pr_subst s) -let prdelta s = pp (Mod_subst.debug_pr_delta s) +let ppsubst s = pp (Mod_subst.debug_pr_subst s) +let ppdelta s = pp (Mod_subst.debug_pr_delta s) let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) @@ -200,9 +198,8 @@ let pppftreestate p = pp(print_pftreestate p) let pproof p = pp(Proof.pr_proof p) -let ppuni u = pp(pr_uni u) +let ppuni u = pp(Universe.pr u) let ppuni_level u = pp (Level.pr u) -let ppuniverse u = pp (str"[" ++ Universe.pr u ++ str"]") let prlev = Universes.pr_with_global_universes let ppuniverse_set l = pp (LSet.pr prlev l) @@ -233,7 +230,7 @@ let ppenvwithcst e = pp str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ str "{" ++ Cmap_env.fold (fun a _ s -> Constant.print a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") -let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (API.Global.env()) x)) +let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) @@ -488,7 +485,7 @@ let in_current_context f c = let (evmap,sign) = Pfedit.get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) -(* We expand the result of preprocessing to be independent of camlp4 +(* We expand the result of preprocessing to be independent of camlp5 VERNAC COMMAND EXTEND PrintPureConstr | [ "PrintPureConstr" constr(c) ] -> [ in_current_context print_pure_constr c ] diff --git a/dev/top_printers.mli b/dev/top_printers.mli new file mode 100644 index 000000000..7b5e4a0b6 --- /dev/null +++ b/dev/top_printers.mli @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Printers for the ocaml toplevel. *) + +val pp : Pp.t -> unit +val pP : Pp.t -> unit (* with surrounding box *) + +val ppfuture : 'a Future.computation -> unit + +val ppid : Names.Id.t -> unit +val pplab : Names.Label.t -> unit +val ppmbid : Names.MBId.t -> unit +val ppdir : Names.DirPath.t -> unit +val ppmp : Names.ModPath.t -> unit +val ppcon : Names.Constant.t -> unit +val ppproj : Names.Projection.t -> unit +val ppkn : Names.KerName.t -> unit +val ppmind : Names.MutInd.t -> unit +val ppind : Names.inductive -> unit + +val ppsp : Libnames.full_path -> unit +val ppqualid : Libnames.qualid -> unit + +val ppclindex : Classops.cl_index -> unit + +val ppscheme : 'a Ind_tables.scheme_kind -> unit + +val prrecarg : Declarations.recarg -> Pp.t +val ppwf_paths : Declarations.recarg Rtree.t -> unit + +val pr_evar : Evar.t -> Pp.t +val ppevar : Evar.t -> unit + +(* Multiple printers for Constr.t *) +val ppconstr : Constr.t -> unit (* by Termops printer *) +val ppconstr_univ : Constr.t -> unit + +(* Extern as type *) +val pptype : Constr.types -> unit + +val ppsconstr : Constr.constr Mod_subst.substituted -> unit +val ppeconstr : EConstr.constr -> unit (* Termops printer *) +val ppconstr_expr : Constrexpr.constr_expr -> unit +val ppglob_constr : 'a Glob_term.glob_constr_g -> unit +val pppattern : Pattern.constr_pattern -> unit +val ppfconstr : CClosure.fconstr -> unit + +val ppbigint : Bigint.bigint -> unit + +val ppintset : Int.Set.t -> unit +val ppidset : Names.Id.Set.t -> unit + +val pridmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> Pp.t +val ppidmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> unit + +val pridmapgen : 'a Names.Id.Map.t -> Pp.t +val ppidmapgen : 'a Names.Id.Map.t -> unit + +val prididmap : Names.Id.t Names.Id.Map.t -> Pp.t +val ppididmap : Names.Id.t Names.Id.Map.t -> unit + +val prconstrunderbindersidmap : + (Names.Id.t list * EConstr.constr) Names.Id.Map.t -> Pp.t +val ppconstrunderbindersidmap : + (Names.Id.t list * EConstr.constr) Names.Id.Map.t -> unit + +val ppevarsubst : + (Constr.t * Constr.t option * Names.Id.Map.key) list Names.Id.Map.t -> unit + +val ppunbound_ltac_var_map : + 'a Genarg.generic_argument Names.Id.Map.t -> unit + +val pr_closure : Ltac_pretype.closure -> Pp.t +val pr_closed_glob_constr_idmap : + Ltac_pretype.closed_glob_constr Names.Id.Map.t -> Pp.t +val pr_closed_glob_constr : Ltac_pretype.closed_glob_constr -> Pp.t +val ppclosure : Ltac_pretype.closure -> unit +val ppclosedglobconstr : Ltac_pretype.closed_glob_constr -> unit +val ppclosedglobconstridmap : + Ltac_pretype.closed_glob_constr Names.Id.Map.t -> unit + +val ppglobal : Globnames.global_reference -> unit + +val ppconst : + Names.KerName.t * (Constr.constr, 'a) Environ.punsafe_judgment -> unit +val ppvar : Names.Id.t * Constr.constr -> unit + +val genppj : ('a -> Pp.t * Pp.t) -> 'a -> Pp.t +val ppj : EConstr.unsafe_judgment -> unit + +val ppsubst : Mod_subst.substitution -> unit +val ppdelta : Mod_subst.delta_resolver -> unit + +val pp_idpred : Names.Id.Pred.t -> unit +val pp_cpred : Names.Cpred.t -> unit +val pp_transparent_state : Names.transparent_state -> unit + +val pp_stack_t : Constr.t Reductionops.Stack.t -> unit +val pp_cst_stack_t : Reductionops.Cst_stack.t -> unit +val pp_state_t : Reductionops.state -> unit + +val ppmetas : Evd.Metaset.t -> unit +val ppevm : Evd.evar_map -> unit +val ppevmall : Evd.evar_map -> unit + +val pr_existentialset : Evar.Set.t -> Pp.t +val ppexistentialset : Evar.Set.t -> unit + +val ppexistentialfilter : Evd.Filter.t -> unit + +val ppclenv : Clenv.clausenv -> unit + +val ppgoalgoal : Goal.goal -> unit + +val ppgoal : Proof_type.goal Evd.sigma -> unit +(* also print evar map *) +val ppgoalsigma : Proof_type.goal Evd.sigma -> unit + +val pphintdb : Hints.Hint_db.t -> unit +val ppproofview : Proofview.proofview -> unit +val ppopenconstr : Evd.open_constr -> unit + +val pproof : Proof.t -> unit + +(* Universes *) +val ppuni : Univ.Universe.t -> unit +val ppuni_level : Univ.Level.t -> unit (* raw *) +val prlev : Univ.Level.t -> Pp.t (* with global names (does this work?) *) +val ppuniverse_set : Univ.LSet.t -> unit +val ppuniverse_instance : Univ.Instance.t -> unit +val ppuniverse_context : Univ.UContext.t -> unit +val ppuniverse_context_set : Univ.ContextSet.t -> unit +val ppuniverse_subst : Univ.universe_subst -> unit +val ppuniverse_opt_subst : Universes.universe_opt_subst -> unit +val ppuniverse_level_subst : Univ.universe_level_subst -> unit +val ppevar_universe_context : UState.t -> unit +val ppconstraints : Univ.Constraint.t -> unit +val ppuniverseconstraints : Universes.Constraints.t -> unit +val ppuniverse_context_future : Univ.UContext.t Future.computation -> unit +val ppcumulativity_info : Univ.CumulativityInfo.t -> unit +val ppabstract_cumulativity_info : Univ.ACumulativityInfo.t -> unit +val ppuniverses : UGraph.t -> unit + +val ppnamedcontextval : Environ.named_context_val -> unit +val ppenv : Environ.env -> unit +val ppenvwithcst : Environ.env -> unit + +val pptac : Tacexpr.glob_tactic_expr -> unit + +val ppobj : Libobject.obj -> unit + +(* Some super raw printers *) +val cast_kind_display : Constr.cast_kind -> string +val constr_display : Constr.constr -> unit +val print_pure_constr : Constr.types -> unit + +val pploc : Loc.t -> unit + +val pp_argument_type : Genarg.argument_type -> unit +val pp_generic_argument : 'a Genarg.generic_argument -> unit + +val prgenarginfo : Geninterp.Val.t -> Pp.t +val ppgenarginfo : Geninterp.Val.t -> unit + +val ppgenargargt : ('a, 'b, 'c) Genarg.ArgT.tag -> unit + +val ppist : Geninterp.interp_sign -> unit diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 8e43bf6ed..f819d2e6a 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -3,7 +3,7 @@ open Term open Names open Cbytecodes open Cemitcodes -open Vm +open Vmvalues let ppripos (ri,pos) = (match ri with diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 81def1674..6a28c5b3d 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -182,6 +182,7 @@ \newcommand{\declnotation}{\nterm{decl\_notation}} \newcommand{\symbolentry}{\nterm{symbol}} \newcommand{\modifiers}{\nterm{modifiers}} +\newcommand{\binderinterp}{\nterm{binder\_interp}} \newcommand{\localdef}{\nterm{local\_def}} \newcommand{\localdecls}{\nterm{local\_decls}} \newcommand{\ident}{\nterm{ident}} diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex deleted file mode 100644 index 541d39501..000000000 --- a/doc/faq/FAQ.tex +++ /dev/null @@ -1,2713 +0,0 @@ -\RequirePackage{ifpdf} -\ifpdf % si on est en pdflatex -\documentclass[a4paper,pdftex]{article} -\else -\documentclass[a4paper]{article} -\fi -\pagestyle{plain} - -% yay les symboles -\usepackage{textcomp} -\usepackage{stmaryrd} -\usepackage{amssymb} -\usepackage{url} -%\usepackage{multicol} -\usepackage{hevea} -\usepackage{fullpage} -\usepackage[utf8]{inputenc} -\usepackage[english]{babel} - -\ifpdf % si on est en pdflatex - \usepackage[pdftex]{graphicx} -\else - \usepackage[dvips]{graphicx} -\fi - -%\input{../macros.tex} - -% Making hevea happy -%HEVEA \renewcommand{\textbar}{|} -%HEVEA \renewcommand{\textunderscore}{\_} - -\def\Question#1{\stepcounter{question}\subsubsection{#1}} - -% version et date -\def\faqversion{0.1} - -% les macros d'amour -\def\Coq{\textsc{Coq}} -\def\Why{\textsc{Why}} -\def\Framac{\textsc{Frama-c}} -\def\Krakatoa{\textsc{Krakatoa}} -\def\Ltac{\textsc{Ltac}} -\def\CoqIde{\textsc{CoqIde}} - -\newcommand{\coqtt}[1]{{\tt #1}} -\newcommand{\coqimp}{{\mbox{\tt ->}}} -\newcommand{\coqequiv}{{\mbox{\tt <->}}} - - -% macro pour les tactics -\def\split{{\tt split}} -\def\assumption{{\tt assumption}} -\def\auto{{\tt auto}} -\def\trivial{{\tt trivial}} -\def\tauto{{\tt tauto}} -\def\left{{\tt left}} -\def\right{{\tt right}} -\def\decompose{{\tt decompose}} -\def\intro{{\tt intro}} -\def\intros{{\tt intros}} -\def\field{{\tt field}} -\def\ring{{\tt ring}} -\def\apply{{\tt apply}} -\def\exact{{\tt exact}} -\def\cut{{\tt cut}} -\def\assert{{\tt assert}} -\def\solve{{\tt solve}} -\def\idtac{{\tt idtac}} -\def\fail{{\tt fail}} -\def\existstac{{\tt exists}} -\def\firstorder{{\tt firstorder}} -\def\congruence{{\tt congruence}} -\def\gb{{\tt gb}} -\def\generalize{{\tt generalize}} -\def\abstracttac{{\tt abstract}} -\def\eapply{{\tt eapply}} -\def\unfold{{\tt unfold}} -\def\rewrite{{\tt rewrite}} -\def\replace{{\tt replace}} -\def\simpl{{\tt simpl}} -\def\elim{{\tt elim}} -\def\set{{\tt set}} -\def\pose{{\tt pose}} -\def\case{{\tt case}} -\def\destruct{{\tt destruct}} -\def\reflexivity{{\tt reflexivity}} -\def\transitivity{{\tt transitivity}} -\def\symmetry{{\tt symmetry}} -\def\Focus{{\tt Focus}} -\def\discriminate{{\tt discriminate}} -\def\contradiction{{\tt contradiction}} -\def\intuition{{\tt intuition}} -\def\try{{\tt try}} -\def\repeat{{\tt repeat}} -\def\eauto{{\tt eauto}} -\def\subst{{\tt subst}} -\def\symmetryin{{\tt symmetryin}} -\def\instantiate{{\tt instantiate}} -\def\inversion{{\tt inversion}} -\def\specialize{{\tt specialize}} -\def\Defined{{\tt Defined}} -\def\Qed{{\tt Qed}} -\def\pattern{{\tt pattern}} -\def\Type{{\tt Type}} -\def\Prop{{\tt Prop}} -\def\Set{{\tt Set}} - - -\newcommand\vfile[2]{\ahref{#1}{\tt {#2}.v}} -\urldef{\InitWf}\url - {http://coq.inria.fr/library/Coq.Init.Wf.html} -\urldef{\LogicBerardi}\url - {http://coq.inria.fr/library/Coq.Logic.Berardi.html} -\urldef{\LogicClassical}\url - {http://coq.inria.fr/library/Coq.Logic.Classical.html} -\urldef{\LogicClassicalFacts}\url - {http://coq.inria.fr/library/Coq.Logic.ClassicalFacts.html} -\urldef{\LogicClassicalDescription}\url - {http://coq.inria.fr/library/Coq.Logic.ClassicalDescription.html} -\urldef{\LogicProofIrrelevance}\url - {http://coq.inria.fr/library/Coq.Logic.ProofIrrelevance.html} -\urldef{\LogicEqdep}\url - {http://coq.inria.fr/library/Coq.Logic.Eqdep.html} -\urldef{\LogicEqdepDec}\url - {http://coq.inria.fr/library/Coq.Logic.Eqdep_dec.html} - - - - -\begin{document} -\bibliographystyle{plain} -\newcounter{question} -\renewcommand{\thesubsubsection}{\arabic{question}} - -%%%%%%% Coq pour les nuls %%%%%%% - -\title{Coq Version 8.4 for the Clueless\\ - \large(\protect\ref{lastquestion} - \ Hints) -} -\author{Pierre Castéran \and Hugo Herbelin \and Florent Kirchner \and Benjamin Monate \and Julien Narboux} -\maketitle - -%%%%%%% - -\begin{abstract} -This note intends to provide an easy way to get acquainted with the -{\Coq} theorem prover. It tries to formulate appropriate answers -to some of the questions any newcomers will face, and to give -pointers to other references when possible. -\end{abstract} - -%%%%%%% - -%\begin{multicols}{2} -\tableofcontents -%\end{multicols} - -%%%%%%% - -\newpage - -\section{Introduction} -This FAQ is the sum of the questions that came to mind as we developed -proofs in \Coq. Since we are singularly short-minded, we wrote the -answers we found on bits of papers to have them at hand whenever the -situation occurs again. This is pretty much the result of that: a -collection of tips one can refer to when proofs become intricate. Yes, -it means we won't take the blame for the shortcomings of this -FAQ. But if you want to contribute and send in your own question and -answers, feel free to write to us\ldots - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Presentation} - -\Question{What is {\Coq}?}\label{whatiscoq} -The {\Coq} tool is a formal proof management system: a proof done with {\Coq} is mechanically checked by the machine. -In particular, {\Coq} allows: -\begin{itemize} - \item the definition of mathematical objects and programming objects, - \item to state mathematical theorems and software specifications, - \item to interactively develop formal proofs of these theorems, - \item to check these proofs by a small certification ``kernel''. -\end{itemize} -{\Coq} is based on a logical framework called ``Calculus of Inductive -Constructions'' extended by a modular development system for theories. - -\Question{Did you really need to name it like that?} -Some French computer scientists have a tradition of naming their -software as animal species: Caml, Elan, Foc or Phox are examples -of this tacit convention. In French, ``coq'' means rooster, and it -sounds like the initials of the Calculus of Constructions CoC on which -it is based. - -\Question{Is {\Coq} a theorem prover?} - -{\Coq} comes with decision and semi-decision procedures ( -propositional calculus, Presburger's arithmetic, ring and field -simplification, resolution, ...) but the main style for proving -theorems is interactively by using LCF-style tactics. - - -\Question{What are the other theorem provers?} -Many other theorem provers are available for use nowadays. -Isabelle, HOL, HOL Light, Lego, Nuprl, PVS are examples of provers that are fairly similar -to {\Coq} by the way they interact with the user. Other relatives of -{\Coq} are ACL2, Agda/Alfa, Twelf, Kiv, Mizar, NqThm, -\begin{htmlonly}% -Omega\ldots -\end{htmlonly} -\begin{latexonly}% -{$\Omega$}mega\ldots -\end{latexonly} - -\Question{What do I have to trust when I see a proof checked by Coq?} - -You have to trust: - -\begin{description} -\item[The theory behind Coq] The theory of {\Coq} version 8.0 is -generally admitted to be consistent wrt Zermelo-Fraenkel set theory + -inaccessible cardinals. Proofs of consistency of subsystems of the -theory of Coq can be found in the literature. -\item[The Coq kernel implementation] You have to trust that the -implementation of the {\Coq} kernel mirrors the theory behind {\Coq}. The -kernel is intentionally small to limit the risk of conceptual or -accidental implementation bugs. -\item[The Objective Caml compiler] The {\Coq} kernel is written using the -Objective Caml language but it uses only the most standard features -(no object, no label ...), so that it is highly improbable that an -Objective Caml bug breaks the consistency of {\Coq} without breaking all -other kinds of features of {\Coq} or of other software compiled with -Objective Caml. -\item[Your hardware] In theory, if your hardware does not work -properly, it can accidentally be the case that False becomes -provable. But it is more likely the case that the whole {\Coq} system -will be unusable. You can check your proof using different computers -if you feel the need to. -\item[Your axioms] Your axioms must be consistent with the theory -behind {\Coq}. -\end{description} - - -\Question{Where can I find information about the theory behind {\Coq}?} -\begin{description} -\item[The Calculus of Inductive Constructions] The -\ahref{http://coq.inria.fr/doc/Reference-Manual006.html}{corresponding} -chapter and the chapter on -\ahref{http://coq.inria.fr/doc/Reference-Manual007.html}{modules} in -the {\Coq} Reference Manual. -\item[Type theory] A book~\cite{ProofsTypes} or some lecture -notes~\cite{Types:Dowek}. -\item[Inductive types] -Christine Paulin-Mohring's habilitation thesis~\cite{Pau96b}. -\item[Co-Inductive types] -Eduardo Giménez' thesis~\cite{EGThese}. -\item[Miscellaneous] A -\ahref{http://coq.inria.fr/doc/biblio.html}{bibliography} about Coq -\end{description} - - -\Question{How can I use {\Coq} to prove programs?} - -You can either extract a program from a proof by using the extraction -mechanism or use dedicated tools, such as -\ahref{http://why3.lri.fr}{\Why}, -\ahref{http://krakatoa.lri.fr}{\Krakatoa}, -\ahref{http://frama-c.com}{\Framac}, to prove -annotated programs written in other languages. - -%\Question{How many {\Coq} users are there?} -% -%An estimation is about 100 regular users. - -\Question{How old is {\Coq}?} - -The first implementation is from 1985 (it was named {\sf CoC} which is -the acronym of the name of the logic it implemented: the Calculus of -Constructions). The first official release of {\Coq} (version 4.10) -was distributed in 1989. - -\Question{What are the \Coq-related tools?} - -There are graphical user interfaces: -\begin{description} -\item[Coqide] A GTK based GUI for \Coq. -\item[Pcoq] A GUI for {\Coq} with proof by pointing and pretty printing. -\item[coqwc] A tool similar to {\tt wc} to count lines in {\Coq} files. -\item[Proof General] A emacs mode for {\Coq} and many other proof assistants. -\item[ProofWeb] The ProofWeb online web interface for {\Coq} (and other proof assistants), with a focus on teaching. -\item[ProverEditor] is an experimental Eclipse plugin with support for {\Coq}. -\end{description} - -There are documentation and browsing tools: - -\begin{description} -\item[coq-tex] A tool to insert {\Coq} examples within .tex files. -\item[coqdoc] A documentation tool for \Coq. -\item[coqgraph] A tool to generate a dependency graph from {\Coq} sources. -\end{description} - -There are front-ends for specific languages: - -\begin{description} -\item[Why] A back-end generator of verification conditions. -\item[Krakatoa] A Java code certification tool that uses both {\Coq} and {\Why} to verify the soundness of implementations with regards to the specifications. -\item[Caduceus] A C code certification tool that uses both {\Coq} and \Why. -\item[Zenon] A first-order theorem prover. -\item[Focal] The \ahref{http://focal.inria.fr}{Focal} project aims at building an environment to develop certified computer algebra libraries. -\item[Concoqtion] is a dependently-typed extension of Objective Caml (and of MetaOCaml) with specifications expressed and proved in Coq. -\item[Ynot] is an extension of Coq providing a "Hoare Type Theory" for specifying higher-order, imperative and concurrent programs. -\item[Ott]is a tool to translate the descriptions of the syntax and semantics of programming languages to the syntax of Coq, or of other provers. -\end{description} - -\Question{What are the high-level tactics of \Coq} - -\begin{itemize} -\item Decision of quantifier-free Presburger's Arithmetic -\item Simplification of expressions on rings and fields -\item Decision of closed systems of equations -\item Semi-decision of first-order logic -\item Prolog-style proof search, possibly involving equalities -\end{itemize} - -\Question{What are the main libraries available for \Coq} - -\begin{itemize} -\item Basic Peano's arithmetic, binary integer numbers, rational numbers, -\item Real analysis, -\item Libraries for lists, boolean, maps, floating-point numbers, -\item Libraries for relations, sets and constructive algebra, -\item Geometry -\end{itemize} - - -\Question{What are the mathematical applications for {\Coq}?} - -{\Coq} is used for formalizing mathematical theories, for teaching, -and for proving properties of algorithms or programs libraries. - -The largest mathematical formalization has been done at the University -of Nijmegen (see the -\ahref{http://c-corn.cs.ru.nl}{Constructive Coq -Repository at Nijmegen}). - -A symbolic step has also been obtained by formalizing in full a proof -of the Four Color Theorem. - -\Question{What are the industrial applications for {\Coq}?} - -{\Coq} is used e.g. to prove properties of the JavaCard system -(especially by Schlumberger and Trusted Logic). It has -also been used to formalize the semantics of the Lucid-Synchrone -data-flow synchronous calculus used by Esterel-Technologies. - -\iffalse -todo christine compilo lustre? -\fi - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Documentation} - -\Question{Where can I find documentation about {\Coq}?} -All the documentation about \Coq, from the reference manual~\cite{Coq:manual} to -friendly tutorials~\cite{Coq:Tutorial} and documentation of the standard library, is available -\ahref{http://coq.inria.fr/doc-eng.html}{online}. -All these documents are viewable either in browsable HTML, or as -downloadable postscripts. - -\Question{Where can I find this FAQ on the web?} - -This FAQ is available online at \ahref{http://coq.inria.fr/faq}{\url{http://coq.inria.fr/faq}}. - -\Question{How can I submit suggestions / improvements / additions for this FAQ?} - -This FAQ is unfinished (in the sense that there are some obvious -sections that are missing). Please send contributions to Coq-Club. - -\Question{Is there any mailing list about {\Coq}?} -The main {\Coq} mailing list is \url{coq-club@inria.fr}, which -broadcasts questions and suggestions about the implementation, the -logical formalism or proof developments. See -\ahref{http://sympa.inria.fr/sympa/info/coq-club}{\url{http://sympa.inria.fr/sympa/info/coq-club}} for -subscription. For bugs reports see question \ref{coqbug}. - -\Question{Where can I find an archive of the list?} -The archives of the {\Coq} mailing list are available at -\ahref{http://sympa.inria.fr/sympa/arc/coq-club}{\url{http://sympa.inria.fr/sympa/arc/coq-club}}. - - -\Question{How can I be kept informed of new releases of {\Coq}?} - -New versions of {\Coq} are announced on the coq-club mailing list. If you only want to receive information about new releases, you can subscribe to {\Coq} on \ahref{http://freshmeat.net/projects/coq/}{\url{http://freshmeat.net/projects/coq/}}. - - -\Question{Is there any book about {\Coq}?} - -The first book on \Coq, Yves Bertot and Pierre Castéran's Coq'Art has been published by Springer-Verlag in 2004: -\begin{quote} -``This book provides a pragmatic introduction to the development of -proofs and certified programs using \Coq. With its large collection of -examples and exercises it is an invaluable tool for researchers, -students, and engineers interested in formal methods and the -development of zero-default software.'' -\end{quote} - -\Question{Where can I find some {\Coq} examples?} - -There are examples in the manual~\cite{Coq:manual} and in the -Coq'Art~\cite{Coq:coqart} exercises \ahref{\url{http://www.labri.fr/Perso/~casteran/CoqArt/index.html}}{\url{http://www.labri.fr/Perso/~casteran/CoqArt/index.html}}. -You can also find large developments using -{\Coq} in the {\Coq} user contributions: -\ahref{http://coq.inria.fr/contribs}{\url{http://coq.inria.fr/contribs}}. - -\Question{How can I report a bug?}\label{coqbug} - -You can use the web interface accessible at \ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link ``contacts''. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Installation} - -\Question{What is the license of {\Coq}?} -{\Coq} is distributed under the GNU Lesser General License -(LGPL). - -\Question{Where can I find the sources of {\Coq}?} -The sources of {\Coq} can be found online in the tar.gz'ed packages -(\ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link -``download''). Development sources can be accessed at -\ahref{http://coq.gforge.inria.fr/}{\url{http://coq.gforge.inria.fr/}} - -\Question{On which platform is {\Coq} available?} -Compiled binaries are available for Linux, MacOS X, and Windows. The -sources can be easily compiled on all platforms supporting Objective -Caml. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{The logic of {\Coq}} - -\subsection{General} - -\Question{What is the logic of \Coq?} - -{\Coq} is based on an axiom-free type theory called -the Calculus of Inductive Constructions (see Coquand \cite{CoHu86}, -Luo~\cite{Luo90} -and Coquand--Paulin-Mohring \cite{CoPa89}). It includes higher-order -functions and predicates, inductive and co-inductive datatypes and -predicates, and a stratified hierarchy of sets. - -\Question{Is \Coq's logic intuitionistic or classical?} - -{\Coq}'s logic is modular. The core logic is intuitionistic -(i.e. excluded-middle $A\vee\neg A$ is not granted by default). It can -be extended to classical logic on demand by requiring an -optional module stating $A\vee\neg A$. - -\Question{Can I define non-terminating programs in \Coq?} - -All programs in {\Coq} are terminating. Especially, loops -must come with an evidence of their termination. - -Non-terminating programs can be simulated by passing around a -bound on how long the program is allowed to run before dying. - -\Question{How is equational reasoning working in {\Coq}?} - - {\Coq} comes with an internal notion of computation called -{\em conversion} (e.g. $(x+1)+y$ is internally equivalent to -$(x+y)+1$; similarly applying argument $a$ to a function mapping $x$ -to some expression $t$ converts to the expression $t$ where $x$ is -replaced by $a$). This notion of conversion (which is decidable -because {\Coq} programs are terminating) covers a certain part of -equational reasoning but is limited to sequential evaluation of -expressions of (not necessarily closed) programs. Besides conversion, -equations have to be treated by hand or using specialised tactics. - -\subsection{Axioms} - -\Question{What axioms can be safely added to {\Coq}?} - -There are a few typical useful axioms that are independent from the -Calculus of Inductive Constructions and that are considered consistent with -the theory of {\Coq}. -Most of these axioms are stated in the directory {\tt Logic} of the -standard library of {\Coq}. The most interesting ones are - -\begin{itemize} -\item Excluded-middle: $\forall A:Prop, A \vee \neg A$ -\item Proof-irrelevance: $\forall A:Prop \forall p_1 p_2:A, p_1=p_2$ -\item Unicity of equality proofs (or equivalently Streicher's axiom $K$): -$\forall A \forall x y:A \forall p_1 p_2:x=y, p_1=p_2$ -\item Hilbert's $\epsilon$ operator: if $A \neq \emptyset$, then there is $\epsilon_P$ such that $\exists x P(x) \rightarrow P(\epsilon_P)$ -\item Church's $\iota$ operator: if $A \neq \emptyset$, then there is $\iota_P$ such that $\exists! x P(x) \rightarrow P(\iota_P)$ -\item The axiom of unique choice: $\forall x \exists! y R(x,y) \rightarrow \exists f \forall x R(x,f(x))$ -\item The functional axiom of choice: $\forall x \exists y R(x,y) \rightarrow \exists f \forall x R(x,f(x))$ -\item Extensionality of predicates: $\forall P Q:A\rightarrow Prop, (\forall x, P(x) \leftrightarrow Q(x)) \rightarrow P=Q$ -\item Extensionality of functions: $\forall f g:A\rightarrow B, (\forall x, f(x)=g(x)) \rightarrow f=g$ -\end{itemize} - -Figure~\ref{fig:axioms} is a summary of the relative strength of these -axioms, most proofs can be found in directory {\tt Logic} of the standard -library. (Statements in boldface are the most ``interesting'' ones for -Coq.) The justification of their validity relies on the interpretability -in set theory. - -\begin{figure}[htbp] -%HEVEA\imgsrc{axioms.png} -%BEGIN LATEX -\begin{center} -\ifpdf % si on est en pdflatex -\scalebox{0.65}{\input{axioms.pdf_t}} -\else -\scalebox{0.65}{\input{axioms.eps_t}} -\fi -\end{center} -%END LATEX -\caption{The dependency graph of axioms in the Calculus of Inductive Constructions} -\label{fig:axioms} -\end{figure} - -\Question{What standard axioms are inconsistent with {\Coq}?} - -The axiom of unique choice together with classical logic -(e.g. excluded-middle) are inconsistent in the variant of the Calculus -of Inductive Constructions where {\Set} is impredicative. - -As a consequence, the functional form of the axiom of choice and -excluded-middle, or any form of the axiom of choice together with -predicate extensionality are inconsistent in the {\Set}-impredicative -version of the Calculus of Inductive Constructions. - -The main purpose of the \Set-predicative restriction of the Calculus -of Inductive Constructions is precisely to accommodate these axioms -which are quite standard in mathematical usage. - -The $\Set$-predicative system is commonly considered consistent by -interpreting it in a standard set-theoretic boolean model, even with -classical logic, axiom of choice and predicate extensionality added. - -\Question{What is Streicher's axiom $K$} -\label{Streicher} - -Streicher's axiom $K$~\cite{HofStr98} is an axiom that asserts -dependent elimination of reflexive equality proofs. - -\begin{coq_example*} -Axiom Streicher_K : - forall (A:Type) (x:A) (P: x=x -> Prop), - P (eq_refl x) -> forall p: x=x, P p. -\end{coq_example*} - -In the general case, axiom $K$ is an independent statement of the -Calculus of Inductive Constructions. However, it is true on decidable -domains (see file \vfile{\LogicEqdepDec}{Eqdep\_dec}). It is also -trivially a consequence of proof-irrelevance (see -\ref{proof-irrelevance}) hence of classical logic. - -Axiom $K$ is equivalent to {\em Uniqueness of Identity Proofs} \cite{HofStr98} - -\begin{coq_example*} -Axiom UIP : forall (A:Set) (x y:A) (p1 p2: x=y), p1 = p2. -\end{coq_example*} - -Axiom $K$ is also equivalent to {\em Uniqueness of Reflexive Identity Proofs} \cite{HofStr98} - -\begin{coq_example*} -Axiom UIP_refl : forall (A:Set) (x:A) (p: x=x), p = eq_refl x. -\end{coq_example*} - -Axiom $K$ is also equivalent to - -\begin{coq_example*} -Axiom - eq_rec_eq : - forall (A:Set) (x:A) (P: A->Set) (p:P x) (h: x=x), - p = eq_rect x P p x h. -\end{coq_example*} - -It is also equivalent to the injectivity of dependent equality (dependent equality is itself equivalent to equality of dependent pairs). - -\begin{coq_example*} -Inductive eq_dep (U:Set) (P:U -> Set) (p:U) (x:P p) : -forall q:U, P q -> Prop := - eq_dep_intro : eq_dep U P p x p x. -Axiom - eq_dep_eq : - forall (U:Set) (u:U) (P:U -> Set) (p1 p2:P u), - eq_dep U P u p1 u p2 -> p1 = p2. -\end{coq_example*} - -\Question{What is proof-irrelevance} -\label{proof-irrelevance} - -A specificity of the Calculus of Inductive Constructions is to permit -statements about proofs. This leads to the question of comparing two -proofs of the same proposition. Identifying all proofs of the same -proposition is called {\em proof-irrelevance}: -$$ -\forall A:\Prop, \forall p q:A, p=q -$$ - -Proof-irrelevance (in {\Prop}) can be assumed without contradiction in -{\Coq}. It expresses that only provability matters, whatever the exact -form of the proof is. This is in harmony with the common purely -logical interpretation of {\Prop}. Contrastingly, proof-irrelevance is -inconsistent in {\Set} since there are types in {\Set}, such as the -type of booleans, that provably have at least two distinct elements. - -Proof-irrelevance (in {\Prop}) is a consequence of classical logic -(see proofs in file \vfile{\LogicClassical}{Classical} and -\vfile{\LogicBerardi}{Berardi}). Proof-irrelevance is also a -consequence of propositional extensionality (i.e. \coqtt{(A {\coqequiv} B) -{\coqimp} A=B}, see the proof in file -\vfile{\LogicClassicalFacts}{ClassicalFacts}). - -Proof-irrelevance directly implies Streicher's axiom $K$. - -\Question{What about functional extensionality?} - -Extensionality of functions is admittedly consistent with the -Set-predicative Calculus of Inductive Constructions. - -%\begin{coq_example*} -% Axiom extensionality : (A,B:Set)(f,g:(A->B))(x:A)(f x)=(g x)->f=g. -%\end{coq_example*} - -Let {\tt A}, {\tt B} be types. To deal with extensionality on -\verb=A->B= without relying on a general extensionality axiom, -a possible approach is to define one's own extensional equality on -\verb=A->B=. - -\begin{coq_eval} -Variables A B : Set. -\end{coq_eval} - -\begin{coq_example*} -Definition ext_eq (f g: A->B) := forall x:A, f x = g x. -\end{coq_example*} - -and to reason on \verb=A->B= as a setoid (see the Chapter on -Setoids in the Reference Manual). - -\Question{Is {\Prop} impredicative?} - -Yes, the sort {\Prop} of propositions is {\em -impredicative}. Otherwise said, a statement of the form $\forall -A:Prop, P(A)$ can be instantiated by itself: if $\forall A:\Prop, P(A)$ -is provable, then $P(\forall A:\Prop, P(A))$ is. - -\Question{Is {\Set} impredicative?} - -No, the sort {\Set} lying at the bottom of the hierarchy of -computational types is {\em predicative} in the basic {\Coq} system. -This means that a family of types in {\Set}, e.g. $\forall A:\Set, A -\rightarrow A$, is not a type in {\Set} and it cannot be applied on -itself. - -However, the sort {\Set} was impredicative in the original versions of -{\Coq}. For backward compatibility, or for experiments by -knowledgeable users, the logic of {\Coq} can be set impredicative for -{\Set} by calling {\Coq} with the option {\tt -impredicative-set}. - -{\Set} has been made predicative from version 8.0 of {\Coq}. The main -reason is to interact smoothly with a classical mathematical world -where both excluded-middle and the axiom of description are valid (see -file \vfile{\LogicClassicalDescription}{ClassicalDescription} for a -proof that excluded-middle and description implies the double negation -of excluded-middle in {\Set} and file {\tt Hurkens\_Set.v} from the -user contribution {\tt Paradoxes} at -\ahref{http://coq.inria.fr/contribs}{\url{http://coq.inria.fr/contribs}} -for a proof that impredicativity of {\Set} implies the simple negation -of excluded-middle in {\Set}). - -\Question{Is {\Type} impredicative?} - -No, {\Type} is stratified. This is hidden for the -user, but {\Coq} internally maintains a set of constraints ensuring -stratification. - -If {\Type} were impredicative then it would be possible to encode -Girard's systems $U-$ and $U$ in {\Coq} and it is known from Girard, -Coquand, Hurkens and Miquel that systems $U-$ and $U$ are inconsistent -[Girard 1972, Coquand 1991, Hurkens 1993, Miquel 2001]. This encoding -can be found in file {\tt Logic/Hurkens.v} of {\Coq} standard library. - -For instance, when the user see {\tt $\forall$ X:Type, X->X : Type}, each -occurrence of {\Type} is implicitly bound to a different level, say -$\alpha$ and $\beta$ and the actual statement is {\tt -forall X:Type($\alpha$), X->X : Type($\beta$)} with the constraint -$\alpha<\beta$. - -When a statement violates a constraint, the message {\tt Universe -inconsistency} appears. Example: {\tt fun (x:Type) (y:$\forall$ X:Type, X -{\coqimp} X) => y x x}. - -\Question{I have two proofs of the same proposition. Can I prove they are equal?} - -In the base {\Coq} system, the answer is generally no. However, if -classical logic is set, the answer is yes for propositions in {\Prop}. -The answer is also yes if proof irrelevance holds (see question -\ref{proof-irrelevance}). - -There are also ``simple enough'' propositions for which you can prove -the equality without requiring any extra axioms. This is typically -the case for propositions defined deterministically as a first-order -inductive predicate on decidable sets. See for instance in question -\ref{le-uniqueness} an axiom-free proof of the uniqueness of the proofs of -the proposition {\tt le m n} (less or equal on {\tt nat}). - -% It is an ongoing work of research to natively include proof -% irrelevance in {\Coq}. - -\Question{I have two proofs of an equality statement. Can I prove they are -equal?} - - Yes, if equality is decidable on the domain considered (which -is the case for {\tt nat}, {\tt bool}, etc): see {\Coq} file -\verb=Eqdep_dec.v=). No otherwise, unless -assuming Streicher's axiom $K$ (see \cite{HofStr98}) or a more general -assumption such as proof-irrelevance (see \ref{proof-irrelevance}) or -classical logic. - -All of these statements can be found in file \vfile{\LogicEqdep}{Eqdep}. - -\Question{Can I prove that the second components of equal dependent -pairs are equal?} - - The answer is the same as for proofs of equality -statements. It is provable if equality on the domain of the first -component is decidable (look at \verb=inj_right_pair= from file -\vfile{\LogicEqdepDec}{Eqdep\_dec}), but not provable in the general -case. However, it is consistent (with the Calculus of Constructions) -to assume it is true. The file \vfile{\LogicEqdep}{Eqdep} actually -provides an axiom (equivalent to Streicher's axiom $K$) which entails -the result (look at \verb=inj_pair2= in \vfile{\LogicEqdep}{Eqdep}). - -\subsection{Impredicativity} - -\Question{Why {\tt injection} does not work on impredicative {\tt Set}?} - - E.g. in this case (this occurs only in the {\tt Set}-impredicative - variant of \Coq): - -\begin{coq_example*} -Inductive I : Type := - intro : forall k:Set, k -> I. -Lemma eq_jdef : - forall x y:nat, intro _ x = intro _ y -> x = y. -Proof. - intros x y H; injection H. -\end{coq_example*} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - - Injectivity of constructors is restricted to predicative types. If -injectivity on large inductive types were not restricted, we would be -allowed to derive an inconsistency (e.g. following the lines of -Burali-Forti paradox). The question remains open whether injectivity -is consistent on some large inductive types not expressive enough to -encode known paradoxes (such as type I above). - - -\Question{What is a ``large inductive definition''?} - -An inductive definition in {\Prop} or {\Set} is called large -if its constructors embed sets or propositions. As an example, here is -a large inductive type: - -\begin{coq_example*} -Inductive sigST (P:Set -> Set) : Type := - existST : forall X:Set, P X -> sigST P. -\end{coq_example*} - -In the {\tt Set} impredicative variant of {\Coq}, large inductive -definitions in {\tt Set} have restricted elimination schemes to -prevent inconsistencies. Especially, projecting the set or the -proposition content of a large inductive definition is forbidden. If -it were allowed, it would be possible to encode e.g. Burali-Forti -paradox \cite{Gir70,Coq85}. - - -\Question{Is Coq's logic conservative over Coquand's Calculus of -Constructions?} - -In the {\Set}-impredicative version of the Calculus of Inductive -Constructions (CIC), there are two ways to interpret the Calculus of -Constructions (CC) since the impredicative sort of CC can be -interpreted either as {\Prop} or as {\Set}. In the {\Set}-predicative -CIC, the impredicative sort of CC can only be interpreted as {\Prop}. - -If the impredicative sort of CC is interpreted as {\Set}, there is no -conservativity of CIC over CC as the discrimination of -constructors of inductive types in {\Set} transports to a -discrimination of constructors of inductive types encoded -impredicatively. Concretely, considering the impredicative encoding of -Boolean, equality and falsity, we can prove the following CC statement -DISCR in CIC which is not provable in CC, as CC has a -``term-irrelevant'' model. - -\begin{coq_example*} -Definition BOOL := forall X:Set, X -> X -> X. -Definition TRUE : BOOL := fun X x1 x2 => x1. -Definition FALSE : BOOL := fun X x1 x2 => x2. -Definition EQBOOL (x1 x2:BOOL) := forall P:BOOL->Set, P x1 -> P x2. -Definition BOT := forall X:Set, X. - -Definition BOOL2bool : BOOL -> bool := fun b => b bool true false. - -Theorem DISCR : EQBOOL TRUE FALSE -> BOT. -intro X. -assert (H : BOOL2bool TRUE = BOOL2bool FALSE). -{ apply X. trivial. } -discriminate H. -Qed. -\end{coq_example*} - -If the impredicative sort of CC is interpreted as {\Prop}, CIC is -presumably conservative over CC. The general idea is that no -proof-relevant information can flow from {\Prop} to {\Set}, even -though singleton elimination can be used. Hence types in {\Set} should -be smashable to the unit type and {\Set} and {\Type} themselves be -mapped to {\Prop}. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Talkin' with the Rooster} - - -%%%%%%% -\subsection{My goal is ..., how can I prove it?} - - -\Question{My goal is a conjunction, how can I prove it?} - -Use some theorem or assumption or use the {\split} tactic. -\begin{coq_example} -Goal forall A B:Prop, A -> B -> A/\B. -intros. -split. -assumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal contains a conjunction as an hypothesis, how can I use it?} - -If you want to decompose a hypothesis into several hypotheses, you can -use the {\destruct} tactic: - -\begin{coq_example} -Goal forall A B:Prop, A/\B -> B. -intros. -destruct H as [H1 H2]. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -You can also perform the destruction at the time of introduction: - -\begin{coq_example} -Goal forall A B:Prop, A/\B -> B. -intros A B [H1 H2]. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a disjunction, how can I prove it?} - -You can prove the left part or the right part of the disjunction using -{\left} or {\right} tactics. If you want to do a classical -reasoning step, use the {\tt classic} axiom to prove the right part with the assumption -that the left part of the disjunction is false. - -\begin{coq_example} -Goal forall A B:Prop, A -> A\/B. -intros. -left. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -An example using classical reasoning: - -\begin{coq_example} -Require Import Classical. - -Ltac classical_right := -match goal with -| _:_ |- ?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) -end. - -Ltac classical_left := -match goal with -| _:_ |- _ \/ ?X1 => (elim (classic X1);intro;[right;trivial|left]) -end. - - -Goal forall A B:Prop, (~A -> B) -> A\/B. -intros. -classical_right. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is an universally quantified statement, how can I prove it?} - -Use some theorem or assumption or introduce the quantified variable in -the context using the {\intro} tactic. If there are several -variables you can use the {\intros} tactic. A good habit is to -provide names for these variables: {\Coq} will do it anyway, but such -automatic naming decreases legibility and robustness. - - -\Question{My goal contains an universally quantified statement, how can I use it?} - -If the universally quantified assumption matches the goal you can -use the {\apply} tactic. If it is an equation you can use the -{\rewrite} tactic. Otherwise you can use the {\specialize} tactic -to instantiate the quantified variables with terms. The variant -{\tt assert(Ht := H t)} makes a copy of assumption {\tt H} before -instantiating it. - - -\Question{My goal is an existential, how can I prove it?} - -Use some theorem or assumption or exhibit the witness using the {\existstac} tactic. -\begin{coq_example} -Goal exists x:nat, forall y, x+y=y. -exists 0. -intros. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is solvable by some lemma, how can I prove it?} - -Just use the {\apply} tactic. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example} -Lemma mylemma : forall x, x+0 = x. -auto. -Qed. - -Goal 3+0 = 3. -apply mylemma. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - -\Question{My goal contains False as an hypothesis, how can I prove it?} - -You can use the {\contradiction} or {\intuition} tactics. - - -\Question{My goal is an equality of two convertible terms, how can I prove it?} - -Just use the {\reflexivity} tactic. - -\begin{coq_example} -Goal forall x, 0+x = x. -intros. -reflexivity. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a {\tt let x := a in ...}, how can I prove it?} - -Just use the {\intro} tactic. - - -\Question{My goal is a {\tt let (a, ..., b) := c in}, how can I prove it?} - -Just use the {\destruct} c as (a,...,b) tactic. - - -\Question{My goal contains some existential hypotheses, how can I use it?} - -As with conjunctive hypotheses, you can use the {\destruct} tactic or -the {\intros} tactic to decompose them into several hypotheses. - -\begin{coq_example*} -Require Import Arith. -\end{coq_example*} -\begin{coq_example} -Goal forall x, (exists y, x * y = 1) -> x = 1. -intros x [y H]. -apply mult_is_one in H. -easy. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality, how can I swap the left and right hand terms?} - -Just use the {\symmetry} tactic. -\begin{coq_example} -Goal forall x y : nat, x=y -> y=x. -intros. -symmetry. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My hypothesis is an equality, how can I swap the left and right hand terms?} - -Just use the {\symmetryin} tactic. - -\begin{coq_example} -Goal forall x y : nat, x=y -> y=x. -intros. -symmetry in H. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality, how can I prove it by transitivity?} - -Just use the {\transitivity} tactic. -\begin{coq_example} -Goal forall x y z : nat, x=y -> y=z -> x=z. -intros. -transitivity y. -assumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal would be solvable using {\tt apply;assumption} if it would not create meta-variables, how can I prove it?} - -You can use {\tt eapply yourtheorem;eauto} but it won't work in all cases ! (for example if more than one hypothesis match one of the subgoals generated by \eapply) so you should rather use {\tt try solve [eapply yourtheorem;eauto]}, otherwise some metavariables may be incorrectly instantiated. - -\begin{coq_example} -Lemma trans : forall x y z : nat, x=y -> y=z -> x=z. -intros. -transitivity y;assumption. -Qed. - -Goal forall x y z : nat, x=y -> y=z -> x=z. -intros. -eapply trans;eauto. -Qed. - -Goal forall x y z t : nat, x=y -> x=t -> y=z -> x=z. -intros. -eapply trans;eauto. -Undo. -eapply trans. -apply H. -auto. -Qed. - -Goal forall x y z t : nat, x=y -> x=t -> y=z -> x=z. -intros. -eapply trans;eauto. -Undo. -try solve [eapply trans;eauto]. -eapply trans. -apply H. -auto. -Qed. -\end{coq_example} - -\Question{My goal is solvable by some lemma within a set of lemmas and I don't want to remember which one, how can I prove it?} - -You can use a what is called a hints' base. - -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Lemma toto1 : 1+1 = 2. -ring. -Qed. -Lemma toto2 : 2+2 = 4. -ring. -Qed. -Lemma toto3 : 2+1 = 3. -ring. -Qed. - -Hint Resolve toto1 toto2 toto3 : mybase. - -Goal 2+(1+1)=4. -auto with mybase. -Qed. -\end{coq_example} - - -\Question{My goal is one of the hypotheses, how can I prove it?} - -Use the {\assumption} tactic. - -\begin{coq_example} -Goal 1=1 -> 1=1. -intro. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal appears twice in the hypotheses and I want to choose which one is used, how can I do it?} - -Use the {\exact} tactic. -\begin{coq_example} -Goal 1=1 -> 1=1 -> 1=1. -intros. -exact H0. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{What can be the difference between applying one hypothesis or another in the context of the last question?} - -From a proof point of view it is equivalent but if you want to extract -a program from your proof, the two hypotheses can lead to different -programs. - - -\Question{My goal is a propositional tautology, how can I prove it?} - -Just use the {\tauto} tactic. -\begin{coq_example} -Goal forall A B:Prop, A-> (A\/B) /\ A. -intros. -tauto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a first order formula, how can I prove it?} - -Just use the semi-decision tactic: \firstorder. - -\iffalse -todo: demander un exemple à Pierre -\fi - -\Question{My goal is solvable by a sequence of rewrites, how can I prove it?} - -Just use the {\congruence} tactic. -\begin{coq_example} -Goal forall a b c d e, a=d -> b=e -> c+b=d -> c+e=a. -intros. -congruence. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is a disequality solvable by a sequence of rewrites, how can I prove it?} - -Just use the {\congruence} tactic. - -\begin{coq_example} -Goal forall a b c d, a<>d -> b=a -> d=c+b -> b<>c+b. -intros. -congruence. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality on some ring (e.g. natural numbers), how can I prove it?} - -Just use the {\ring} tactic. - -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Goal forall a b : Z, (a+b)*(a+b) = a*a + 2*a*b + b*b. -intros. -ring. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is an equality on some field (e.g. real numbers), how can I prove it?} - -Just use the {\field} tactic. - -\begin{coq_example} -Require Import Reals. -Require Ring. -Local Open Scope R_scope. -Goal forall a b : R, b*a<>0 -> (a/b) * (b/a) = 1. -intros. -field. -split ; auto with real. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an inequality on integers in Presburger's arithmetic (an expression build from $+$, $-$, constants, and variables), how can I prove it?} - - -\begin{coq_example} -Require Import ZArith. -Require Omega. -Local Open Scope Z_scope. -Goal forall a : Z, a>0 -> a+a > a. -intros. -omega. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equation solvable using equational hypothesis on some ring (e.g. natural numbers), how can I prove it?} - -You need the {\gb} tactic (see Loïc Pottier's homepage). - -\subsection{Tactics usage} - -\Question{I want to state a fact that I will use later as an hypothesis, how can I do it?} - -If you want to use forward reasoning (first proving the fact and then -using it) you just need to use the {\assert} tactic. If you want to use -backward reasoning (proving your goal using an assumption and then -proving the assumption) use the {\cut} tactic. - -\begin{coq_example} -Goal forall A B C D : Prop, (A -> B) -> (B->C) -> A -> C. -intros. -assert (A->C). -intro;apply H0;apply H;assumption. -apply H2. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\begin{coq_example} -Goal forall A B C D : Prop, (A -> B) -> (B->C) -> A -> C. -intros. -cut (A->C). -intro. -apply H2;assumption. -intro;apply H0;apply H;assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - - -\Question{I want to state a fact that I will use later as an hypothesis and prove it later, how can I do it?} - -You can use {\cut} followed by {\intro} or you can use the following {\Ltac} command: -\begin{verbatim} -Ltac assert_later t := cut t;[intro|idtac]. -\end{verbatim} - -\Question{What is the difference between {\Qed} and {\Defined}?} - -These two commands perform type checking, but when {\Defined} is used the new definition is set as transparent, otherwise it is defined as opaque (see \ref{opaque}). - - -\Question{How can I know what an automation tactic does in my example?} - -You can use its {\tt info} variant: info\_auto, info\_trivial, info\_eauto. - -\Question{Why {\auto} does not work? How can I fix it?} - -You can increase the depth of the proof search or add some lemmas in the base of hints. -Perhaps you may need to use \eauto. - -\Question{What is {\eauto}?} - -This is the same tactic as \auto, but it relies on {\eapply} instead of \apply. - -\Question{How can I speed up {\auto}?} - -You can use \texttt{info\_}{\auto} to replace {\auto} by the tactics it generates. -You can split your hint bases into smaller ones. - - -\Question{What is the equivalent of {\tauto} for classical logic?} - -Currently there are no equivalent tactic for classical logic. You can use Gödel's ``not not'' translation. - - -\Question{I want to replace some term with another in the goal, how can I do it?} - -If one of your hypothesis (say {\tt H}) states that the terms are equal you can use the {\rewrite} tactic. Otherwise you can use the {\replace} {\tt with} tactic. - -\Question{I want to replace some term with another in an hypothesis, how can I do it?} - -You can use the {\rewrite} {\tt in} tactic. - -\Question{I want to replace some symbol with its definition, how can I do it?} - -You can use the {\unfold} tactic. - -\Question{How can I reduce some term?} - -You can use the {\simpl} tactic. - -\Question{How can I declare a shortcut for some term?} - -You can use the {\set} or {\pose} tactics. - -\Question{How can I perform case analysis?} - -You can use the {\case} or {\destruct} tactics. - -\Question{How can I prevent the case tactic from losing information ?} - -You may want to use the (now standard) {\tt case\_eq} tactic. See the Coq'Art page 159. - -\Question{Why should I name my intros?} - -When you use the {\intro} tactic you don't have to give a name to your -hypothesis. If you do so the name will be generated by {\Coq} but your -scripts may be less robust. If you add some hypothesis to your theorem -(or change their order), you will have to change your proof to adapt -to the new names. - -\Question{How can I automatize the naming?} - -You can use the {\tt Show Intro.} or {\tt Show Intros.} commands to generate the names and use your editor to generate a fully named {\intro} tactic. -This can be automatized within {\tt xemacs}. - -\begin{coq_example} -Goal forall A B C : Prop, A -> B -> C -> A/\B/\C. -Show Intros. -(* -A B C H H0 -H1 -*) -intros A B C H H0 H1. -repeat split;assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{I want to automatize the use of some tactic, how can I do it?} - -You need to use the {\tt proof with T} command and add {\ldots} at the -end of your sentences. - -For instance: -\begin{coq_example} -Goal forall A B C : Prop, A -> B/\C -> A/\B/\C. -Proof with assumption. -intros. -split... -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{I want to execute the {\texttt proof with} tactic only if it solves the goal, how can I do it?} - -You need to use the {\try} and {\solve} tactics. For instance: -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Goal forall a b c : Z, a+b=b+a. -Proof with try solve [ring]. -intros... -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{How can I do the opposite of the {\intro} tactic?} - -You can use the {\generalize} tactic. - -\begin{coq_example} -Goal forall A B : Prop, A->B-> A/\B. -intros. -generalize H. -intro. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{One of the hypothesis is an equality between a variable and some term, I want to get rid of this variable, how can I do it?} - -You can use the {\subst} tactic. This will rewrite the equality everywhere and clear the assumption. - -\Question{What can I do if I get ``{\tt generated subgoal term has metavariables in it }''?} - -You should use the {\eapply} tactic, this will generate some goals containing metavariables. - -\Question{How can I instantiate some metavariable?} - -Just use the {\instantiate} tactic. - - -\Question{What is the use of the {\pattern} tactic?} - -The {\pattern} tactic transforms the current goal, performing -beta-expansion on all the applications featuring this tactic's -argument. For instance, if the current goal includes a subterm {\tt -phi(t)}, then {\tt pattern t} transforms the subterm into {\tt (fun -x:A => phi(x)) t}. This can be useful when {\apply} fails on matching, -to abstract the appropriate terms. - -\Question{What is the difference between assert, cut and generalize?} - -PS: Notice for people that are interested in proof rendering that \assert -and {\pose} (and \cut) are not rendered the same as {\generalize} (see the -HELM experimental rendering tool at \ahref{http://helm.cs.unibo.it/library.html}{\url{http://helm.cs.unibo.it}}, link -HELM, link COQ Online). Indeed {\generalize} builds a beta-expanded term -while \assert, {\pose} and {\cut} uses a let-in. - -\begin{verbatim} - (* Goal is T *) - generalize (H1 H2). - (* Goal is A->T *) - ... a proof of A->T ... -\end{verbatim} - -is rendered into something like -\begin{verbatim} - (h) ... the proof of A->T ... - we proved A->T - (h0) by (H1 H2) we proved A - by (h h0) we proved T -\end{verbatim} -while -\begin{verbatim} - (* Goal is T *) - assert q := (H1 H2). - (* Goal is A *) - ... a proof of A ... - (* Goal is A |- T *) - ... a proof of T ... -\end{verbatim} -is rendered into something like -\begin{verbatim} - (q) ... the proof of A ... - we proved A - ... the proof of T ... - we proved T -\end{verbatim} -Otherwise said, {\generalize} is not rendered in a forward-reasoning way, -while {\assert} is. - -\Question{What can I do if \Coq can not infer some implicit argument ?} - -You can state explicitly what this implicit argument is. See \ref{implicit}. - -\Question{How can I explicit some implicit argument ?}\label{implicit} - -Just use \texttt{A:=term} where \texttt{A} is the argument. - -For instance if you want to use the existence of ``nil'' on nat*nat lists: -\begin{verbatim} -exists (nil (A:=(nat*nat))). -\end{verbatim} - -\iffalse -\Question{Is there anyway to do pattern matching with dependent types?} - -todo -\fi - -\subsection{Proof management} - - -\Question{How can I change the order of the subgoals?} - -You can use the {\Focus} command to concentrate on some goal. When the goal is proved you will see the remaining goals. - -\Question{How can I change the order of the hypothesis?} - -You can use the {\tt Move ... after} command. - -\Question{How can I change the name of an hypothesis?} - -You can use the {\tt Rename ... into} command. - -\Question{How can I delete some hypothesis?} - -You can use the {\tt Clear} command. - -\Question{How can use a proof which is not finished?} - -You can use the {\tt Admitted} command to state your current proof as an axiom. -You can use the {\tt give\_up} tactic to omit a portion of a proof. - -\Question{How can I state a conjecture?} - -You can use the {\tt Admitted} command to state your current proof as an axiom. - -\Question{What is the difference between a lemma, a fact and a theorem?} - -From {\Coq} point of view there are no difference. But some tools can -have a different behavior when you use a lemma rather than a -theorem. For instance {\tt coqdoc} will not generate documentation for -the lemmas within your development. - -\Question{How can I organize my proofs?} - -You can organize your proofs using the section mechanism of \Coq. Have -a look at the manual for further information. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Inductive and Co-inductive types} - -\subsection{General} - -\Question{How can I prove that two constructors are different?} - -You can use the {\discriminate} tactic. - -\begin{coq_example} -Inductive toto : Set := | C1 : toto | C2 : toto. -Goal C1 <> C2. -discriminate. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{During an inductive proof, how to get rid of impossible cases of an inductive definition?} - -Use the {\inversion} tactic. - - -\Question{How can I prove that 2 terms in an inductive set are equal? Or different?} - -Have a look at \coqtt{decide equality} and \coqtt{discriminate} in the \ahref{http://coq.inria.fr/doc/main.html}{Reference Manual}. - -\Question{Why is the proof of \coqtt{0+n=n} on natural numbers -trivial but the proof of \coqtt{n+0=n} is not?} - - Since \coqtt{+} (\coqtt{plus}) on natural numbers is defined by analysis on its first argument - -\begin{coq_example} -Print plus. -\end{coq_example} - -{\noindent} The expression \coqtt{0+n} evaluates to \coqtt{n}. As {\Coq} reasons -modulo evaluation of expressions, \coqtt{0+n} and \coqtt{n} are -considered equal and the theorem \coqtt{0+n=n} is an instance of the -reflexivity of equality. On the other side, \coqtt{n+0} does not -evaluate to \coqtt{n} and a proof by induction on \coqtt{n} is -necessary to trigger the evaluation of \coqtt{+}. - -\Question{Why is dependent elimination in Prop not -available by default?} - - -This is just because most of the time it is not needed. To derive a -dependent elimination principle in {\tt Prop}, use the command {\tt Scheme} and -apply the elimination scheme using the \verb=using= option of -\verb=elim=, \verb=destruct= or \verb=induction=. - - -\Question{Argh! I cannot write expressions like ``~{\tt if n <= p then p else n}~'', as in any programming language} -\label{minmax} - -The short answer : You should use {\texttt le\_lt\_dec n p} instead.\\ - -The long answer: That's right, you can't. -If you type for instance the following ``definition'': -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Fail Definition max (n p : nat) := if n <= p then p else n. -\end{coq_example} - -As \Coq~ says, the term ``~\texttt{n <= p}~'' is a proposition, i.e. a -statement that belongs to the mathematical world. There are many ways to -prove such a proposition, either by some computation, or using some already -proven theorems. For instance, proving $3-2 \leq 2^{45503}$ is very easy, -using some theorems on arithmetical operations. If you compute both numbers -before comparing them, you risk to use a lot of time and space. - - -On the contrary, a function for computing the greatest of two natural numbers -is an algorithm which, called on two natural numbers -$n$ and $p$, determines whether $n\leq p$ or $p < n$. -Such a function is a \emph{decision procedure} for the inequality of - \texttt{nat}. The possibility of writing such a procedure comes -directly from de decidability of the order $\leq$ on natural numbers. - - -When you write a piece of code like -``~\texttt{if n <= p then \dots{} else \dots}~'' -in a -programming language like \emph{ML} or \emph{Java}, a call to such a -decision procedure is generated. The decision procedure is in general -a primitive function, written in a low-level language, in the correctness -of which you have to trust. - -The standard Library of the system \emph{Coq} contains a -(constructive) proof of decidability of the order $\leq$ on -\texttt{nat} : the function \texttt{le\_lt\_dec} of -the module \texttt{Compare\_dec} of library \texttt{Arith}. - -The following code shows how to define correctly \texttt{min} and -\texttt{max}, and prove some properties of these functions. - -\begin{coq_example} -Require Import Compare_dec. - -Definition max (n p : nat) := if le_lt_dec n p then p else n. - -Definition min (n p : nat) := if le_lt_dec n p then n else p. - -Eval compute in (min 4 7). - -Theorem min_plus_max : forall n p, min n p + max n p = n + p. -Proof. - intros n p; - unfold min, max; - case (le_lt_dec n p); - simpl; auto with arith. -Qed. - -Theorem max_equiv : forall n p, max n p = p <-> n <= p. -Proof. - unfold max; intros n p; case (le_lt_dec n p);simpl; auto. - intuition auto with arith. - split. - intro e; rewrite e; auto with arith. - intro H; absurd (p < p); eauto with arith. -Qed. -\end{coq_example} - -\Question{I wrote my own decision procedure for $\leq$, which -is much faster than yours, but proving such theorems as - \texttt{max\_equiv} seems to be quite difficult} - -Your code is probably the following one: - -\begin{coq_example} -Fixpoint my_le_lt_dec (n p :nat) {struct n}: bool := - match n, p with 0, _ => true - | S n', S p' => my_le_lt_dec n' p' - | _ , _ => false - end. - -Definition my_max (n p:nat) := if my_le_lt_dec n p then p else n. - -Definition my_min (n p:nat) := if my_le_lt_dec n p then n else p. -\end{coq_example} - - -For instance, the computation of \texttt{my\_max 567 321} is almost -immediate, whereas one can't wait for the result of -\texttt{max 56 32}, using \emph{Coq's} \texttt{le\_lt\_dec}. - -This is normal. Your definition is a simple recursive function which -returns a boolean value. Coq's \texttt{le\_lt\_dec} is a \emph{certified -function}, i.e. a complex object, able not only to tell whether $n\leq p$ -or $p<n$, but also of building a complete proof of the correct inequality. -What make \texttt{le\_lt\_dec} inefficient for computing \texttt{min} -and \texttt{max} is the building of a huge proof term. - -Nevertheless, \texttt{le\_lt\_dec} is very useful. Its type -is a strong specification, using the -\texttt{sumbool} type (look at the reference manual or chapter 9 of -\cite{coqart}). Eliminations of the form -``~\texttt{case (le\_lt\_dec n p)}~'' provide proofs of -either $n \leq p$ or $p < n$, allowing easy proofs of some theorems as in -question~\ref{minmax}. Unfortunately, this not the case of your -\texttt{my\_le\_lt\_dec}, which returns a quite non-informative boolean -value. - - -\begin{coq_example} -Check le_lt_dec. -\end{coq_example} - -You should keep in mind that \texttt{le\_lt\_dec} is useful to build -certified programs which need to compare natural numbers, and is not -designed to compare quickly two numbers. - -Nevertheless, the \emph{extraction} of \texttt{le\_lt\_dec} towards -\emph{OCaml} or \emph{Haskell}, is a reasonable program for comparing two -natural numbers in Peano form in linear time. - -It is also possible to keep your boolean function as a decision procedure, -but you have to establish yourself the relationship between \texttt{my\_le\_lt\_dec} and the propositions $n\leq p$ and $p<n$: - -\begin{coq_example*} -Theorem my_le_lt_dec_true : - forall n p, my_le_lt_dec n p = true <-> n <= p. - -Theorem my_le_lt_dec_false : - forall n p, my_le_lt_dec n p = false <-> p < n. -\end{coq_example*} - - -\subsection{Recursion} - -\Question{Why can't I define a non terminating program?} - - Because otherwise the decidability of the type-checking -algorithm (which involves evaluation of programs) is not ensured. On -another side, if non terminating proofs were allowed, we could get a -proof of {\tt False}: - -\begin{coq_example*} -(* This is fortunately not allowed! *) -Fixpoint InfiniteProof (n:nat) : False := InfiniteProof n. -Theorem Paradox : False. -Proof (InfiniteProof O). -\end{coq_example*} - - -\Question{Why only structurally well-founded loops are allowed?} - - The structural order on inductive types is a simple and -powerful notion of termination. The consistency of the Calculus of -Inductive Constructions relies on it and another consistency proof -would have to be made for stronger termination arguments (such -as the termination of the evaluation of CIC programs themselves!). - -In spite of this, all non-pathological termination orders can be mapped -to a structural order. Tools to do this are provided in the file -\vfile{\InitWf}{Wf} of the standard library of {\Coq}. - -\Question{How to define loops based on non structurally smaller -recursive calls?} - - The procedure is as follows (we consider the definition of {\tt -mergesort} as an example). - -\begin{itemize} - -\item Define the termination order, say {\tt R} on the type {\tt A} of -the arguments of the loop. - -\begin{coq_eval} -Reset Initial. -Require Import List. -\end{coq_eval} - -\begin{coq_example*} -Definition R (a b:list nat) := length a < length b. -\end{coq_example*} - -\item Prove that this order is well-founded (in fact that all elements in {\tt A} are accessible along {\tt R}). - -\begin{coq_example*} -Lemma Rwf : well_founded R. -\end{coq_example*} -\begin{coq_eval} -Admitted. -\end{coq_eval} - -\item Define the step function (which needs proofs that recursive -calls are on smaller arguments). - -\begin{coq_example*} -Definition split (l : list nat) - : {l1: list nat | R l1 l} * {l2 : list nat | R l2 l}. -Admitted. -Definition concat (l1 l2 : list nat) : list nat. -Admitted. -Definition merge_step (l : list nat) (f: forall l':list nat, R l' l -> list nat) := - let (lH1,lH2) := (split l) in - let (l1,H1) := lH1 in - let (l2,H2) := lH2 in - concat (f l1 H1) (f l2 H2). -\end{coq_example*} - -\item Define the recursive function by fixpoint on the step function. - -\begin{coq_example*} -Definition merge := Fix Rwf (fun _ => list nat) merge_step. -\end{coq_example*} - -\end{itemize} - -\Question{What is behind the accessibility and well-foundedness proofs?} - - Well-foundedness of some relation {\tt R} on some type {\tt A} -is defined as the accessibility of all elements of {\tt A} along {\tt R}. - -\begin{coq_example} -Print well_founded. -Print Acc. -\end{coq_example} - -The structure of the accessibility predicate is a well-founded tree -branching at each node {\tt x} in {\tt A} along all the nodes {\tt x'} -less than {\tt x} along {\tt R}. Any sequence of elements of {\tt A} -decreasing along the order {\tt R} are branches in the accessibility -tree. Hence any decreasing along {\tt R} is mapped into a structural -decreasing in the accessibility tree of {\tt R}. This is emphasised in -the definition of {\tt fix} which recurs not on its argument {\tt x:A} -but on the accessibility of this argument along {\tt R}. - -See file \vfile{\InitWf}{Wf}. - -\Question{How to perform simultaneous double induction?} - - In general a (simultaneous) double induction is simply solved by an -induction on the first hypothesis followed by an inversion over the -second hypothesis. Here is an example - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example} -Inductive even : nat -> Prop := - | even_O : even 0 - | even_S : forall n:nat, even n -> even (S (S n)). - -Inductive odd : nat -> Prop := - | odd_SO : odd 1 - | odd_S : forall n:nat, odd n -> odd (S (S n)). - -Lemma not_even_and_odd : forall n:nat, even n -> odd n -> False. -induction 1. - inversion 1. - inversion 1. apply IHeven; trivial. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -In case the type of the second induction hypothesis is not -dependent, {\tt inversion} can just be replaced by {\tt destruct}. - -\Question{How to define a function by simultaneous double recursion?} - - The same trick applies, you can even use the pattern-matching -compilation algorithm to do the work for you. Here is an example: - -\begin{coq_example} -Fixpoint minus (n m:nat) {struct n} : nat := - match n, m with - | O, _ => 0 - | S k, O => S k - | S k, S l => minus k l - end. -Print minus. -\end{coq_example} - -In case of dependencies in the type of the induction objects -$t_1$ and $t_2$, an extra argument stating $t_1=t_2$ must be given to -the fixpoint definition - -\Question{How to perform nested and double induction?} - - To reason by nested (i.e. lexicographic) induction, just reason by -induction on the successive components. - -\smallskip - -Double induction (or induction on pairs) is a restriction of the -lexicographic induction. Here is an example of double induction. - -\begin{coq_example} -Lemma nat_double_ind : -forall P : nat -> nat -> Prop, P 0 0 -> - (forall m n, P m n -> P m (S n)) -> - (forall m n, P m n -> P (S m) n) -> - forall m n, P m n. -intros P H00 HmS HSn; induction m. -(* case 0 *) -induction n; [assumption | apply HmS; apply IHn]. -(* case Sm *) -intro n; apply HSn; apply IHm. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{How to define a function by nested recursion?} - - The same trick applies. Here is the example of Ackermann -function. - -\begin{coq_example} -Fixpoint ack (n:nat) : nat -> nat := - match n with - | O => S - | S n' => - (fix ack' (m:nat) : nat := - match m with - | O => ack n' 1 - | S m' => ack n' (ack' m') - end) - end. -\end{coq_example} - - -\subsection{Co-inductive types} - -\Question{I have a cofixpoint $t:=F(t)$ and I want to prove $t=F(t)$. How to do it?} - -Just case-expand $F({\tt t})$ then complete by a trivial case analysis. -Here is what it gives on e.g. the type of streams on naturals - -\begin{coq_eval} -Set Implicit Arguments. -\end{coq_eval} -\begin{coq_example} -CoInductive Stream (A:Set) : Set := - Cons : A -> Stream A -> Stream A. -CoFixpoint nats (n:nat) : Stream nat := Cons n (nats (S n)). -Lemma Stream_unfold : - forall n:nat, nats n = Cons n (nats (S n)). -Proof. - intro; - change (nats n = match nats n with - | Cons x s => Cons x s - end). - case (nats n); reflexivity. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - -\section{Syntax and notations} - -\Question{I do not want to type ``forall'' because it is too long, what can I do?} - -You can define your own notation for forall: -\begin{verbatim} -Notation "fa x : t, P" := (forall x:t, P) (at level 200, x ident). -\end{verbatim} -or if your are using {\CoqIde} you can define a pretty symbol for for all and an input method (see \ref{forallcoqide}). - - - -\Question{How can I define a notation for square?} - -You can use for instance: -\begin{verbatim} -Notation "x ^2" := (Rmult x x) (at level 20). -\end{verbatim} -Note that you can not use: -\begin{tt} -Notation "x $^2$" := (Rmult x x) (at level 20). -\end{tt} -because ``$^2$'' is an iso-latin character. If you really want this kind of notation you should use UTF-8. - - -\Question{Why ``no associativity'' and ``left associativity'' at the same level does not work?} - -Because we relie on Camlp4 for syntactical analysis and Camlp4 does not really -implement no associativity. By default, non associative operators are defined -as right associative. - - - -\Question{How can I know the associativity associated with a level?} - -You can do ``Print Grammar constr'', and decode the output from Camlp4, good luck ! - -\section{Modules} - - - - -%%%%%%% -\section{\Ltac} - -\Question{What is {\Ltac}?} - -{\Ltac} is the tactic language for \Coq. It provides the user with a -high-level ``toolbox'' for tactic creation. - -\Question{Is there any printing command in {\Ltac}?} - -You can use the {\idtac} tactic with a string argument. This string -will be printed out. The same applies to the {\fail} tactic - -\Question{What is the syntax for let in {\Ltac}?} - -If $x_i$ are identifiers and $e_i$ and $expr$ are tactic expressions, then let reads: -\begin{center} -{\tt let $x_1$:=$e_1$ with $x_2$:=$e_2$\ldots with $x_n$:=$e_n$ in -$expr$}. -\end{center} -Beware that if $expr$ is complex (i.e. features at least a sequence) parenthesis -should be added around it. For example: -\begin{coq_example} -Ltac twoIntro := let x:=intro in (x;x). -\end{coq_example} - -\Question{What is the syntax for pattern matching in {\Ltac}?} - -Pattern matching on a term $expr$ (non-linear first order unification) -with patterns $p_i$ and tactic expressions $e_i$ reads: -\begin{center} -\hspace{10ex} -{\tt match $expr$ with -\hspace*{2ex}$p_1$ => $e_1$ -\hspace*{1ex}\textbar$p_2$ => $e_2$ -\hspace*{1ex}\ldots -\hspace*{1ex}\textbar$p_n$ => $e_n$ -\hspace*{1ex}\textbar\ \textunderscore\ => $e_{n+1}$ -end. -} -\end{center} -Underscore matches all terms. - -\Question{What is the semantics for ``match goal''?} - -The semantics of {\tt match goal} depends on whether it returns -tactics or not. The {\tt match goal} expression matches the current -goal against a series of patterns: {$hyp_1 {\ldots} hyp_n$ \textbar- -$ccl$}. It uses a first-order unification algorithm and in case of -success, if the right-hand-side is an expression, it tries to type it -while if the right-hand-side is a tactic, it tries to apply it. If the -typing or the tactic application fails, the {\tt match goal} tries all -the possible combinations of $hyp_i$ before dropping the branch and -moving to the next one. Underscore matches all terms. - -\Question{Why can't I use a ``match goal'' returning a tactic in a non -tail-recursive position?} - -This is precisely because the semantics of {\tt match goal} is to -apply the tactic on the right as soon as a pattern unifies what is -meaningful only in tail-recursive uses. - -The semantics in non tail-recursive call could have been the one used -for terms (i.e. fail if the tactic expression is not typable, but -don't try to apply it). For uniformity of semantics though, this has -been rejected. - -\Question{How can I generate a new name?} - -You can use the following syntax: -{\tt let id:=fresh in \ldots}\\ -For example: -\begin{coq_example} -Ltac introIdGen := let id:=fresh in intro id. -\end{coq_example} - - -\iffalse -\Question{How can I access the type of a term?} - -You can use typeof. -todo -\fi - -\iffalse -\Question{How can I define static and dynamic code?} -\fi - -\section{Tactics written in OCaml} - -\Question{Can you show me an example of a tactic written in OCaml?} - -Have a look at the skeleton ``Hello World'' tactic from the next question. -You also have some examples of tactics written in OCaml in the ``plugins'' directory of {\Coq} sources. - -\Question{Is there a skeleton of OCaml tactic I can reuse somewhere?} - -The following steps describe how to write a simplistic ``Hello world'' OCaml -tactic. This takes the form of a dynamically loadable OCaml module, which will -be invoked from the Coq toplevel. -\begin{enumerate} -\item In the \verb+plugins+ directory of the Coq source location, create a -directory \verb+hello+. Proceed to create a grammar and OCaml file, respectively -\verb+plugins/hello/g_hello.ml4+ and \verb+plugins/hello/coq_hello.ml+, -containing: - \begin{itemize} - \item in \verb+g_hello.ml4+: -\begin{verbatim} -(*i camlp4deps: "grammar/grammar.cma" i*) -TACTIC EXTEND Hello -| [ "hello" ] -> [ Coq_hello.printHello ] -END -\end{verbatim} - \item in \verb+coq_hello.ml+: -\begin{verbatim} -let printHello gl = -Tacticals.tclIDTAC_MESSAGE (Pp.str "Hello world") gl - \end{verbatim} - \end{itemize} -\item Create a file \verb+plugins/hello/hello_plugin.mllib+, containing the -names of the OCaml modules bundled in the dynamic library: -\begin{verbatim} -Coq_hello -G_hello -\end{verbatim} -\item Append the following lines in \verb+plugins/plugins{byte,opt}.itarget+: -\begin{itemize} - \item in \verb+pluginsopt.itarget+: -\begin{verbatim} -hello/hello_plugin.cmxa -\end{verbatim} - \item in \verb+pluginsbyte.itarget+: -\begin{verbatim} -hello/hello_plugin.cma -\end{verbatim} -\end{itemize} -\item In the root directory of the Coq source location, modify the file -\verb+Makefile.common+: - \begin{itemize} - \item add \verb+hello+ to the \verb+SRCDIR+ definition (second argument of the - \verb+addprefix+ function); - \item in the section ``Object and Source files'', add \verb+HELLOCMA:=plugins/hello/hello_plugin.cma+; - \item add \verb+$(HELLOCMA)+ to the \verb+PLUGINSCMA+ definition. - \end{itemize} -\item Modify the file \verb+Makefile.build+, adding in section ``3) plugins'' the -line: -\begin{verbatim} -hello: $(HELLOCMA) -\end{verbatim} -\item From the command line, run \verb+make hello+, then \verb+make plugins/hello/hello_plugin.cmxs+. -\end{enumerate} -The call to the tactic \verb+hello+ from a Coq script has to be preceded by -\verb+Declare ML Module "hello_plugin"+, which will load the dynamic object -\verb+hello_plugin.cmxs+. For instance: -\begin{verbatim} -Declare ML Module "hello_plugin". -Variable A:Prop. -Goal A-> A. -Proof. -hello. -auto. -Qed. -\end{verbatim} - - -\section{Case studies} - -\iffalse -\Question{How can I define vectors or lists of size n?} -\fi - - -\Question{How to prove that 2 sets are different?} - - You need to find a property true on one set and false on the -other one. As an example we show how to prove that {\tt bool} and {\tt -nat} are discriminable. As discrimination property we take the -property to have no more than 2 elements. - -\begin{coq_example*} -Theorem nat_bool_discr : bool <> nat. -Proof. - pose (discr := - fun X:Set => - ~ (forall a b:X, ~ (forall x:X, x <> a -> x <> b -> False))). - intro Heq; assert (H: discr bool). - intro H; apply (H true false); destruct x; auto. - rewrite Heq in H; apply H; clear H. - destruct a; destruct b as [|n]; intro H0; eauto. - destruct n; [ apply (H0 2); discriminate | eauto ]. -Qed. -\end{coq_example*} - -\Question{Is there an axiom-free proof of Streicher's axiom $K$ for -the equality on {\tt nat}?} -\label{K-nat} - -Yes, because equality is decidable on {\tt nat}. Here is the proof. - -\begin{coq_example*} -Require Import Eqdep_dec. -Require Import Peano_dec. -Theorem K_nat : - forall (x:nat) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. -Proof. -intros; apply K_dec_set with (p := p). -apply eq_nat_dec. -assumption. -Qed. -\end{coq_example*} - -Similarly, we have - -\begin{coq_example*} -Theorem eq_rect_eq_nat : - forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h. -Proof. -intros; apply K_nat with (p := h); reflexivity. -Qed. -\end{coq_example*} - -\Question{How to prove that two proofs of {\tt n<=m} on {\tt nat} are equal?} -\label{le-uniqueness} - -This is provable without requiring any axiom because axiom $K$ -directly holds on {\tt nat}. Here is a proof using question \ref{K-nat}. - -\begin{coq_example*} -Require Import Arith. -Scheme le_ind' := Induction for le Sort Prop. -Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q. -Proof. -induction p using le_ind'; intro q. - replace (le_n n) with - (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl). - 2:reflexivity. - generalize (eq_refl n). - pattern n at 2 4 6 10, q; case q; [intro | intros m l e]. - rewrite <- eq_rect_eq_nat; trivial. - contradiction (le_Sn_n m); rewrite <- e; assumption. - replace (le_S n m p) with - (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ eq_refl). - 2:reflexivity. - generalize (eq_refl (S m)). - pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS]. - contradiction (le_Sn_n m); rewrite Heq; assumption. - injection HeqS; intro Heq; generalize l HeqS. - rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat. - rewrite (IHp l0); reflexivity. -Qed. -\end{coq_example*} - -\Question{How to exploit equalities on sets} - -To extract information from an equality on sets, you need to -find a predicate of sets satisfied by the elements of the sets. As an -example, let's consider the following theorem. - -\begin{coq_example*} -Theorem interval_discr : - forall m n:nat, - {x : nat | x <= m} = {x : nat | x <= n} -> m = n. -\end{coq_example*} - -We have a proof requiring the axiom of proof-irrelevance. We -conjecture that proof-irrelevance can be circumvented by introducing a -primitive definition of discrimination of the proofs of -\verb!{x : nat | x <= m}!. - -\begin{latexonly}% -The proof can be found in file {\tt interval$\_$discr.v} in this directory. -%Here is the proof -%\begin{small} -%\begin{flushleft} -%\begin{texttt} -%\def_{\ifmmode\sb\else\subscr\fi} -%\include{interval_discr.v} -%%% WARNING semantics of \_ has changed ! -%\end{texttt} -%$a\_b\_c$ -%\end{flushleft} -%\end{small} -\end{latexonly}% -\begin{htmlonly}% -\ahref{./interval_discr.v}{Here} is the proof. -\end{htmlonly} - -\Question{I have a problem of dependent elimination on -proofs, how to solve it?} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Inductive Def1 : Set := c1 : Def1. -Inductive DefProp : Def1 -> Prop := - c2 : forall d:Def1, DefProp d. -Inductive Comb : Set := - c3 : forall d:Def1, DefProp d -> Comb. -Lemma eq_comb : - forall (d1 d1':Def1) (d2:DefProp d1) (d2':DefProp d1'), - d1 = d1' -> c3 d1 d2 = c3 d1' d2'. -\end{coq_example*} - - You need to derive the dependent elimination -scheme for DefProp by hand using {\coqtt Scheme}. - -\begin{coq_eval} -Abort. -\end{coq_eval} - -\begin{coq_example*} -Scheme DefProp_elim := Induction for DefProp Sort Prop. -Lemma eq_comb : - forall d1 d1':Def1, - d1 = d1' -> - forall (d2:DefProp d1) (d2':DefProp d1'), c3 d1 d2 = c3 d1' d2'. -intros. -destruct H. -destruct d2 using DefProp_elim. -destruct d2' using DefProp_elim. -reflexivity. -Qed. -\end{coq_example*} - - -\Question{And what if I want to prove the following?} - -\begin{coq_example*} -Inductive natProp : nat -> Prop := - | p0 : natProp 0 - | pS : forall n:nat, natProp n -> natProp (S n). -Inductive package : Set := - pack : forall n:nat, natProp n -> package. -Lemma eq_pack : - forall n n':nat, - n = n' -> - forall (np:natProp n) (np':natProp n'), pack n np = pack n' np'. -\end{coq_example*} - - - -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example*} -Scheme natProp_elim := Induction for natProp Sort Prop. -Definition pack_S : package -> package. -destruct 1. -apply (pack (S n)). -apply pS; assumption. -Defined. -Lemma eq_pack : - forall n n':nat, - n = n' -> - forall (np:natProp n) (np':natProp n'), pack n np = pack n' np'. -intros n n' Heq np np'. -generalize dependent n'. -induction np using natProp_elim. -induction np' using natProp_elim; intros; auto. - discriminate Heq. -induction np' using natProp_elim; intros; auto. - discriminate Heq. -change (pack_S (pack n np) = pack_S (pack n0 np')). -apply (f_equal (A:=package)). -apply IHnp. -auto. -Qed. -\end{coq_example*} - - - - - - - -\section{Publishing tools} - -\Question{How can I generate some latex from my development?} - -You can use {\tt coqdoc}. - -\Question{How can I generate some HTML from my development?} - -You can use {\tt coqdoc}. - -\Question{How can I generate some dependency graph from my development?} - -You can use the tool \verb|coqgraph| developed by Philippe Audebaud in 2002. -This tool transforms dependencies generated by \verb|coqdep| into 'dot' files which can be visualized using the Graphviz software (http://www.graphviz.org/). - -\Question{How can I cite some {\Coq} in my latex document?} - -You can use {\tt coq\_tex}. - -\Question{How can I cite the {\Coq} reference manual?} - -You can use this bibtex entry (to adapt to the appropriate version): -\begin{verbatim} -@manual{Coq:manual, - author = {{Coq} {Development} {Team}, The}, - title = {The {Coq} Proof Assistant Reference Manual, version 8.7}, - month = Oct, - year = {2017}, - url = {http://coq.inria.fr} -} -\end{verbatim} - -\Question{Where can I publish my developments in {\Coq}?} - -You can submit your developments as a user contribution to the {\Coq} -development team. This ensures its liveness along the evolution and -possible changes of {\Coq}. - -You can also submit your developments to the HELM/MoWGLI repository at -the University of Bologna (see -\ahref{http://mowgli.cs.unibo.it}{\url{http://mowgli.cs.unibo.it}}). For -developments submitted in this database, it is possible to visualize -the developments in natural language and execute various retrieving -requests. - -\Question{How can I read my proof in natural language?} - -You can submit your proof to the HELM/MoWGLI repository and use the -rendering tool provided by the server (see -\ahref{http://mowgli.cs.unibo.it}{\url{http://mowgli.cs.unibo.it}}). - -\section{\CoqIde} - -\Question{What is {\CoqIde}?} - -{\CoqIde} is a gtk based GUI for \Coq. - -\Question{How to enable Emacs keybindings?} - -If in Gnome, run the gnome configuration editor (\texttt{gconf-editor}) -and set key \texttt{gtk-key-theme} to \texttt{Emacs} in the category -\texttt{desktop/gnome/interface}. - -Otherwise, you need to find where the \verb#gtk-key-theme-name# option is located in -your configuration, and set it to \texttt{Emacs}. Usually, it is in the -\verb#$(HOME)/.gtkrc-2.0# file. - - -%$ juste pour que la coloration emacs marche - -\Question{How to enable antialiased fonts?} - - Set the \verb#GDK_USE_XFT# variable to \verb#1#. This is by default - with \verb#Gtk >= 2.2#. If some of your fonts are not available, - set \verb#GDK_USE_XFT# to \verb#0#. - -\Question{How to use those Forall and Exists pretty symbols?}\label{forallcoqide} - Thanks to the notation features in \Coq, you just need to insert these -lines in your {\Coq} buffer:\\ -\begin{tt} -Notation "$\forall$ x : t, P" := (forall x:t, P) (at level 200, x ident). -\end{tt}\\ -\begin{tt} -Notation "$\exists$ x : t, P" := (exists x:t, P) (at level 200, x ident). -\end{tt} - -Copy/Paste of these lines from this file will not work outside of \CoqIde. -You need to load a file containing these lines or to enter the $\forall$ -using an input method (see \ref{inputmeth}). To try it just use \verb#Require Import utf8# from inside -\CoqIde. -To enable these notations automatically start coqide with -\begin{verbatim} - coqide -l utf8 -\end{verbatim} -In the ide subdir of {\Coq} library, you will find a sample utf8.v with some -pretty simple notations. - -\Question{How to define an input method for non ASCII symbols?}\label{inputmeth} - -\begin{itemize} -\item First solution: type \verb#<CONTROL><SHIFT>2200# to enter a forall in the script widow. - 2200 is the hexadecimal code for forall in unicode charts and is encoded as - in UTF-8. - 2203 is for exists. See \ahref{http://www.unicode.org}{\url{http://www.unicode.org}} for more codes. -\item Second solution: rebind \verb#<AltGr>a# to forall and \verb#<AltGr>e# to exists. - - Under X11, one can add those lines in the file ~/.xmodmaprc : - -\begin{verbatim} -! forall -keycode 24 = a A a A U2200 NoSymbol U2200 NoSymbol -! exists -keycode 26 = e E e E U2203 NoSymbol U2203 NoSymbol -\end{verbatim} -and then run xmodmap ~/.xmodmaprc. -\end{itemize} - - Alternatively, you may use an input method editor such as SCIM or iBus. -The latter offers a \LaTeX-like input method. - -\Question{How to customize the shortcuts for menus?} - Two solutions are offered: -\begin{itemize} -\item Edit \verb+$XDG_CONFIG_HOME/coq/coqide.keys+ (which is usually \verb+$HOME/.config/coq/coqide.keys+) by hand or -\item If your system supports it, from \CoqIde, you may select a menu entry and press the desired - shortcut. -\end{itemize} - -\Question{What encoding should I use? What is this $\backslash$x\{iiii\} in my file?} - The encoding option is related to the way files are saved. - Keep it as UTF-8 until it becomes important for you to exchange files - with non UTF-8 aware applications. - If you choose something else than UTF-8, then missing characters will - be encoded by $\backslash$x\{....\} or $\backslash$x\{........\} - where each dot is an hex. digit. - The number between braces is the hexadecimal UNICODE index for the - missing character. - -\Question{How to get rid of annoying unwanted automatic templates?} - -Some users may experiment problems with unwanted automatic -templates while using Coqide. This is due to a change in the -modifiers keys available through GTK. The straightest way to get -rid of the problem is to edit by hand your coqiderc (either -\verb|/home/<user>/.config/coq/coqiderc| under Linux, or \\ -\verb|C:\Documents and Settings\<user>\.config\coq\coqiderc| under Windows) -and replace any occurrence of \texttt{MOD4} by \texttt{MOD1}. - - - -\section{Extraction} - -\Question{What is program extraction?} - -Program extraction consist in generating a program from a constructive proof. - -\Question{Which language can I extract to?} - -You can extract your programs to Objective Caml and Haskell. - -\Question{How can I extract an incomplete proof?} - -You can provide programs for your axioms. - - - -%%%%%%% -\section{Glossary} - -\Question{Can you explain me what an evaluable constant is?} - -An evaluable constant is a constant which is unfoldable. - -\Question{What is a goal?} - -The goal is the statement to be proved. - -\Question{What is a meta variable?} - -A meta variable in {\Coq} represents a ``hole'', i.e. a part of a proof -that is still unknown. - -\Question{What is Gallina?} - -Gallina is the specification language of \Coq. Complete documentation -of this language can be found in the Reference Manual. - -\Question{What is The Vernacular?} - -It is the language of commands of Gallina i.e. definitions, lemmas, {\ldots} - - -\Question{What is a dependent type?} - -A dependent type is a type which depends on some term. For instance -``vector of size n'' is a dependent type representing all the vectors -of size $n$. Its type depends on $n$ - -\Question{What is a proof by reflection?} - -This is a proof generated by some computation which is done using the -internal reduction of {\Coq} (not using the tactic language of {\Coq} -(\Ltac) nor the implementation language for \Coq). An example of -tactic using the reflection mechanism is the {\ring} tactic. The -reflection method consist in reflecting a subset of {\Coq} language (for -example the arithmetical expressions) into an object of the {\Coq} -language itself (in this case an inductive type denoting arithmetical -expressions). For more information see~\cite{howe,harrison,boutin} -and the last chapter of the Coq'Art. - -\Question{What is intuitionistic logic?} - -This is any logic which does not assume that ``A or not A''. - - -\Question{What is proof-irrelevance?} - -See question \ref{proof-irrelevance} - - -\Question{What is the difference between opaque and transparent?}{\label{opaque}} - -Opaque definitions can not be unfolded but transparent ones can. - - -\section{Troubleshooting} - -\Question{What can I do when {\tt Qed.} is slow?} - -Sometime you can use the {\abstracttac} tactic, which makes as if you had -stated some local lemma, this speeds up the typing process. - -\Question{Why \texttt{Reset Initial.} does not work when using \texttt{coqc}?} - -The initial state corresponds to the state of \texttt{coqtop} when the interactive -session began. It does not make sense in files to compile. - - -\Question{What can I do if I get ``No more subgoals but non-instantiated existential variables''?} - -This means that {\eauto} or {\eapply} didn't instantiate an -existential variable which eventually got erased by some computation. -You may backtrack to the faulty occurrence of {\eauto} or {\eapply} -and give the missing argument an explicit value. Alternatively, you -can use the commands \texttt{Show Existentials.} and -\texttt{Existential.} to display and instantiate the remaining -existential variables. - - -\begin{coq_example} -Lemma example_show_existentials : forall a b c:nat, a=b -> b=c -> a=c. -Proof. -intros. -eapply eq_trans. -Show Existentials. -eassumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{What can I do if I get ``Cannot solve a second-order unification problem''?} - -You can help {\Coq} using the {\pattern} tactic. - - -\Question{I copy-paste a term and {\Coq} says it is not convertible - to the original term. Sometimes it even says the copied term is not -well-typed.} - - This is probably due to invisible implicit information (implicit -arguments, coercions and Cases annotations) in the printed term, which -is not re-synthesised from the copied-pasted term in the same way as -it is in the original term. - - Consider for instance {\tt (@eq Type True True)}. This term is -printed as {\tt True=True} and re-parsed as {\tt (@eq Prop True -True)}. The two terms are not convertible (hence they fool tactics -like {\tt pattern}). - - There is currently no satisfactory answer to the problem. However, -the command {\tt Set Printing All} is useful for diagnosing the -problem. - - Due to coercions, one may even face type-checking errors. In some -rare cases, the criterion to hide coercions is a bit too loose, which -may result in a typing error message if the parser is not able to find -again the missing coercion. - - - -\section{Conclusion and Farewell.} -\label{ccl} - -\Question{What if my question isn't answered here?} -\label{lastquestion} - -Don't panic \verb+:-)+. You can try the {\Coq} manual~\cite{Coq:manual} for a technical -description of the prover. The Coq'Art~\cite{Coq:coqart} is the first -book written on {\Coq} and provides a comprehensive review of the -theorem prover as well as a number of example and exercises. Finally, -the tutorial~\cite{Coq:Tutorial} provides a smooth introduction to -theorem proving in \Coq. - - -%%%%%%% -\newpage -\nocite{LaTeX:intro} -\nocite{LaTeX:symb} -\bibliography{fk} - -%%%%%%% -\typeout{*********************************************} -\typeout{********* That makes {\thequestion} questions **********} -\typeout{*********************************************} - -\end{document} diff --git a/doc/faq/axioms.fig b/doc/faq/axioms.fig deleted file mode 100644 index 963178503..000000000 --- a/doc/faq/axioms.fig +++ /dev/null @@ -1,131 +0,0 @@ -#FIG 3.2 Produced by xfig version 3.2.5c -Landscape -Center -Inches -Letter -100.00 -Single --2 -1200 2 -5 1 0 1 0 7 50 -1 -1 0.000 0 1 1 0 14032.500 7222.500 4725 3825 4425 4800 4200 6000 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 0 1 3600.000 8925.000 3600 9075 3450 8925 3600 8775 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 0 1 3600.000 8625.000 3600 8775 3450 8625 3600 8475 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8325.000 3600 8475 3450 8325 3600 8175 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8625.000 3600 8775 3450 8625 3600 8475 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8925.000 3600 9075 3450 8925 3600 8775 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 9225.000 3600 9375 3450 9225 3600 9075 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 1 1 0 6309.515 5767.724 4200 3825 3450 5550 3825 7200 - 1 1 1.00 60.00 120.00 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7725 3900 7200 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7200 6225 7200 7050 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 5550 5625 5550 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 3375 3225 3375 3600 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3373 1950 3376 2250 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 3375 2625 3375 3000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 2175 3600 3750 3600 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 2475 2475 2475 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3374 1125 3377 1425 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 975 1575 975 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 1725 2025 1725 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 4 - 8025 5925 8250 5925 9000 4950 9150 4950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 8625 5400 8250 3900 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7050 7350 4575 7950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4200 7500 4200 7950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 1139 2771 1364 3521 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4425 4875 7350 3825 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1048 1125 1051 1425 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1049 1950 1052 2250 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1500 3900 2175 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4575 6000 6450 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4714 6255 7039 7080 -2 1 0 1 -1 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4200 6225 4200 7200 -3 0 0 1 0 7 50 -1 -1 0.000 0 0 0 4 - 6450 7050 4050 6675 3750 6825 3750 7050 - 0.000 1.000 1.000 0.000 -4 0 -1 50 -1 2 12 0.0000 2 135 1440 3675 6225 Excluded-middle\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1065 450 1050 Operator iota\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2850 3150 2400 Constructive indefinite description\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 3150 2625 in propositional context\001 -4 0 -1 50 -1 0 12 0.0000 2 135 2235 450 2400 Constructive definite descr.\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 450 2625 in propositional context\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1995 3825 3750 Relational choice axiom\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 6900 3750 Predicate extensionality\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1710 1275 5025 (if Set impredicative)\001 -4 0 -1 50 -1 0 12 0.0000 2 165 1065 3750 5250 (Diaconescu)\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2070 4950 5550 Propositional degeneracy\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2310 6150 6150 Propositional extensionality\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2325 4950 6525 (needs Prop-impredicativity)\001 -4 0 -1 50 -1 0 12 0.0000 2 165 720 6000 6750 (Berardi)\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1725 1575 6225 Not excluded-middle\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2730 3375 7425 Decidability of equality on any A\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1170 3600 8175 Axiom K on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 4035 3600 8475 Uniqueness of reflexivity proofs for equality on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2865 3600 8775 Uniqueness of equality proofs on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 5220 3600 9375 Invariance by substitution of reflexivity proofs for equality on A\001 -4 0 -1 50 -1 2 12 0.0000 2 180 2145 9000 5175 Functional extensionality\001 -4 0 -1 50 -1 2 12 0.0000 2 180 3585 3600 9075 Injectivity of equality on Sigma-types on A\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1515 6450 7275 Proof-irrelevance\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1440 3150 1050 Operator epsilon\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1080 3150 1650 Constructive\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1785 3150 1875 indefinite description\001 -4 0 -1 50 -1 2 12 0.0000 2 135 2085 3150 3150 Functional choice axiom\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1080 450 1650 Constructive\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1620 450 1875 definite description\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1980 450 3750 Axiom of unique choice\001 diff --git a/doc/faq/fk.bib b/doc/faq/fk.bib deleted file mode 100644 index 3410427de..000000000 --- a/doc/faq/fk.bib +++ /dev/null @@ -1,2221 +0,0 @@ -%%%%%%% FAQ %%%%%%% - -@book{ProofsTypes, - Author="Girard, Jean-Yves and Yves Lafont and Paul Taylor", - Title="Proofs and Types", - Publisher="Cambrige Tracts in Theoretical Computer Science, Cambridge University Press", - Year="1989" -} - -@misc{Types:Dowek, - author = "Gilles Dowek", - title = "Th{\'e}orie des types", - year = 2002, - howpublished = "Lecture notes", - url= "http://www.lix.polytechnique.fr/~dowek/Cours/theories_des_types.ps.gz" -} - -@PHDTHESIS{EGThese, - author = {Eduardo Giménez}, - title = {Un Calcul de Constructions Infinies et son application -a la vérification de systèmes communicants}, - type = {thèse d'Université}, - school = {Ecole Normale Supérieure de Lyon}, - month = {December}, - year = {1996}, -} - - -%%%%%%% Semantique %%%%%%% - -@misc{Sem:cours, - author = "François Pottier", - title = "{Typage et Programmation}", - year = "2002", - howpublished = "Lecture notes", - note = "DEA PSPL" -} - -@inproceedings{Sem:Dubois, - author = {Catherine Dubois}, - editor = {Mark Aagaard and - John Harrison}, - title = "{Proving ML Type Soundness Within Coq}", - pages = {126-144}, - booktitle = {TPHOLs}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {1869}, - year = {2000}, - isbn = {3-540-67863-8}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@techreport{Sem:Plotkin, -author = {Gordon D. Plotkin}, -institution = {Aarhus University}, -number = {{DAIMI FN-19}}, -title = {{A structural approach to operational semantics}}, -year = {1981} -} - -@article{Sem:RemyV98, - author = "Didier R{\'e}my and J{\'e}r{\^o}me Vouillon", - title = "Objective {ML}: - An effective object-oriented extension to {ML}", - journal = "Theory And Practice of Object Systems", - year = 1998, - volume = "4", - number = "1", - pages = "27--50", - note = {A preliminary version appeared in the proceedings - of the 24th ACM Conference on Principles - of Programming Languages, 1997} -} - -@book{Sem:Winskel, - AUTHOR = {Winskel, Glynn}, - TITLE = {The Formal Semantics of Programming Languages}, - NOTE = {WIN g2 93:1 P-Ex}, - YEAR = {1993}, - PUBLISHER = {The MIT Press}, - SERIES = {Foundations of Computing}, - } - -@Article{Sem:WrightFelleisen, - refkey = "C1210", - title = "A Syntactic Approach to Type Soundness", - author = "Andrew K. Wright and Matthias Felleisen", - pages = "38--94", - journal = "Information and Computation", - month = "15~" # nov, - year = "1994", - volume = "115", - number = "1" -} - -@inproceedings{Sem:Nipkow-MOD, - author={Tobias Nipkow}, - title={Jinja: Towards a Comprehensive Formal Semantics for a - {J}ava-like Language}, - booktitle={Proc.\ Marktobderdorf Summer School 2003}, - publisher={IOS Press},editor={H. Schwichtenberg and K. Spies}, - year=2003, - note={To appear} -} - -%%%%%%% Coq %%%%%%% - -@book{Coq:coqart, - title = "Interactive Theorem Proving and Program Development, - Coq'Art: The Calculus of Inductive Constructions", - author = "Yves Bertot and Pierre Castéran", - publisher = "Springer Verlag", - series = "Texts in Theoretical Computer Science. An - EATCS series", - year = 2004 -} - -@phdthesis{Coq:Del01, - AUTHOR = "David Delahaye", - TITLE = "Conception de langages pour décrire les preuves et les - automatisations dans les outils d'aide à la preuve", - SCHOOL = {Universit\'e Paris~6}, - YEAR = "2001", - Type = {Th\`ese de Doctorat} -} - -@techreport{Coq:gimenez-tut, - author = "Eduardo Gim\'enez", - title = "A Tutorial on Recursive Types in Coq", - number = "RT-0221", - pages = "42 p.", - url = "citeseer.nj.nec.com/gimenez98tutorial.html" } - -@phdthesis{Coq:Mun97, - AUTHOR = "César Mu{\~{n}}oz", - TITLE = "Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types", - SCHOOL = {Universit\'e Paris~7}, - Number = {Unit\'e de recherche INRIA-Rocquencourt, TU-0488}, - YEAR = "1997", - Note = {English version available as INRIA research report RR-3309}, - Type = {Th\`ese de Doctorat} -} - -@PHDTHESIS{Coq:Filliatre99, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Preuve de programmes imp\'eratifs en th\'eorie des types}}, - TYPE = {Th{\`e}se de Doctorat}, - SCHOOL = {Universit\'e Paris-Sud}, - YEAR = 1999, - MONTH = {July}, -} - -@manual{Coq:Tutorial, - AUTHOR = {G\'erard Huet and Gilles Kahn and Christine Paulin-Mohring}, - TITLE = {{The Coq Proof Assistant A Tutorial}}, - YEAR = 2004 -} - -%%%%%%% PVS %%%%%%% - -@manual{PVS:prover, - title = "{PVS} Prover Guide", - author = "N. Shankar and S. Owre and J. M. Rushby and D. W. J. - Stringer-Calvert", - month = sep, - year = "1999", - organization = "Computer Science Laboratory, SRI International", - address = "Menlo Park, CA", -} - -@techreport{PVS-Semantics:TR, - TITLE = {The Formal Semantics of {PVS}}, - AUTHOR = {Sam Owre and Natarajan Shankar}, - NUMBER = {CR-1999-209321}, - INSTITUTION = {Computer Science Laboratory, SRI International}, - ADDRESS = {Menlo Park, CA}, - MONTH = may, - YEAR = 1999, -} - -@techreport{PVS-Tactics:DiVito, - TITLE = {A {PVS} Prover Strategy Package for Common Manipulations}, - AUTHOR = {Ben L. Di Vito}, - NUMBER = {TM-2002-211647}, - INSTITUTION = {Langley Research Center}, - ADDRESS = {Hampton, VA}, - MONTH = apr, - YEAR = 2002, -} - -@misc{PVS-Tactics:cours, - author = "César Muñoz", - title = "Strategies in {PVS}", - howpublished = "Lecture notes", - note = "National Institute of Aerospace", - year = 2002 -} - -@techreport{PVS-Tactics:field, - author = "C. Mu{\~n}oz and M. Mayero", - title = "Real Automation in the Field", - institution = "ICASE-NASA Langley", - number = "NASA/CR-2001-211271 Interim ICASE Report No. 39", - month = "dec", - year = "2001" -} - -%%%%%%% Autres Prouveurs %%%%%%% - -@misc{ACL2:repNuPrl, - author = "James L. Caldwell and John Cowles", - title = "{Representing Nuprl Proof Objects in ACL2: toward a proof checker for Nuprl}", - url = "http://www.cs.uwyo.edu/~jlc/papers/proof_checking.ps" } - -@inproceedings{Elan:ckl-strat, - author = {H. Cirstea and C. Kirchner and L. Liquori}, - title = "{Rewrite Strategies in the Rewriting Calculus}", - booktitle = {WRLA'02}, - publisher = "{Elsevier Science B.V.}", - series = {Electronic Notes in Theoretical Computer Science}, - volume = {71}, - year = {2003}, -} - -@book{LCF:GMW, - author = {M. Gordon and R. Milner and C. Wadsworth}, - publisher = {sv}, - series = {lncs}, - volume = 78, - title = {Edinburgh {LCF}: A Mechanized Logic of Computation}, - year = 1979 -} - -%%%%%%% LaTeX %%%%%%% - -@manual{LaTeX:symb, - title = "The Great, Big List of \LaTeX\ Symbols", - author = "David Carlisle and Scott Pakin and Alexander Holt", - month = feb, - year = 2001, -} - -@manual{LaTeX:intro, - title = "The Not So Short Introduction to \LaTeX2e", - author = "Tobias Oetiker", - month = jan, - year = 1999, -} - -@MANUAL{CoqManualV7, - AUTHOR = {{The {Coq} Development Team}}, - TITLE = {{The Coq Proof Assistant Reference Manual -- Version - V7.1}}, - YEAR = {2001}, - MONTH = OCT, - NOTE = {http://coq.inria.fr} -} - -@MANUAL{CoqManual96, - TITLE = {The {Coq Proof Assistant Reference Manual} Version 6.1}, - AUTHOR = {B. Barras and S. Boutin and C. Cornes and J. Courant and - J.-C. Filli\^atre and - H. Herbelin and G. Huet and P. Manoury and C. Mu{\~{n}}oz and - C. Murthy and C. Parent and C. Paulin-Mohring and - A. Sa{\"\i}bi and B. Werner}, - ORGANIZATION = {{INRIA-Rocquencourt}-{CNRS-ENS Lyon}}, - URL = {ftp://ftp.inria.fr/INRIA/coq/V6.1/doc/Reference-Manual.dvi.gz}, - YEAR = 1996, - MONTH = DEC -} - -@MANUAL{CoqTutorial99, - AUTHOR = {G.~Huet and G.~Kahn and Ch.~Paulin-Mohring}, - TITLE = {The {\sf Coq} Proof Assistant - A tutorial - Version 6.3}, - MONTH = JUL, - YEAR = {1999}, - ABSTRACT = {http://coq.inria.fr/doc/tutorial.html} -} - -@MANUAL{CoqTutorialV7, - AUTHOR = {G.~Huet and G.~Kahn and Ch.~Paulin-Mohring}, - TITLE = {The {\sf Coq} Proof Assistant - A tutorial - Version 7.1}, - MONTH = OCT, - YEAR = {2001}, - NOTE = {http://coq.inria.fr} -} - -@TECHREPORT{modelpa2000, - AUTHOR = {B. Bérard and P. Castéran and E. Fleury and L. Fribourg - and J.-F. Monin and C. Paulin and A. Petit and D. Rouillard}, - TITLE = {Automates temporisés CALIFE}, - INSTITUTION = {Calife}, - YEAR = 2000, - URL = {http://www.loria.fr/projets/calife/WebCalifePublic/FOURNITURES/F1.1.ps.gz}, - TYPE = {Fourniture {F1.1}} -} - -@TECHREPORT{CaFrPaRo2000, - AUTHOR = {P. Castéran and E. Freund and C. Paulin and D. Rouillard}, - TITLE = {Bibliothèques Coq et Isabelle-HOL pour les systèmes de transitions et les p-automates}, - INSTITUTION = {Calife}, - YEAR = 2000, - URL = {http://www.loria.fr/projets/calife/WebCalifePublic/FOURNITURES/F5.4.ps.gz}, - TYPE = {Fourniture {F5.4}} -} - -@PROCEEDINGS{TPHOLs99, - TITLE = {International Conference on - Theorem Proving in Higher Order Logics (TPHOLs'99)}, - YEAR = 1999, - EDITOR = {Y. Bertot and G. Dowek and C. Paulin-Mohring and L. Th{\'e}ry}, - SERIES = {Lecture Notes in Computer Science}, - MONTH = SEP, - PUBLISHER = {{Sprin\-ger-Verlag}}, - ADDRESS = {Nice}, - TYPE_PUBLI = {editeur} -} - -@INPROCEEDINGS{Pau01, - AUTHOR = {Christine Paulin-Mohring}, - TITLE = {Modelisation of Timed Automata in {Coq}}, - BOOKTITLE = {Theoretical Aspects of Computer Software (TACS'2001)}, - PAGES = {298--315}, - YEAR = 2001, - EDITOR = {N. Kobayashi and B. Pierce}, - VOLUME = 2215, - SERIES = {Lecture Notes in Computer Science}, - PUBLISHER = {Springer-Verlag} -} - -@PHDTHESIS{Moh89b, - AUTHOR = {C. Paulin-Mohring}, - MONTH = JAN, - SCHOOL = {{Paris 7}}, - TITLE = {Extraction de programmes dans le {Calcul des Constructions}}, - TYPE = {Thèse d'université}, - YEAR = {1989}, - URL = {http://www.lri.fr/~paulin/these.ps.gz} -} - -@ARTICLE{HuMo92, - AUTHOR = {G. Huet and C. Paulin-Mohring}, - EDITION = {INRIA}, - JOURNAL = {Courrier du CNRS - Informatique}, - TITLE = {Preuves et Construction de Programmes}, - YEAR = {1992}, - CATEGORY = {national} -} - -@INPROCEEDINGS{LePa94, - AUTHOR = {F. Leclerc and C. Paulin-Mohring}, - TITLE = {Programming with Streams in {Coq}. A case study : The Sieve of Eratosthenes}, - EDITOR = {H. Barendregt and T. Nipkow}, - VOLUME = 806, - SERIES = {Lecture Notes in Computer Science}, - BOOKTITLE = {{Types for Proofs and Programs, Types' 93}}, - YEAR = 1994, - PUBLISHER = {Springer-Verlag} -} - -@INPROCEEDINGS{Moh86, - AUTHOR = {C. Mohring}, - ADDRESS = {Cambridge, MA}, - BOOKTITLE = {Symposium on Logic in Computer Science}, - PUBLISHER = {IEEE Computer Society Press}, - TITLE = {Algorithm Development in the {Calculus of Constructions}}, - YEAR = {1986} -} - -@INPROCEEDINGS{Moh89a, - AUTHOR = {C. Paulin-Mohring}, - ADDRESS = {Austin}, - BOOKTITLE = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - MONTH = JAN, - PUBLISHER = {ACM}, - TITLE = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - YEAR = {1989} -} - -@INCOLLECTION{Moh89c, - AUTHOR = {C. Paulin-Mohring}, - TITLE = {{R\'ealisabilit\'e et extraction de programmes}}, - BOOKTITLE = {Logique et Informatique : une introduction}, - PUBLISHER = {INRIA}, - YEAR = 1991, - EDITOR = {B. Courcelle}, - VOLUME = 8, - SERIES = {Collection Didactique}, - PAGES = {163-180}, - CATEGORY = {national} -} - -@INPROCEEDINGS{Moh93, - AUTHOR = {C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of the conference Typed Lambda Calculi a -nd Applications}, - EDITOR = {M. Bezem and J.-F. Groote}, - INSTITUTION = {LIP-ENS Lyon}, - NOTE = {LIP research report 92-49}, - NUMBER = 664, - SERIES = {Lecture Notes in Computer Science}, - TITLE = {{Inductive Definitions in the System {Coq} - Rules and Properties}}, - TYPE = {research report}, - YEAR = 1993 -} - -@ARTICLE{PaWe92, - AUTHOR = {C. Paulin-Mohring and B. Werner}, - JOURNAL = {Journal of Symbolic Computation}, - TITLE = {{Synthesis of ML programs in the system Coq}}, - VOLUME = {15}, - YEAR = {1993}, - PAGES = {607--640} -} - -@INPROCEEDINGS{Pau96, - AUTHOR = {C. Paulin-Mohring}, - TITLE = {Circuits as streams in {Coq} : Verification of a sequential multiplier}, - BOOKTITLE = {Types for Proofs and Programs, TYPES'95}, - EDITOR = {S. Berardi and M. Coppo}, - SERIES = {Lecture Notes in Computer Science}, - YEAR = 1996, - VOLUME = 1158 -} - -@PHDTHESIS{Pau96b, - AUTHOR = {Christine Paulin-Mohring}, - TITLE = {Définitions Inductives en Théorie des Types d'Ordre Supérieur}, - SCHOOL = {Université Claude Bernard Lyon I}, - YEAR = 1996, - MONTH = DEC, - TYPE = {Habilitation à diriger les recherches}, - URL = {http://www.lri.fr/~paulin/habilitation.ps.gz} -} - -@INPROCEEDINGS{PfPa89, - AUTHOR = {F. Pfenning and C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of Mathematical Foundations of Programming Semantics}, - NOTE = {technical report CMU-CS-89-209}, - PUBLISHER = {Springer-Verlag}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 442, - TITLE = {Inductively defined types in the {Calculus of Constructions}}, - YEAR = {1990} -} - -@MISC{krakatoa02, - AUTHOR = {Claude March\'e and Christine Paulin and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} proof tool}, - YEAR = 2002, - NOTE = {\url{http://krakatoa.lri.fr/}} -} - -@ARTICLE{marche03jlap, - AUTHOR = {Claude March{\'e} and Christine Paulin-Mohring and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} Tool for Certification of \textsc{Java/JavaCard} Programs annotated in \textsc{JML}}, - JOURNAL = {Journal of Logic and Algebraic Programming}, - YEAR = 2003, - NOTE = {To appear}, - URL = {http://krakatoa.lri.fr}, - TOPICS = {team} -} -@ARTICLE{marche04jlap, - AUTHOR = {Claude March{\'e} and Christine Paulin-Mohring and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} Tool for Certification of \textsc{Java/JavaCard} Programs annotated in \textsc{JML}}, - JOURNAL = {Journal of Logic and Algebraic Programming}, - YEAR = 2004, - VOLUME = 58, - NUMBER = {1--2}, - PAGES = {89--106}, - URL = {http://krakatoa.lri.fr}, - TOPICS = {team} -} - -@TECHREPORT{catano03deliv, - AUTHOR = {N{\'e}stor Cata{\~n}o and Marek Gawkowski and -Marieke Huisman and Bart Jacobs and Claude March{\'e} and Christine Paulin -and Erik Poll and Nicole Rauch and Xavier Urbain}, - TITLE = {Logical Techniques for Applet Verification}, - INSTITUTION = {VerifiCard Project}, - YEAR = 2003, - TYPE = {Deliverable}, - NUMBER = {5.2}, - TOPICS = {team}, - NOTE = {Available from \url{http://www.verificard.org}} -} - -@TECHREPORT{kmu2002rr, - AUTHOR = {Keiichirou Kusakari and Claude Marché and Xavier Urbain}, - TITLE = {Termination of Associative-Commutative Rewriting using Dependency Pairs Criteria}, - INSTITUTION = {LRI}, - YEAR = 2002, - TYPE = {Research Report}, - NUMBER = 1304, - TYPE_PUBLI = {interne}, - TOPICS = {team}, - NOTE = {\url{http://www.lri.fr/~urbain/textes/rr1304.ps.gz}}, - URL = {http://www.lri.fr/~urbain/textes/rr1304.ps.gz} -} - -@ARTICLE{marche2004jsc, - AUTHOR = {Claude March\'e and Xavier Urbain}, - TITLE = {Modular {\&} Incremental Proofs of {AC}-Termination}, - JOURNAL = {Journal of Symbolic Computation}, - YEAR = 2004, - TOPICS = {team} -} - -@INPROCEEDINGS{contejean03wst, - AUTHOR = {Evelyne Contejean and Claude Marché and Benjamin Monate and Xavier Urbain}, - TITLE = {{Proving Termination of Rewriting with {\sc C\textit{i}ME}}}, - CROSSREF = {wst03}, - PAGES = {71--73}, - NOTE = {\url{http://cime.lri.fr/}}, - URL = {http://cime.lri.fr/}, - YEAR = 2003, - TYPE_PUBLI = {icolcomlec}, - TOPICS = {team} -} - -@TECHREPORT{contejean04rr, - AUTHOR = {Evelyne Contejean and Claude March{\'e} and Ana-Paula Tom{\'a}s and Xavier Urbain}, - TITLE = {Mechanically proving termination using polynomial interpretations}, - INSTITUTION = {LRI}, - YEAR = {2004}, - TYPE = {Research Report}, - NUMBER = {1382}, - TYPE_PUBLI = {interne}, - TOPICS = {team}, - URL = {http://www.lri.fr/~urbain/textes/rr1382.ps.gz} -} - -@UNPUBLISHED{duran_sub, - AUTHOR = {Francisco Duran and Salvador Lucas and - Claude {March\'e} and {Jos\'e} Meseguer and Xavier Urbain}, - TITLE = {Termination of Membership Equational Programs}, - NOTE = {Submitted} -} - -@PROCEEDINGS{comon95lncs, - TITLE = {Term Rewriting}, - BOOKTITLE = {Term Rewriting}, - TOPICS = {team, cclserver}, - YEAR = 1995, - EDITOR = {Hubert Comon and Jean-Pierre Jouannaud}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {909}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - ORGANIZATION = {French Spring School of Theoretical Computer - Science}, - TYPE_PUBLI = {editeur}, - CLEF_LABO = {CJ95} -} - -@PROCEEDINGS{lics94, - TITLE = {Proceedings of the Ninth Annual IEEE Symposium on Logic - in Computer Science}, - BOOKTITLE = {Proceedings of the Ninth Annual IEEE Symposium on Logic - in Computer Science}, - YEAR = 1994, - MONTH = JUL, - ADDRESS = {Paris, France}, - ORGANIZATION = {{IEEE} Comp. Soc. Press} -} - -@PROCEEDINGS{rta91, - TITLE = {4th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {4th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Ronald. V. Book}, - YEAR = 1991, - MONTH = APR, - ADDRESS = {Como, Italy}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 488 -} - -@PROCEEDINGS{rta96, - TITLE = {7th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {7th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Harald Ganzinger}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1996, - MONTH = JUL, - ADDRESS = {New Brunswick, NJ, USA}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 1103 -} - -@PROCEEDINGS{rta97, - TITLE = {8th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {8th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Hubert Comon}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1997, - MONTH = JUN, - ADDRESS = {Barcelona, Spain}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {1232} -} - -@PROCEEDINGS{rta98, - TITLE = {9th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {9th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Tobias Nipkow}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1998, - MONTH = APR, - ADDRESS = {Tsukuba, Japan}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {1379} -} - -@PROCEEDINGS{rta00, - TITLE = {11th International Conference on Rewriting Techniques and Applications}, - BOOKTITLE = {11th International Conference on Rewriting Techniques and Applications}, - EDITOR = {Leo Bachmair}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 1833, - MONTH = JUL, - YEAR = 2000, - ADDRESS = {Norwich, UK} -} - -@PROCEEDINGS{srt95, - TITLE = {Proceedings of the Conference on Symbolic Rewriting - Techniques}, - BOOKTITLE = {Proceedings of the Conference on Symbolic Rewriting - Techniques}, - YEAR = 1995, - EDITOR = {Manuel Bronstein and Volker Weispfenning}, - ADDRESS = {Monte Verita, Switzerland} -} - -@BOOK{comon01cclbook, - BOOKTITLE = {Constraints in Computational Logics}, - TITLE = {Constraints in Computational Logics}, - EDITOR = {Hubert Comon and Claude March{\'e} and Ralf Treinen}, - YEAR = 2001, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 2002, - TOPICS = {team}, - TYPE_PUBLI = {editeur} -} - -@PROCEEDINGS{wst03, - BOOKTITLE = {{Extended Abstracts of the 6th International Workshop on Termination, WST'03}}, - TITLE = {{Extended Abstracts of the 6th International Workshop on Termination, WST'03}}, - YEAR = {2003}, - EDITOR = {Albert Rubio}, - MONTH = JUN, - NOTE = {Technical Report DSIC II/15/03, Universidad Politécnica de Valencia, Spain} -} - -@INPROCEEDINGS{FilliatreLetouzey03, - AUTHOR = {J.-C. Filli\^atre and P. Letouzey}, - TITLE = {{Functors for Proofs and Programs}}, - BOOKTITLE = {Proceedings of The European Symposium on Programming}, - YEAR = 2004, - ADDRESS = {Barcelona, Spain}, - MONTH = {March 29-April 2}, - NOTE = {To appear}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/fpp.ps.gz} -} - -@TECHREPORT{Filliatre03, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Why: a multi-language multi-prover verification tool}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1366}, - MONTH = {March}, - YEAR = 2003, - URL = {http://www.lri.fr/~filliatr/ftp/publis/why-tool.ps.gz} -} - -@ARTICLE{FilliatrePottier02, - AUTHOR = {J.-C. Filli{\^a}tre and F. Pottier}, - TITLE = {{Producing All Ideals of a Forest, Functionally}}, - JOURNAL = {Journal of Functional Programming}, - VOLUME = 13, - NUMBER = 5, - PAGES = {945--956}, - MONTH = {September}, - YEAR = 2003, - URL = {http://www.lri.fr/~filliatr/ftp/publis/kr-fp.ps.gz}, - ABSTRACT = { - We present a functional implementation of Koda and Ruskey's - algorithm for generating all ideals of a forest poset as a Gray - code. Using a continuation-based approach, we give an extremely - concise formulation of the algorithm's core. Then, in a number of - steps, we derive a first-order version whose efficiency is - comparable to a C implementation given by Knuth.} -} - -@UNPUBLISHED{FORS01, - AUTHOR = {J.-C. Filli{\^a}tre and S. Owre and H. Rue{\ss} and N. Shankar}, - TITLE = {Deciding Propositional Combinations of Equalities and Inequalities}, - NOTE = {Unpublished}, - MONTH = OCT, - YEAR = 2001, - URL = {http://www.lri.fr/~filliatr/ftp/publis/ics.ps}, - ABSTRACT = { - We address the problem of combining individual decision procedures - into a single decision procedure. Our combination approach is based - on using the canonizer obtained from Shostak's combination algorithm - for equality. We illustrate our approach with a combination - algorithm for equality, disequality, arithmetic inequality, and - propositional logic. Unlike the Nelson--Oppen combination where the - processing of equalities is distributed across different closed - decision procedures, our combination involves the centralized - processing of equalities in a single procedure. The termination - argument for the combination is based on that for Shostak's - algorithm. We also give soundness and completeness arguments.} -} - -@INPROCEEDINGS{ICS, - AUTHOR = {J.-C. Filli{\^a}tre and S. Owre and H. Rue{\ss} and N. Shankar}, - TITLE = {{ICS: Integrated Canonization and Solving (Tool presentation)}}, - BOOKTITLE = {Proceedings of CAV'2001}, - EDITOR = {G. Berry and H. Comon and A. Finkel}, - PUBLISHER = {Springer-Verlag}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 2102, - PAGES = {246--249}, - YEAR = 2001 -} - -@INPROCEEDINGS{Filliatre01a, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {La supériorité de l'ordre supérieur}, - BOOKTITLE = {Journées Francophones des Langages Applicatifs}, - PAGES = {15--26}, - MONTH = {Janvier}, - YEAR = 2002, - ADDRESS = {Anglet, France}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/sos.ps.gz}, - CODE = {http://www.lri.fr/~filliatr/ftp/ocaml/misc/koda-ruskey.ps}, - ABSTRACT = { - Nous présentons ici une écriture fonctionnelle de l'algorithme de - Koda-Ruskey, un algorithme pour engendrer une large famille - de codes de Gray. En s'inspirant de techniques de programmation par - continuation, nous aboutissons à un code de neuf lignes seulement, - bien plus élégant que les implantations purement impératives - proposées jusqu'ici, notamment par Knuth. Dans un second temps, - nous montrons comment notre code peut être légèrement modifié pour - aboutir à une version de complexité optimale. - Notre implantation en Objective Caml rivalise d'efficacité avec les - meilleurs codes C. Nous détaillons les calculs de complexité, - un exercice intéressant en présence d'ordre supérieur et d'effets de - bord combinés.} -} - -@TECHREPORT{Filliatre00c, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Design of a proof assistant: Coq version 7}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1369}, - MONTH = {October}, - YEAR = 2000, - URL = {http://www.lri.fr/~filliatr/ftp/publis/coqv7.ps.gz}, - ABSTRACT = { - We present the design and implementation of the new version of the - Coq proof assistant. The main novelty is the isolation of the - critical part of the system, which consists in a type checker for - the Calculus of Inductive Constructions. This kernel is now - completely independent of the rest of the system and has been - rewritten in a purely functional way. This leads to greater clarity - and safety, without compromising efficiency. It also opens the way to - the ``bootstrap'' of the Coq system, where the kernel will be - certified using Coq itself.} -} - -@TECHREPORT{Filliatre00b, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Hash consing in an ML framework}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1368}, - MONTH = {September}, - YEAR = 2000, - URL = {http://www.lri.fr/~filliatr/ftp/publis/hash-consing.ps.gz}, - ABSTRACT = { - Hash consing is a technique to share values that are structurally - equal. Beyond the obvious advantage of saving memory blocks, hash - consing may also be used to gain speed in several operations (like - equality test) and data structures (like sets or maps) when sharing is - maximal. However, physical adresses cannot be used directly for this - purpose when the garbage collector is likely to move blocks - underneath. We present an easy solution in such a framework, with - many practical benefits.} -} - -@MISC{ocamlweb, - AUTHOR = {J.-C. Filli\^atre and C. March\'e}, - TITLE = {{ocamlweb, a literate programming tool for Objective Caml}}, - NOTE = {Available at \url{http://www.lri.fr/~filliatr/ocamlweb/}}, - URL = {http://www.lri.fr/~filliatr/ocamlweb/} -} - -@ARTICLE{Filliatre00a, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Verification of Non-Functional Programs - using Interpretations in Type Theory}}, - JOURNAL = {Journal of Functional Programming}, - VOLUME = 13, - NUMBER = 4, - PAGES = {709--745}, - MONTH = {July}, - YEAR = 2003, - NOTE = {English translation of~\cite{Filliatre99}.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - ABSTRACT = {We study the problem of certifying programs combining imperative and - functional features within the general framework of type theory. - - Type theory constitutes a powerful specification language, which is - naturally suited for the proof of purely functional programs. To - deal with imperative programs, we propose a logical interpretation - of an annotated program as a partial proof of its specification. The - construction of the corresponding partial proof term is based on a - static analysis of the effects of the program, and on the use of - monads. The usual notion of monads is refined in order to account - for the notion of effect. The missing subterms in the partial proof - term are seen as proof obligations, whose actual proofs are left to - the user. We show that the validity of those proof obligations - implies the total correctness of the program. - We also establish a result of partial completeness. - - This work has been implemented in the Coq proof assistant. - It appears as a tactic taking an annotated program as argument and - generating a set of proof obligations. Several nontrivial - algorithms have been certified using this tactic.} -} - -@ARTICLE{Filliatre99c, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Formal Proof of a Program: Find}}, - JOURNAL = {Science of Computer Programming}, - YEAR = 2001, - NOTE = {To appear}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}, - ABSTRACT = {In 1971, C.~A.~R.~Hoare gave the proof of correctness and termination of a - rather complex algorithm, in a paper entitled \emph{Proof of a - program: Find}. It is a hand-made proof, where the - program is given together with its formal specification and where - each step is fully - justified by a mathematical reasoning. We present here a formal - proof of the same program in the system Coq, using the - recent tactic of the system developed to establishing the total - correctness of - imperative programs. We follow Hoare's paper as close as - possible, keeping the same program and the same specification. We - show that we get exactly the same proof obligations, which are - proved in a straightforward way, following the original paper. - We also explain how more informal reasonings of Hoare's proof are - formalized in the system Coq. - This demonstrates the adequacy of the system Coq in the - process of certifying imperative programs.} -} - -@TECHREPORT{Filliatre99b, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{A theory of monads parameterized by effects}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1367}, - MONTH = {November}, - YEAR = 1999, - URL = {http://www.lri.fr/~filliatr/ftp/publis/monads.ps.gz}, - ABSTRACT = {Monads were introduced in computer science to express the semantics - of programs with computational effects, while type and effect - inference was introduced to mark out those effects. - In this article, we propose a combination of the notions of effects - and monads, where the monadic operators are parameterized by effects. - We establish some relationships between those generalized monads and - the classical ones. - Then we use a generalized monad to translate imperative programs - into purely functional ones. We establish the correctness of that - translation. This work has been put into practice in the Coq proof - assistant to establish the correctness of imperative programs.} -} - -@PHDTHESIS{Filliatre99, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Preuve de programmes imp\'eratifs en th\'eorie des types}}, - TYPE = {Th{\`e}se de Doctorat}, - SCHOOL = {Universit\'e Paris-Sud}, - YEAR = 1999, - MONTH = {July}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}, - ABSTRACT = {Nous étudions le problème de la certification de programmes mêlant - traits impératifs et fonctionnels dans le cadre de la théorie des - types. - - La théorie des types constitue un puissant langage de spécification, - naturellement adapté à la preuve de programmes purement - fonctionnels. Pour y certifier également des programmes impératifs, - nous commençons par exprimer leur sémantique de manière purement - fonctionnelle. Cette traduction repose sur une analyse statique des - effets de bord des programmes, et sur l'utilisation de la notion de - monade, notion que nous raffinons en l'associant à la notion d'effet - de manière générale. Nous montrons que cette traduction est - sémantiquement correcte. - - Puis, à partir d'un programme annoté, nous construisons une preuve - de sa spécification, traduite de manière fonctionnelle. Cette preuve - est bâtie sur la traduction fonctionnelle précédemment - introduite. Elle est presque toujours incomplète, les parties - manquantes étant autant d'obligations de preuve qui seront laissées - à la charge de l'utilisateur. Nous montrons que la validité de ces - obligations entraîne la correction totale du programme. - - Nous avons implanté notre travail dans l'assistant de preuve - Coq, avec lequel il est dès à présent distribué. Cette - implantation se présente sous la forme d'une tactique prenant en - argument un programme annoté et engendrant les obligations de - preuve. Plusieurs algorithmes non triviaux ont été certifiés à - l'aide de cet outil (Find, Quicksort, Heapsort, algorithme de - Knuth-Morris-Pratt).} -} - -@INPROCEEDINGS{FilliatreMagaud99, - AUTHOR = {J.-C. Filli\^atre and N. Magaud}, - TITLE = {{Certification of sorting algorithms in the system Coq}}, - BOOKTITLE = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - YEAR = 1999, - ABSTRACT = {We present the formal proofs of total correctness of three sorting - algorithms in the system Coq, namely \textit{insertion sort}, - \textit{quicksort} and \textit{heapsort}. The implementations are - imperative programs working in-place on a given array. Those - developments demonstrate the usefulness of inductive types and higher-order - logic in the process of software certification. They also - show that the proof of rather complex algorithms may be done in a - small amount of time --- only a few days for each development --- - and without great difficulty.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz} -} - -@INPROCEEDINGS{Filliatre98, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Proof of Imperative Programs in Type Theory}}, - BOOKTITLE = {International Workshop, TYPES '98, Kloster Irsee, Germany}, - PUBLISHER = {Springer-Verlag}, - VOLUME = 1657, - SERIES = {Lecture Notes in Computer Science}, - MONTH = MAR, - YEAR = {1998}, - ABSTRACT = {We present a new approach to certifying imperative programs, - in the context of Type Theory. - The key is a functional translation of imperative programs, which is - made possible by an analysis of their effects. - On sequential imperative programs, we get the same proof - obligations as those given by Floyd-Hoare logic, - but our approach also includes functional constructions. - As a side-effect, we propose a way to eradicate the use of auxiliary - variables in specifications. - This work has been implemented in the Coq Proof Assistant and applied - on non-trivial examples.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/types98.ps.gz} -} - -@TECHREPORT{Filliatre97, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP - ENS Lyon}, - NUMBER = {97--04}, - TITLE = {{Finite Automata Theory in Coq: - A constructive proof of Kleene's theorem}}, - TYPE = {Research Report}, - MONTH = {February}, - YEAR = {1997}, - ABSTRACT = {We describe here a development in the system Coq - of a piece of Finite Automata Theory. The main result is the Kleene's - theorem, expressing that regular expressions and finite automata - define the same languages. From a constructive proof of this result, - we automatically obtain a functional program that compiles any - regular expression into a finite automata, which constitutes the main - part of the implementation of {\tt grep}-like programs. This - functional program is obtained by the automatic method of {\em - extraction} which removes the logical parts of the proof to keep only - its informative contents. Starting with an idea of what we would - have written in ML, we write the specification and do the proofs in - such a way that we obtain the expected program, which is therefore - efficient.}, - URL = {ftp://ftp.ens-lyon.fr/pub/LIP/Rapports/RR/RR97/RR97-04.ps.Z} -} - -@TECHREPORT{Filliatre95, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP - ENS Lyon}, - NUMBER = {96--25}, - TITLE = {{A decision procedure for Direct Predicate - Calculus: study and implementation in - the Coq system}}, - TYPE = {Research Report}, - MONTH = {February}, - YEAR = {1995}, - ABSTRACT = {The paper of J. Ketonen and R. Weyhrauch \emph{A - decidable fragment of Predicate Calculus} defines a decidable - fragment of first-order predicate logic - Direct Predicate Calculus - - as the subset which is provable in Gentzen sequent calculus - without the contraction rule, and gives an effective decision - procedure for it. This report is a detailed study of this - procedure. We extend the decidability to non-prenex formulas. We - prove that the intuitionnistic fragment is still decidable, with a - refinement of the same procedure. An intuitionnistic version has - been implemented in the Coq system using a translation into - natural deduction.}, - URL = {ftp://ftp.ens-lyon.fr/pub/LIP/Rapports/RR/RR96/RR96-25.ps.Z} -} - -@TECHREPORT{Filliatre94, - AUTHOR = {J.-C. Filli\^atre}, - MONTH = {Juillet}, - INSTITUTION = {Ecole Normale Sup\'erieure}, - TITLE = {{Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct~: \'etude et impl\'ementation dans le syst\`eme Coq}}, - TYPE = {Rapport de {DEA}}, - YEAR = {1994}, - URL = {ftp://ftp.lri.fr/LRI/articles/filliatr/memoire.dvi.gz} -} - -@TECHREPORT{CourantFilliatre93, - AUTHOR = {J. Courant et J.-C. Filli\^atre}, - MONTH = {Septembre}, - INSTITUTION = {Ecole Normale Sup\'erieure}, - TITLE = {{Formalisation de la th\'eorie des langages - formels en Coq}}, - TYPE = {Rapport de ma\^{\i}trise}, - YEAR = {1993}, - URL = {http://www.ens-lyon.fr/~jcourant/stage_maitrise.dvi.gz}, - URL2 = {http://www.ens-lyon.fr/~jcourant/stage_maitrise.ps.gz} -} - -@INPROCEEDINGS{tphols2000-Letouzey, - crossref = "tphols2000", - title = "Formalizing {S}t{\aa}lmarck's algorithm in {C}oq", - author = "Pierre Letouzey and Laurent Th{\'e}ry", - pages = "387--404"} - -@PROCEEDINGS{tphols2000, - editor = "J. Harrison and M. Aagaard", - booktitle = "Theorem Proving in Higher Order Logics: - 13th International Conference, TPHOLs 2000", - series = "Lecture Notes in Computer Science", - volume = 1869, - year = 2000, - publisher = "Springer-Verlag"} - -@InCollection{howe, - author = {Doug Howe}, - title = {Computation Meta theory in Nuprl}, - booktitle = {The Proceedings of the Ninth International Conference of Autom -ated Deduction}, - volume = {310}, - editor = {E. Lusk and R. Overbeek}, - publisher = {Springer-Verlag}, - pages = {238--257}, - year = {1988} -} - -@TechReport{harrison, - author = {John Harrison}, - title = {Meta theory and Reflection in Theorem Proving:a Survey and Cri -tique}, - institution = {SRI International Cambridge Computer Science Research Center}, - year = {1995}, - number = {CRC-053} -} - -@InCollection{cc, - author = {Thierry Coquand and Gérard Huet}, - title = {The Calculus of Constructions}, - booktitle = {Information and Computation}, - year = {1988}, - volume = {76}, - number = {2/3} -} - - -@InProceedings{coquandcci, - author = {Thierry Coquand and Christine Paulin-Mohring}, - title = {Inductively defined types}, - booktitle = {Proceedings of Colog'88}, - year = {1990}, - editor = {P. Martin-Löf and G. Mints}, - volume = {417}, - series = {LNCS}, - publisher = {Springer-Verlag} -} - - -@InProceedings{boutin, - author = {Samuel Boutin}, - title = {Using reflection to build efficient and certified decision pro -cedures.}, - booktitle = {Proceedings of TACS'97}, - year = {1997}, - editor = {M. Abadi and T. Ito}, - volume = {1281}, - series = {LNCS}, - publisher = {Springer-Verlag} -} - -@Manual{Coq:manual, - title = {The Coq proof assistant reference manual}, - author = {\mbox{The Coq development team}}, - organization = {LogiCal Project}, - note = {Version 8.0}, - year = {2004}, - url = "http://coq.inria.fr" -} - -@string{jfp = "Journal of Functional Programming"} -@STRING{lncs="Lecture Notes in Computer Science"} -@STRING{lnai="Lecture Notes in Artificial Intelligence"} -@string{SV = "{Sprin\-ger-Verlag}"} - -@INPROCEEDINGS{Aud91, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {Proceedings of the sixth Conf. on Logic in Computer Science.}, - PUBLISHER = {IEEE}, - TITLE = {Partial {Objects} in the {Calculus of Constructions}}, - YEAR = {1991} -} - -@PHDTHESIS{Aud92, - AUTHOR = {Ph. Audebaud}, - SCHOOL = {{Universit\'e} Bordeaux I}, - TITLE = {Extension du Calcul des Constructions par Points fixes}, - YEAR = {1992} -} - -@INPROCEEDINGS{Audebaud92b, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, - EDITOR = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, - NOTE = {Also Research Report LIP-ENS-Lyon}, - PAGES = {pp 21--34}, - TITLE = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, - YEAR = {1992} -} - -@INPROCEEDINGS{Augustsson85, - AUTHOR = {L. Augustsson}, - TITLE = {{Compiling Pattern Matching}}, - BOOKTITLE = {Conference Functional Programming and -Computer Architecture}, - YEAR = {1985} -} - -@ARTICLE{BaCo85, - AUTHOR = {J.L. Bates and R.L. Constable}, - JOURNAL = {ACM transactions on Programming Languages and Systems}, - TITLE = {Proofs as {Programs}}, - VOLUME = {7}, - YEAR = {1985} -} - -@BOOK{Bar81, - AUTHOR = {H.P. Barendregt}, - PUBLISHER = {North-Holland}, - TITLE = {The Lambda Calculus its Syntax and Semantics}, - YEAR = {1981} -} - -@TECHREPORT{Bar91, - AUTHOR = {H. Barendregt}, - INSTITUTION = {Catholic University Nijmegen}, - NOTE = {In Handbook of Logic in Computer Science, Vol II}, - NUMBER = {91-19}, - TITLE = {Lambda {Calculi with Types}}, - YEAR = {1991} -} - -@ARTICLE{BeKe92, - AUTHOR = {G. Bellin and J. Ketonen}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {115--142}, - TITLE = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, - VOLUME = {95}, - YEAR = {1992} -} - -@BOOK{Bee85, - AUTHOR = {M.J. Beeson}, - PUBLISHER = SV, - TITLE = {Foundations of Constructive Mathematics, Metamathematical Studies}, - YEAR = {1985} -} - -@BOOK{Bis67, - AUTHOR = {E. Bishop}, - PUBLISHER = {McGraw-Hill}, - TITLE = {Foundations of Constructive Analysis}, - YEAR = {1967} -} - -@BOOK{BoMo79, - AUTHOR = {R.S. Boyer and J.S. Moore}, - KEY = {BoMo79}, - PUBLISHER = {Academic Press}, - SERIES = {ACM Monograph}, - TITLE = {A computational logic}, - YEAR = {1979} -} - -@MASTERSTHESIS{Bou92, - AUTHOR = {S. Boutin}, - MONTH = sep, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Certification d'un compilateur {ML en Coq}}, - YEAR = {1992} -} - -@inproceedings{Bou97, - title = {Using reflection to build efficient and certified decision procedure -s}, - author = {S. Boutin}, - booktitle = {TACS'97}, - editor = {Martin Abadi and Takahashi Ito}, - publisher = SV, - series = lncs, - volume=1281, - PS={http://pauillac.inria.fr/~boutin/public_w/submitTACS97.ps.gz}, - year = {1997} -} - -@PhdThesis{Bou97These, - author = {S. Boutin}, - title = {R\'eflexions sur les quotients}, - school = {Paris 7}, - year = 1997, - type = {th\`ese d'Universit\'e}, - month = apr -} - -@ARTICLE{Bru72, - AUTHOR = {N.J. de Bruijn}, - JOURNAL = {Indag. Math.}, - TITLE = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, - VOLUME = {34}, - YEAR = {1972} -} - - -@INCOLLECTION{Bru80, - AUTHOR = {N.J. de Bruijn}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - PUBLISHER = {Academic Press}, - TITLE = {A survey of the project {Automath}}, - YEAR = {1980} -} - -@TECHREPORT{COQ93, - AUTHOR = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, - INSTITUTION = {INRIA}, - MONTH = may, - NUMBER = {154}, - TITLE = {{The Coq Proof Assistant User's Guide Version 5.8}}, - YEAR = {1993} -} - -@TECHREPORT{CPar93, - AUTHOR = {C. Parent}, - INSTITUTION = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - MONTH = oct, - NOTE = {Also in~\cite{Nijmegen93}}, - NUMBER = {93-29}, - TITLE = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, - YEAR = {1993} -} - -@PHDTHESIS{CPar95, - AUTHOR = {C. Parent}, - SCHOOL = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - TITLE = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, - YEAR = {1995} -} - -@BOOK{Caml, - AUTHOR = {P. Weis and X. Leroy}, - PUBLISHER = {InterEditions}, - TITLE = {Le langage Caml}, - YEAR = {1993} -} - -@INPROCEEDINGS{ChiPotSimp03, - AUTHOR = {Laurent Chicli and Lo\"{\i}c Pottier and Carlos Simpson}, - ADDRESS = {Berg en Dal, The Netherlands}, - TITLE = {Mathematical Quotients and Quotient Types in Coq}, - BOOKTITLE = {TYPES'02}, - PUBLISHER = SV, - SERIES = LNCS, - VOLUME = {2646}, - YEAR = {2003} -} - -@TECHREPORT{CoC89, - AUTHOR = {Projet Formel}, - INSTITUTION = {INRIA}, - NUMBER = {110}, - TITLE = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, - YEAR = {1989} -} - -@INPROCEEDINGS{CoHu85a, - AUTHOR = {Thierry Coquand and Gérard Huet}, - ADDRESS = {Linz}, - BOOKTITLE = {EUROCAL'85}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, - VOLUME = {203}, - YEAR = {1985} -} - -@INPROCEEDINGS{CoHu85b, - AUTHOR = {Thierry Coquand and Gérard Huet}, - BOOKTITLE = {Logic Colloquium'85}, - EDITOR = {The Paris Logic Group}, - PUBLISHER = {North-Holland}, - TITLE = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, - YEAR = {1987} -} - -@ARTICLE{CoHu86, - AUTHOR = {Thierry Coquand and Gérard Huet}, - JOURNAL = {Information and Computation}, - NUMBER = {2/3}, - TITLE = {The {Calculus of Constructions}}, - VOLUME = {76}, - YEAR = {1988} -} - -@INPROCEEDINGS{CoPa89, - AUTHOR = {Thierry Coquand and Christine Paulin-Mohring}, - BOOKTITLE = {Proceedings of Colog'88}, - EDITOR = {P. Martin-L\"of and G. Mints}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Inductively defined types}, - VOLUME = {417}, - YEAR = {1990} -} - -@BOOK{Con86, - AUTHOR = {R.L. {Constable et al.}}, - PUBLISHER = {Prentice-Hall}, - TITLE = {{Implementing Mathematics with the Nuprl Proof Development System}}, - YEAR = {1986} -} - -@PHDTHESIS{Coq85, - AUTHOR = {Thierry Coquand}, - MONTH = jan, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Une Th\'eorie des Constructions}, - YEAR = {1985} -} - -@INPROCEEDINGS{Coq86, - AUTHOR = {Thierry Coquand}, - ADDRESS = {Cambridge, MA}, - BOOKTITLE = {Symposium on Logic in Computer Science}, - PUBLISHER = {IEEE Computer Society Press}, - TITLE = {{An Analysis of Girard's Paradox}}, - YEAR = {1986} -} - -@INPROCEEDINGS{Coq90, - AUTHOR = {Thierry Coquand}, - BOOKTITLE = {Logic and Computer Science}, - EDITOR = {P. Oddifredi}, - NOTE = {INRIA Research Report 1088, also in~\cite{CoC89}}, - PUBLISHER = {Academic Press}, - TITLE = {{Metamathematical Investigations of a Calculus of Constructions}}, - YEAR = {1990} -} - -@INPROCEEDINGS{Coq91, - AUTHOR = {Thierry Coquand}, - BOOKTITLE = {Proceedings 9th Int. Congress of Logic, Methodology and Philosophy of Science}, - TITLE = {{A New Paradox in Type Theory}}, - MONTH = {August}, - YEAR = {1991} -} - -@INPROCEEDINGS{Coq92, - AUTHOR = {Thierry Coquand}, - TITLE = {{Pattern Matching with Dependent Types}}, - YEAR = {1992}, - crossref = {Bastad92} -} - -@INPROCEEDINGS{Coquand93, - AUTHOR = {Thierry Coquand}, - TITLE = {{Infinite Objects in Type Theory}}, - YEAR = {1993}, - crossref = {Nijmegen93} -} - -@MASTERSTHESIS{Cou94a, - AUTHOR = {J. Courant}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Explicitation de preuves par r\'ecurrence implicite}, - YEAR = {1994} -} - -@INPROCEEDINGS{Del99, - author = "Delahaye, D.", - title = "Information Retrieval in a Coq Proof Library using - Type Isomorphisms", - booktitle = {Proceedings of TYPES'99, L\"okeberg}, - publisher = SV, - series = lncs, - year = "1999", - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf TYPES99-SIsos.ps.gz}" -} - -@INPROCEEDINGS{Del00, - author = "Delahaye, D.", - title = "A {T}actic {L}anguage for the {S}ystem {{\sf Coq}}", - booktitle = "Proceedings of Logic for Programming and Automated Reasoning - (LPAR), Reunion Island", - publisher = SV, - series = LNCS, - volume = "1955", - pages = "85--95", - month = "November", - year = "2000", - url = - "{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf LPAR2000-ltac.ps.gz}" -} - -@INPROCEEDINGS{DelMay01, - author = "Delahaye, D. and Mayero, M.", - title = {{\tt Field}: une proc\'edure de d\'ecision pour les nombres r\'eels - en {\Coq}}, - booktitle = "Journ\'ees Francophones des Langages Applicatifs, Pontarlier", - publisher = "INRIA", - month = "Janvier", - year = "2001", - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf JFLA2000-Field.ps.gz}" -} - -@TECHREPORT{Dow90, - AUTHOR = {G. Dowek}, - INSTITUTION = {INRIA}, - NUMBER = {1283}, - TITLE = {Naming and Scoping in a Mathematical Vernacular}, - TYPE = {Research Report}, - YEAR = {1990} -} - -@ARTICLE{Dow91a, - AUTHOR = {G. Dowek}, - JOURNAL = {Compte-Rendus de l'Acad\'emie des Sciences}, - NOTE = {The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors}, - NUMBER = {12}, - PAGES = {951--956}, - TITLE = {L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}, - VOLUME = {I, 312}, - YEAR = {1991} -} - -@INPROCEEDINGS{Dow91b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of Mathematical Foundation of Computer Science}, - NOTE = {Also INRIA Research Report}, - PAGES = {151--160}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {A Second Order Pattern Matching Algorithm in the Cube of Typed $\lambda$-calculi}, - VOLUME = {520}, - YEAR = {1991} -} - -@PHDTHESIS{Dow91c, - AUTHOR = {G. Dowek}, - MONTH = dec, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {D\'emonstration automatique dans le Calcul des Constructions}, - YEAR = {1991} -} - -@article{Dow92a, - AUTHOR = {G. Dowek}, - TITLE = {The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}, - YEAR = 1993, - journal = tcs, - volume = 107, - number = 2, - pages = {349-356} -} - - -@ARTICLE{Dow94a, - AUTHOR = {G. Dowek}, - JOURNAL = {Annals of Pure and Applied Logic}, - VOLUME = {69}, - PAGES = {135--155}, - TITLE = {Third order matching is decidable}, - YEAR = {1994} -} - -@INPROCEEDINGS{Dow94b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of the second international conference on typed lambda calculus and applications}, - TITLE = {Lambda-calculus, Combinators and the Comprehension Schema}, - YEAR = {1995} -} - -@INPROCEEDINGS{Dyb91, - AUTHOR = {P. Dybjer}, - BOOKTITLE = {Logical Frameworks}, - EDITOR = {G. Huet and G. Plotkin}, - PAGES = {59--79}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Inductive sets and families in {Martin-L{\"o}f's} - Type Theory and their set-theoretic semantics: An inversion principle for {Martin-L\"of's} type theory}, - VOLUME = {14}, - YEAR = {1991} -} - -@ARTICLE{Dyc92, - AUTHOR = {Roy Dyckhoff}, - JOURNAL = {The Journal of Symbolic Logic}, - MONTH = sep, - NUMBER = {3}, - TITLE = {Contraction-free sequent calculi for intuitionistic logic}, - VOLUME = {57}, - YEAR = {1992} -} - -@MASTERSTHESIS{Fil94, - AUTHOR = {J.-C. Filli\^atre}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct. {\'E}tude et impl\'ementation dans le syst\`eme {\Coq}}, - YEAR = {1994} -} - -@TECHREPORT{Filliatre95, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP-ENS-Lyon}, - TITLE = {A decision procedure for Direct Predicate Calculus}, - TYPE = {Research report}, - NUMBER = {96--25}, - YEAR = {1995} -} - -@Article{Filliatre03jfp, - author = {J.-C. Filli{\^a}tre}, - title = {Verification of Non-Functional Programs - using Interpretations in Type Theory}, - journal = jfp, - volume = 13, - number = 4, - pages = {709--745}, - month = jul, - year = 2003, - note = {[English translation of \cite{Filliatre99}]}, - url = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - topics = "team, lri", - type_publi = "irevcomlec" -} - - -@PhdThesis{Filliatre99, - author = {J.-C. Filli\^atre}, - title = {Preuve de programmes imp\'eratifs en th\'eorie des types}, - type = {Th{\`e}se de Doctorat}, - school = {Universit\'e Paris-Sud}, - year = 1999, - month = {July}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}} -} - -@Unpublished{Filliatre99c, - author = {J.-C. Filli\^atre}, - title = {{Formal Proof of a Program: Find}}, - month = {January}, - year = 2000, - note = {Submitted to \emph{Science of Computer Programming}}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}} -} - -@InProceedings{FilliatreMagaud99, - author = {J.-C. Filli\^atre and N. Magaud}, - title = {Certification of sorting algorithms in the system {\Coq}}, - booktitle = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - year = 1999, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz}} -} - -@UNPUBLISHED{Fle90, - AUTHOR = {E. Fleury}, - MONTH = jul, - NOTE = {Rapport de Stage}, - TITLE = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, - YEAR = {1990} -} - -@BOOK{Fourier, - AUTHOR = {Jean-Baptiste-Joseph Fourier}, - PUBLISHER = {Gauthier-Villars}, - TITLE = {Fourier's method to solve linear - inequations/equations systems.}, - YEAR = {1890} -} - -@INPROCEEDINGS{Gim94, - AUTHOR = {Eduardo Gim\'enez}, - BOOKTITLE = {Types'94 : Types for Proofs and Programs}, - NOTE = {Extended version in LIP research report 95-07, ENS Lyon}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Codifying guarded definitions with recursive schemes}, - VOLUME = {996}, - YEAR = {1994} -} - -@TechReport{Gim98, - author = {E. Gim\'enez}, - title = {A Tutorial on Recursive Types in Coq}, - institution = {INRIA}, - year = 1998, - month = mar -} - -@INPROCEEDINGS{Gimenez95b, - AUTHOR = {E. Gim\'enez}, - BOOKTITLE = {Workshop on Types for Proofs and Programs}, - SERIES = LNCS, - NUMBER = {1158}, - PAGES = {135-152}, - TITLE = {An application of co-Inductive types in Coq: - verification of the Alternating Bit Protocol}, - EDITORS = {S. Berardi and M. Coppo}, - PUBLISHER = SV, - YEAR = {1995} -} - -@INPROCEEDINGS{Gir70, - AUTHOR = {Jean-Yves Girard}, - BOOKTITLE = {Proceedings of the 2nd Scandinavian Logic Symposium}, - PUBLISHER = {North-Holland}, - TITLE = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, - YEAR = {1970} -} - -@PHDTHESIS{Gir72, - AUTHOR = {Jean-Yves Girard}, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, - YEAR = {1972} -} - - - -@BOOK{Gir89, - AUTHOR = {Jean-Yves Girard and Yves Lafont and Paul Taylor}, - PUBLISHER = {Cambridge University Press}, - SERIES = {Cambridge Tracts in Theoretical Computer Science 7}, - TITLE = {Proofs and Types}, - YEAR = {1989} -} - -@TechReport{Har95, - author = {John Harrison}, - title = {Metatheory and Reflection in Theorem Proving: A Survey and Critique}, - institution = {SRI International Cambridge Computer Science Research Centre,}, - year = 1995, - type = {Technical Report}, - number = {CRC-053}, - abstract = {http://www.cl.cam.ac.uk/users/jrh/papers.html} -} - -@MASTERSTHESIS{Hir94, - AUTHOR = {Daniel Hirschkoff}, - MONTH = sep, - SCHOOL = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, - TITLE = {{\'E}criture d'une tactique arithm\'etique pour le syst\`eme {\Coq}}, - YEAR = {1994} -} - -@INPROCEEDINGS{HofStr98, - AUTHOR = {Martin Hofmann and Thomas Streicher}, - TITLE = {The groupoid interpretation of type theory}, - BOOKTITLE = {Proceedings of the meeting Twenty-five years of constructive type theory}, - PUBLISHER = {Oxford University Press}, - YEAR = {1998} -} - -@INCOLLECTION{How80, - AUTHOR = {W.A. Howard}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - NOTE = {Unpublished 1969 Manuscript}, - PUBLISHER = {Academic Press}, - TITLE = {The Formulae-as-Types Notion of Constructions}, - YEAR = {1980} -} - - - -@InProceedings{Hue87tapsoft, - author = {G. Huet}, - title = {Programming of Future Generation Computers}, - booktitle = {Proceedings of TAPSOFT87}, - series = LNCS, - volume = 249, - pages = {276--286}, - year = 1987, - publisher = SV -} - -@INPROCEEDINGS{Hue87, - AUTHOR = {G. Huet}, - BOOKTITLE = {Programming of Future Generation Computers}, - EDITOR = {K. Fuchi and M. Nivat}, - NOTE = {Also in \cite{Hue87tapsoft}}, - PUBLISHER = {Elsevier Science}, - TITLE = {Induction Principles Formalized in the {Calculus of Constructions}}, - YEAR = {1988} -} - - - -@INPROCEEDINGS{Hue88, - AUTHOR = {G. Huet}, - BOOKTITLE = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, - EDITOR = {R. Narasimhan}, - NOTE = {Also in~\cite{CoC89}}, - PUBLISHER = {World Scientific Publishing}, - TITLE = {{The Constructive Engine}}, - YEAR = {1989} -} - -@BOOK{Hue89, - EDITOR = {G. Huet}, - PUBLISHER = {Addison-Wesley}, - SERIES = {The UT Year of Programming Series}, - TITLE = {Logical Foundations of Functional Programming}, - YEAR = {1989} -} - -@INPROCEEDINGS{Hue92, - AUTHOR = {G. Huet}, - BOOKTITLE = {Proceedings of 12th FST/TCS Conference, New Delhi}, - PAGES = {229--240}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {The Gallina Specification Language : A case study}, - VOLUME = {652}, - YEAR = {1992} -} - -@ARTICLE{Hue94, - AUTHOR = {G. Huet}, - JOURNAL = {J. Functional Programming}, - PAGES = {371--394}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Residual theory in $\lambda$-calculus: a formal development}, - VOLUME = {4,3}, - YEAR = {1994} -} - -@INCOLLECTION{HuetLevy79, - AUTHOR = {G. Huet and J.-J. L\'{e}vy}, - TITLE = {Call by Need Computations in Non-Ambigous -Linear Term Rewriting Systems}, - NOTE = {Also research report 359, INRIA, 1979}, - BOOKTITLE = {Computational Logic, Essays in Honor of -Alan Robinson}, - EDITOR = {J.-L. Lassez and G. Plotkin}, - PUBLISHER = {The MIT press}, - YEAR = {1991} -} - -@ARTICLE{KeWe84, - AUTHOR = {J. Ketonen and R. Weyhrauch}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {297--307}, - TITLE = {A decidable fragment of {P}redicate {C}alculus}, - VOLUME = {32}, - YEAR = {1984} -} - -@BOOK{Kle52, - AUTHOR = {S.C. Kleene}, - PUBLISHER = {North-Holland}, - SERIES = {Bibliotheca Mathematica}, - TITLE = {Introduction to Metamathematics}, - YEAR = {1952} -} - -@BOOK{Kri90, - AUTHOR = {J.-L. Krivine}, - PUBLISHER = {Masson}, - SERIES = {Etudes et recherche en informatique}, - TITLE = {Lambda-calcul {types et mod\`eles}}, - YEAR = {1990} -} - -@BOOK{LE92, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Environments}, - YEAR = {1992} -} - -@BOOK{LF91, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Frameworks}, - YEAR = {1991} -} - -@ARTICLE{Laville91, - AUTHOR = {A. Laville}, - TITLE = {Comparison of Priority Rules in Pattern -Matching and Term Rewriting}, - JOURNAL = {Journal of Symbolic Computation}, - VOLUME = {11}, - PAGES = {321--347}, - YEAR = {1991} -} - -@INPROCEEDINGS{LePa94, - AUTHOR = {F. Leclerc and C. Paulin-Mohring}, - BOOKTITLE = {{Types for Proofs and Programs, Types' 93}}, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, - VOLUME = {806}, - YEAR = {1994} -} - -@TECHREPORT{Leroy90, - AUTHOR = {X. Leroy}, - TITLE = {The {ZINC} experiment: an economical implementation -of the {ML} language}, - INSTITUTION = {INRIA}, - NUMBER = {117}, - YEAR = {1990} -} - -@INPROCEEDINGS{Let02, - author = {P. Letouzey}, - title = {A New Extraction for Coq}, - booktitle = {Proceedings of the TYPES'2002 workshop}, - year = 2002, - note = {to appear}, - url = {draft at \url{http://www.lri.fr/~letouzey/download/extraction2002.ps.gz}} -} - -@BOOK{MaL84, - AUTHOR = {{P. Martin-L\"of}}, - PUBLISHER = {Bibliopolis}, - SERIES = {Studies in Proof Theory}, - TITLE = {Intuitionistic Type Theory}, - YEAR = {1984} -} - -@ARTICLE{MaSi94, - AUTHOR = {P. Manoury and M. Simonot}, - JOURNAL = {TCS}, - TITLE = {Automatizing termination proof of recursively defined function}, - YEAR = {To appear} -} - -@INPROCEEDINGS{Moh89a, - AUTHOR = {Christine Paulin-Mohring}, - ADDRESS = {Austin}, - BOOKTITLE = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - MONTH = jan, - PUBLISHER = {ACM}, - TITLE = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - YEAR = {1989} -} - -@PHDTHESIS{Moh89b, - AUTHOR = {Christine Paulin-Mohring}, - MONTH = jan, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Extraction de programmes dans le {Calcul des Constructions}}, - YEAR = {1989} -} - -@INPROCEEDINGS{Moh93, - AUTHOR = {Christine Paulin-Mohring}, - BOOKTITLE = {Proceedings of the conference Typed Lambda Calculi and Applications}, - EDITOR = {M. Bezem and J.-F. Groote}, - NOTE = {Also LIP research report 92-49, ENS Lyon}, - NUMBER = {664}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Inductive Definitions in the System Coq - Rules and Properties}}, - YEAR = {1993} -} - -@BOOK{Moh97, - AUTHOR = {Christine Paulin-Mohring}, - MONTH = jan, - PUBLISHER = {{ENS Lyon}}, - TITLE = {{Le syst\`eme Coq. \mbox{Th\`ese d'habilitation}}}, - YEAR = {1997} -} - -@MASTERSTHESIS{Mun94, - AUTHOR = {C. Mu{\~n}oz}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, - YEAR = {1994} -} - -@PHDTHESIS{Mun97d, - AUTHOR = "C. Mu{\~{n}}oz", - TITLE = "Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types", - SCHOOL = {Universit\'e Paris 7}, - YEAR = "1997", - Note = {Version en anglais disponible comme rapport de - recherche INRIA RR-3309}, - Type = {Th\`ese de Doctorat} -} - -@BOOK{NoPS90, - AUTHOR = {B. {Nordstr\"om} and K. Peterson and J. Smith}, - BOOKTITLE = {Information Processing 83}, - PUBLISHER = {Oxford Science Publications}, - SERIES = {International Series of Monographs on Computer Science}, - TITLE = {Programming in {Martin-L\"of's} Type Theory}, - YEAR = {1990} -} - -@ARTICLE{Nor88, - AUTHOR = {B. {Nordstr\"om}}, - JOURNAL = {BIT}, - TITLE = {Terminating General Recursion}, - VOLUME = {28}, - YEAR = {1988} -} - -@BOOK{Odi90, - EDITOR = {P. Odifreddi}, - PUBLISHER = {Academic Press}, - TITLE = {Logic and Computer Science}, - YEAR = {1990} -} - -@INPROCEEDINGS{PaMS92, - AUTHOR = {M. Parigot and P. Manoury and M. Simonot}, - ADDRESS = {St. Petersburg, Russia}, - BOOKTITLE = {Logic Programming and automated reasoning}, - EDITOR = {A. Voronkov}, - MONTH = jul, - NUMBER = {624}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{ProPre : A Programming language with proofs}}, - YEAR = {1992} -} - -@ARTICLE{PaWe92, - AUTHOR = {Christine Paulin-Mohring and Benjamin Werner}, - JOURNAL = {Journal of Symbolic Computation}, - PAGES = {607--640}, - TITLE = {{Synthesis of ML programs in the system Coq}}, - VOLUME = {15}, - YEAR = {1993} -} - -@ARTICLE{Par92, - AUTHOR = {M. Parigot}, - JOURNAL = {Theoretical Computer Science}, - NUMBER = {2}, - PAGES = {335--356}, - TITLE = {{Recursive Programming with Proofs}}, - VOLUME = {94}, - YEAR = {1992} -} - -@INPROCEEDINGS{Parent95b, - AUTHOR = {C. Parent}, - BOOKTITLE = {{Mathematics of Program Construction'95}}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Synthesizing proofs from programs in -the Calculus of Inductive Constructions}}, - VOLUME = {947}, - YEAR = {1995} -} - -@INPROCEEDINGS{Prasad93, - AUTHOR = {K.V. Prasad}, - BOOKTITLE = {{Proceedings of CONCUR'93}}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Programming with broadcasts}}, - VOLUME = {715}, - YEAR = {1993} -} - -@BOOK{RC95, - author = "di~Cosmo, R.", - title = "Isomorphisms of Types: from $\lambda$-calculus to information - retrieval and language design", - series = "Progress in Theoretical Computer Science", - publisher = "Birkhauser", - year = "1995", - note = "ISBN-0-8176-3763-X" -} - -@TECHREPORT{Rou92, - AUTHOR = {J. Rouyer}, - INSTITUTION = {INRIA}, - MONTH = nov, - NUMBER = {1795}, - TITLE = {{D{\'e}veloppement de l'Algorithme d'Unification dans le Calcul des Constructions}}, - YEAR = {1992} -} - -@TECHREPORT{Saibi94, - AUTHOR = {A. Sa\"{\i}bi}, - INSTITUTION = {INRIA}, - MONTH = dec, - NUMBER = {2345}, - TITLE = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, - YEAR = {1994} -} - - -@MASTERSTHESIS{Ter92, - AUTHOR = {D. Terrasse}, - MONTH = sep, - SCHOOL = {IARFA}, - TITLE = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, - YEAR = {1992} -} - -@TECHREPORT{ThBeKa92, - AUTHOR = {L. Th\'ery and Y. Bertot and G. Kahn}, - INSTITUTION = {INRIA Sophia}, - MONTH = may, - NUMBER = {1684}, - TITLE = {Real theorem provers deserve real user-interfaces}, - TYPE = {Research Report}, - YEAR = {1992} -} - -@BOOK{TrDa89, - AUTHOR = {A.S. Troelstra and D. van Dalen}, - PUBLISHER = {North-Holland}, - SERIES = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, - TITLE = {Constructivism in Mathematics, an introduction}, - YEAR = {1988} -} - -@PHDTHESIS{Wer94, - AUTHOR = {B. Werner}, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {Une th\'eorie des constructions inductives}, - TYPE = {Th\`ese de Doctorat}, - YEAR = {1994} -} - -@PHDTHESIS{Bar99, - AUTHOR = {B. Barras}, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {Auto-validation d'un système de preuves avec familles inductives}, - TYPE = {Th\`ese de Doctorat}, - YEAR = {1999} -} - -@UNPUBLISHED{ddr98, - AUTHOR = {D. de Rauglaudre}, - TITLE = {Camlp4 version 1.07.2}, - YEAR = {1998}, - NOTE = {In Camlp4 distribution} -} - -@ARTICLE{dowek93, - AUTHOR = {G. Dowek}, - TITLE = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, - JOURNAL = {Journal Logic Computation}, - VOLUME = {3}, - NUMBER = {3}, - PAGES = {287--315}, - MONTH = {June}, - YEAR = {1993} -} - -@INPROCEEDINGS{manoury94, - AUTHOR = {P. Manoury}, - TITLE = {{A User's Friendly Syntax to Define -Recursive Functions as Typed $\lambda-$Terms}}, - BOOKTITLE = {{Types for Proofs and Programs, TYPES'94}}, - SERIES = {LNCS}, - VOLUME = {996}, - MONTH = jun, - YEAR = {1994} -} - -@TECHREPORT{maranget94, - AUTHOR = {L. Maranget}, - INSTITUTION = {INRIA}, - NUMBER = {2385}, - TITLE = {{Two Techniques for Compiling Lazy Pattern Matching}}, - YEAR = {1994} -} - -@INPROCEEDINGS{puel-suarez90, - AUTHOR = {L.Puel and A. Su\'arez}, - BOOKTITLE = {{Conference Lisp and Functional Programming}}, - SERIES = {ACM}, - PUBLISHER = SV, - TITLE = {{Compiling Pattern Matching by Term -Decomposition}}, - YEAR = {1990} -} - -@MASTERSTHESIS{saidi94, - AUTHOR = {H. Saidi}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {R\'esolution d'\'equations dans le syst\`eme T - de G\"odel}, - YEAR = {1994} -} - -@misc{streicher93semantical, - author = "T. Streicher", - title = "Semantical Investigations into Intensional Type Theory", - note = "Habilitationsschrift, LMU Munchen.", - year = "1993" } - - - -@Misc{Pcoq, - author = {Lemme Team}, - title = {Pcoq a graphical user-interface for {Coq}}, - note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} -} - - -@Misc{ProofGeneral, - author = {David Aspinall}, - title = {Proof General}, - note = {\url{https://proofgeneral.github.io/}} -} - - - -@Book{CoqArt, - author = {Yves bertot and Pierre Castéran}, - title = {Coq'Art}, - publisher = {Springer-Verlag}, - year = 2004, - note = {To appear} -} - -@INCOLLECTION{wadler87, - AUTHOR = {P. Wadler}, - TITLE = {Efficient Compilation of Pattern Matching}, - BOOKTITLE = {The Implementation of Functional Programming -Languages}, - EDITOR = {S.L. Peyton Jones}, - PUBLISHER = {Prentice-Hall}, - YEAR = {1987} -} - - -@COMMENT{cross-references, must be at end} - -@BOOK{Bastad92, - EDITOR = {B. Nordstr\"om and K. Petersson and G. Plotkin}, - PUBLISHER = {Available by ftp at site ftp.inria.fr}, - TITLE = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, - YEAR = {1992} -} - -@BOOK{Nijmegen93, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Types for Proofs and Programs}, - VOLUME = {806}, - YEAR = {1994} -} - -@PHDTHESIS{Luo90, - AUTHOR = {Z. Luo}, - TITLE = {An Extended Calculus of Constructions}, - SCHOOL = {University of Edinburgh}, - YEAR = {1990} -} diff --git a/doc/faq/hevea.sty b/doc/faq/hevea.sty deleted file mode 100644 index 6d49aa8ce..000000000 --- a/doc/faq/hevea.sty +++ /dev/null @@ -1,78 +0,0 @@ -% hevea : hevea.sty -% This is a very basic style file for latex document to be processed -% with hevea. It contains definitions of LaTeX environment which are -% processed in a special way by the translator. -% Mostly : -% - latexonly, not processed by hevea, processed by latex. -% - htmlonly , the reverse. -% - rawhtml, to include raw HTML in hevea output. -% - toimage, to send text to the image file. -% The package also provides hevea logos, html related commands (ahref -% etc.), void cutting and image commands. -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{hevea}[2002/01/11] -\RequirePackage{comment} -\newif\ifhevea\heveafalse -\@ifundefined{ifimagen}{\newif\ifimagen\imagenfalse} -\makeatletter% -\newcommand{\heveasmup}[2]{% -\raise #1\hbox{$\m@th$% - \csname S@\f@size\endcsname - \fontsize\sf@size 0% - \math@fontsfalse\selectfont -#2% -}}% -\DeclareRobustCommand{\hevea}{H\kern-.15em\heveasmup{.2ex}{E}\kern-.15emV\kern-.15em\heveasmup{.2ex}{E}\kern-.15emA}% -\DeclareRobustCommand{\hacha}{H\kern-.15em\heveasmup{.2ex}{A}\kern-.15emC\kern-.1em\heveasmup{.2ex}{H}\kern-.15emA}% -\DeclareRobustCommand{\html}{\protect\heveasmup{0.ex}{HTML}} -%%%%%%%%% Hyperlinks hevea style -\newcommand{\ahref}[2]{{#2}} -\newcommand{\ahrefloc}[2]{{#2}} -\newcommand{\aname}[2]{{#2}} -\newcommand{\ahrefurl}[1]{\texttt{#1}} -\newcommand{\footahref}[2]{#2\footnote{\texttt{#1}}} -\newcommand{\mailto}[1]{\texttt{#1}} -\newcommand{\imgsrc}[2][]{} -\newcommand{\home}[1]{\protect\raisebox{-.75ex}{\char126}#1} -\AtBeginDocument -{\@ifundefined{url} -{%url package is not loaded -\let\url\ahref\let\oneurl\ahrefurl\let\footurl\footahref} -{}} -%% Void cutting instructions -\newcounter{cuttingdepth} -\newcommand{\tocnumber}{} -\newcommand{\notocnumber}{} -\newcommand{\cuttingunit}{} -\newcommand{\cutdef}[2][]{} -\newcommand{\cuthere}[2]{} -\newcommand{\cutend}{} -\newcommand{\htmlhead}[1]{} -\newcommand{\htmlfoot}[1]{} -\newcommand{\htmlprefix}[1]{} -\newenvironment{cutflow}[1]{}{} -\newcommand{\cutname}[1]{} -\newcommand{\toplinks}[3]{} -%%%% Html only -\excludecomment{rawhtml} -\newcommand{\rawhtmlinput}[1]{} -\excludecomment{htmlonly} -%%%% Latex only -\newenvironment{latexonly}{}{} -\newenvironment{verblatex}{}{} -%%%% Image file stuff -\def\toimage{\endgroup} -\def\endtoimage{\begingroup\def\@currenvir{toimage}} -\def\verbimage{\endgroup} -\def\endverbimage{\begingroup\def\@currenvir{verbimage}} -\newcommand{\imageflush}[1][]{} -%%% Bgcolor definition -\newsavebox{\@bgcolorbin} -\newenvironment{bgcolor}[2][] - {\newcommand{\@mycolor}{#2}\begin{lrbox}{\@bgcolorbin}\vbox\bgroup} - {\egroup\end{lrbox}% - \begin{flushleft}% - \colorbox{\@mycolor}{\usebox{\@bgcolorbin}}% - \end{flushleft}} -%%% Postlude -\makeatother diff --git a/doc/faq/interval_discr.v b/doc/faq/interval_discr.v deleted file mode 100644 index 671dc988a..000000000 --- a/doc/faq/interval_discr.v +++ /dev/null @@ -1,419 +0,0 @@ -(** Sketch of the proof of {p:nat|p<=n} = {p:nat|p<=m} -> n=m - - - preliminary results on the irrelevance of boundedness proofs - - introduce the notion of finite cardinal |A| - - prove that |{p:nat|p<=n}| = n - - prove that |A| = n /\ |A| = m -> n = m if equality is decidable on A - - prove that equality is decidable on A - - conclude -*) - -(** * Preliminary results on [nat] and [le] *) - -(** Proving axiom K on [nat] *) - -Require Import Eqdep_dec. -Require Import Arith. - -Theorem eq_rect_eq_nat : - forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h. -Proof. -intros. -apply K_dec_set with (p := h). -apply eq_nat_dec. -reflexivity. -Qed. - -(** Proving unicity of proofs of [(n<=m)%nat] *) - -Scheme le_ind' := Induction for le Sort Prop. - -Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q. -Proof. -induction p using le_ind'; intro q. - replace (le_n n) with - (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl). - 2:reflexivity. - generalize (eq_refl n). - pattern n at 2 4 6 10, q; case q; [intro | intros m l e]. - rewrite <- eq_rect_eq_nat; trivial. - contradiction (le_Sn_n m); rewrite <- e; assumption. - replace (le_S n m p) with - (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ eq_refl). - 2:reflexivity. - generalize (eq_refl (S m)). - pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS]. - contradiction (le_Sn_n m); rewrite Heq; assumption. - injection HeqS; intro Heq; generalize l HeqS. - rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat. - rewrite (IHp l0); reflexivity. -Qed. - -(** Proving irrelevance of boundedness proofs while building - elements of interval *) - -Lemma dep_pair_intro : - forall (n x y:nat) (Hx : x<=n) (Hy : y<=n), x=y -> - exist (fun x => x <= n) x Hx = exist (fun x => x <= n) y Hy. -Proof. -intros n x y Hx Hy Heq. -generalize Hy. -rewrite <- Heq. -intros. -rewrite (le_uniqueness_proof x n Hx Hy0). -reflexivity. -Qed. - -(** * Proving that {p:nat|p<=n} = {p:nat|p<=m} -> n=m *) - -(** Definition of having finite cardinality [n+1] for a set [A] *) - -Definition card (A:Set) n := - exists f, - (forall x:A, f x <= n) /\ - (forall x y:A, f x = f y -> x = y) /\ - (forall m, m <= n -> exists x:A, f x = m). - -Require Import Arith. - -(** Showing that the interval [0;n] has cardinality [n+1] *) - -Theorem card_interval : forall n, card {x:nat|x<=n} n. -Proof. -intro n. -exists (fun x:{x:nat|x<=n} => proj1_sig x). -split. -(* bounded *) -intro x; apply (proj2_sig x). -split. -(* injectivity *) -intros (p,Hp) (q,Hq). -simpl. -intro Hpq. -apply dep_pair_intro; assumption. -(* surjectivity *) -intros m Hmn. -exists (exist (fun x : nat => x <= n) m Hmn). -reflexivity. -Qed. - -(** Showing that equality on the interval [0;n] is decidable *) - -Lemma interval_dec : - forall n (x y : {m:nat|m<=n}), {x=y}+{x<>y}. -Proof. -intros n (p,Hp). -induction p; intros ([|q],Hq). -left. - apply dep_pair_intro. - reflexivity. -right. - intro H; discriminate H. -right. - intro H; discriminate H. -assert (Hp' : p <= n). - apply le_Sn_le; assumption. -assert (Hq' : q <= n). - apply le_Sn_le; assumption. -destruct (IHp Hp' (exist (fun m => m <= n) q Hq')) - as [Heq|Hneq]. -left. - injection Heq; intro Heq'. - apply dep_pair_intro. - apply eq_S. - assumption. -right. - intro HeqS. - injection HeqS; intro Heq. - apply Hneq. - apply dep_pair_intro. - assumption. -Qed. - -(** Showing that the cardinality relation is functional on decidable sets *) - -Lemma card_inj_aux : - forall (A:Type) f g n, - (forall x:A, f x <= 0) -> - (forall x y:A, f x = f y -> x = y) -> - (forall m, m <= S n -> exists x:A, g x = m) - -> False. -Proof. -intros A f g n Hfbound Hfinj Hgsurj. -destruct (Hgsurj (S n) (le_n _)) as (x,Hx). -destruct (Hgsurj n (le_S _ _ (le_n _))) as (x',Hx'). -assert (Hfx : 0 = f x). -apply le_n_O_eq. -apply Hfbound. -assert (Hfx' : 0 = f x'). -apply le_n_O_eq. -apply Hfbound. -assert (x=x'). -apply Hfinj. -rewrite <- Hfx. -rewrite <- Hfx'. -reflexivity. -rewrite H in Hx. -rewrite Hx' in Hx. -apply (n_Sn _ Hx). -Qed. - -(** For [dec_restrict], we use a lemma on the negation of equality -that requires proof-irrelevance. It should be possible to avoid this -lemma by generalizing over a first-order definition of [x<>y], say -[neq] such that [{x=y}+{neq x y}] and [~(x=y /\ neq x y)]; for such -[neq], unicity of proofs could be proven *) - - Require Import Classical. - Lemma neq_dep_intro : - forall (A:Set) (z x y:A) (p:x<>z) (q:y<>z), x=y -> - exist (fun x => x <> z) x p = exist (fun x => x <> z) y q. - Proof. - intros A z x y p q Heq. - generalize q; clear q; rewrite <- Heq; intro q. - rewrite (proof_irrelevance _ p q); reflexivity. - Qed. - -Lemma dec_restrict : - forall (A:Set), - (forall x y :A, {x=y}+{x<>y}) -> - forall z (x y :{a:A|a<>z}), {x=y}+{x<>y}. -Proof. -intros A Hdec z (x,Hx) (y,Hy). -destruct (Hdec x y) as [Heq|Hneq]. -left; apply neq_dep_intro; assumption. -right; intro Heq; injection Heq; exact Hneq. -Qed. - -Lemma pred_inj : forall n m, - 0 <> n -> 0 <> m -> pred m = pred n -> m = n. -Proof. -destruct n. -intros m H; destruct H; reflexivity. -destruct m. -intros _ H; destruct H; reflexivity. -simpl; intros _ _ H. -rewrite H. -reflexivity. -Qed. - -Lemma le_neq_lt : forall n m, n <= m -> n<>m -> n < m. -Proof. -intros n m Hle Hneq. -destruct (le_lt_eq_dec n m Hle). -assumption. -contradiction. -Qed. - -Lemma inj_restrict : - forall (A:Set) (f:A->nat) x y z, - (forall x y : A, f x = f y -> x = y) - -> x <> z -> f y < f z -> f z <= f x - -> pred (f x) = f y - -> False. - -(* Search error sans le type de f !! *) -Proof. -intros A f x y z Hfinj Hneqx Hfy Hfx Heq. -assert (f z <> f x). - apply not_eq_sym. - intro Heqf. - apply Hneqx. - apply Hfinj. - assumption. -assert (f x = S (f y)). - assert (0 < f x). - apply le_lt_trans with (f z). - apply le_O_n. - apply le_neq_lt; assumption. - apply pred_inj. - apply O_S. - apply lt_O_neq; assumption. - exact Heq. -assert (f z <= f y). -destruct (le_lt_or_eq _ _ Hfx). - apply lt_n_Sm_le. - rewrite <- H0. - assumption. - contradiction Hneqx. - symmetry. - apply Hfinj. - assumption. -contradiction (lt_not_le (f y) (f z)). -Qed. - -Theorem card_inj : forall m n (A:Set), - (forall x y :A, {x=y}+{x<>y}) -> - card A m -> card A n -> m = n. -Proof. -induction m; destruct n; -intros A Hdec - (f,(Hfbound,(Hfinj,Hfsurj))) - (g,(Hgbound,(Hginj,Hgsurj))). -(* 0/0 *) -reflexivity. -(* 0/Sm *) -destruct (card_inj_aux _ _ _ _ Hfbound Hfinj Hgsurj). -(* Sn/0 *) -destruct (card_inj_aux _ _ _ _ Hgbound Hginj Hfsurj). -(* Sn/Sm *) -destruct (Hgsurj (S n) (le_n _)) as (xSn,HSnx). -rewrite IHm with (n:=n) (A := {x:A|x<>xSn}). -reflexivity. -(* decidability of eq on {x:A|x<>xSm} *) -apply dec_restrict. -assumption. -(* cardinality of {x:A|x<>xSn} is m *) -pose (f' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in - if le_lt_dec (f xSn) (f x) - then pred (f x) - else f x). -exists f'. -split. -(* f' is bounded *) -unfold f'. -intros (x,_). -destruct (le_lt_dec (f xSn) (f x)) as [Hle|Hge]. -change m with (pred (S m)). -apply le_pred. -apply Hfbound. -apply le_S_n. -apply le_trans with (f xSn). -exact Hge. -apply Hfbound. -split. -(* f' is injective *) -unfold f'. -intros (x,Hneqx) (y,Hneqy) Heqf'. -destruct (le_lt_dec (f xSn) (f x)) as [Hlefx|Hgefx]; -destruct (le_lt_dec (f xSn) (f y)) as [Hlefy|Hgefy]. -(* f xSn <= f x et f xSn <= f y *) -assert (Heq : x = y). - apply Hfinj. - assert (f xSn <> f y). - apply not_eq_sym. - intro Heqf. - apply Hneqy. - apply Hfinj. - assumption. - assert (0 < f y). - apply le_lt_trans with (f xSn). - apply le_O_n. - apply le_neq_lt; assumption. - assert (f xSn <> f x). - apply not_eq_sym. - intro Heqf. - apply Hneqx. - apply Hfinj. - assumption. - assert (0 < f x). - apply le_lt_trans with (f xSn). - apply le_O_n. - apply le_neq_lt; assumption. - apply pred_inj. - apply lt_O_neq; assumption. - apply lt_O_neq; assumption. - assumption. -apply neq_dep_intro; assumption. -(* f y < f xSn <= f x *) -destruct (inj_restrict A f x y xSn); assumption. -(* f x < f xSn <= f y *) -symmetry in Heqf'. -destruct (inj_restrict A f y x xSn); assumption. -(* f x < f xSn et f y < f xSn *) -assert (Heq : x=y). - apply Hfinj; assumption. -apply neq_dep_intro; assumption. -(* f' is surjective *) -intros p Hlep. -destruct (le_lt_dec (f xSn) p) as [Hle|Hlt]. -(* case f xSn <= p *) -destruct (Hfsurj (S p) (le_n_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x <> xSn). - intro Heqx. - rewrite Heqx in Hx. - rewrite Hx in Hle. - apply le_Sn_n with p; assumption. -exists (exist (fun a => a<>xSn) x Hneq). -unfold f'. -destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt']. -rewrite Hx; reflexivity. -rewrite Hx in Hlt'. -contradiction (le_not_lt (f xSn) p). -apply lt_trans with (S p). -apply lt_n_Sn. -assumption. -(* case p < f xSn *) -destruct (Hfsurj p (le_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x <> xSn). - intro Heqx. - rewrite Heqx in Hx. - rewrite Hx in Hlt. - apply (lt_irrefl p). - assumption. -exists (exist (fun a => a<>xSn) x Hneq). -unfold f'. -destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt']. - rewrite Hx in Hle'. - contradiction (lt_irrefl p). - apply lt_le_trans with (f xSn); assumption. - assumption. -(* cardinality of {x:A|x<>xSn} is n *) -pose (g' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in - if Hdec x xSn then 0 else g x). -exists g'. -split. -(* g is bounded *) -unfold g'. -intros (x,_). -destruct (Hdec x xSn) as [_|Hneq]. -apply le_O_n. -assert (Hle_gx:=Hgbound x). -destruct (le_lt_or_eq _ _ Hle_gx). -apply lt_n_Sm_le. -assumption. -contradiction Hneq. -apply Hginj. -rewrite HSnx. -assumption. -split. -(* g is injective *) -unfold g'. -intros (x,Hneqx) (y,Hneqy) Heqg'. -destruct (Hdec x xSn) as [Heqx|_]. -contradiction Hneqx. -destruct (Hdec y xSn) as [Heqy|_]. -contradiction Hneqy. -assert (Heq : x=y). - apply Hginj; assumption. -apply neq_dep_intro; assumption. -(* g is surjective *) -intros p Hlep. -destruct (Hgsurj p (le_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x<>xSn). - intro Heq. - rewrite Heq in Hx. - rewrite Hx in HSnx. - rewrite HSnx in Hlep. - contradiction (le_Sn_n _ Hlep). -exists (exist (fun a => a<>xSn) x Hneq). -simpl. -destruct (Hdec x xSn) as [Heqx|_]. -contradiction Hneq. -assumption. -Qed. - -(** Conclusion *) - -Theorem interval_discr : - forall n m, {p:nat|p<=n} = {p:nat|p<=m} -> n=m. -Proof. -intros n m Heq. -apply card_inj with (A := {p:nat|p<=n}). -apply interval_dec. -apply card_interval. -rewrite Heq. -apply card_interval. -Qed. diff --git a/doc/refman/AsyncProofs.tex b/doc/refman/AsyncProofs.tex index 30039d489..8f9d876cb 100644 --- a/doc/refman/AsyncProofs.tex +++ b/doc/refman/AsyncProofs.tex @@ -1,4 +1,4 @@ -\achapter{Asynchronous and Parallel Proof Processing} +\achapter{Asynchronous and Parallel Proof Processing\label{Asyncprocessing}} %HEVEA\cutname{async-proofs.html} \aauthor{Enrico Tassi} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index 7ad895f9d..376ef031d 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -280,6 +280,18 @@ Fail Check end). \end{coq_example} +The option {\tt Set Asymmetric Patterns} \optindex{Asymmetric Patterns} +(off by default) removes parameters from constructors in patterns: +\begin{coq_example} + Set Asymmetric Patterns. + Check (fun l:List nat => + match l with + | nil => nil + | cons _ l' => l' + end) + Unset Asymmetric Patterns. +\end{coq_example} + \paragraph{Implicit arguments in patterns} By default, implicit arguments are omitted in patterns. So we write: diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 22c75b4fc..6e76d04e7 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -462,11 +462,18 @@ abbreviate a type, like {\tt relation A := A -> A -> Prop}. This is equivalent to {\tt Hint Transparent,Opaque} {\ident} {\tt: typeclass\_instances}. +\subsection{\tt Set Typeclasses Axioms Are Instances} +\optindex{Typeclasses Axioms Are Instances} + +This option (off by default since 8.8) automatically declares axioms +whose type is a typeclass at declaration time as instances of that +class. + \subsection{\tt Set Typeclasses Dependency Order} \optindex{Typeclasses Dependency Order} This option (on by default since 8.6) respects the dependency order between -subgoals, meaning that subgoals which are depended on by other subgoals +subgoals, meaning that subgoals which are depended on by other subgoals come first, while the non-dependent subgoals were put before the dependent ones previously (Coq v8.5 and below). This can result in quite different performance behaviors of proof search. @@ -519,14 +526,14 @@ potentially more expensive proof-search (i.e. more useless backtracking). \subsection{\tt Set Typeclass Resolution After Apply} -\optindex{Typeclasses Resolution After Apply} +\optindex{Typeclass Resolution After Apply} \emph{Deprecated since 8.6} This option (off by default in Coq 8.6 and 8.5) controls the resolution of typeclass subgoals generated by the {\tt apply} tactic. \subsection{\tt Set Typeclass Resolution For Conversion} -\optindex{Typeclasses Resolution For Conversion} +\optindex{Typeclass Resolution For Conversion} This option (on by default) controls the use of typeclass resolution when a unification problem cannot be solved during diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 83e866e9f..cff7be3e9 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -1,4 +1,4 @@ -\achapter{Extraction of programs in Objective Caml and Haskell} +\achapter{Extraction of programs in OCaml and Haskell} %HEVEA\cutname{extraction.html} \label{Extraction} \aauthor{Jean-Christophe Filliâtre and Pierre Letouzey} @@ -95,12 +95,12 @@ one monolithic file or one file per \Coq\ library. \begin{description} \item {\tt Extraction TestCompile} \qualid$_1$ \dots\ \qualid$_n$. ~\par All the globals (or modules) \qualid$_1$ \dots\ \qualid$_n$ and all - their dependencies are extracted to a temporary Ocaml file, just as in + their dependencies are extracted to a temporary {\ocaml} file, just as in {\tt Extraction "{\em file}"}. Then this temporary file and its - signature are compiled with the same Ocaml compiler used to built - \Coq. This command succeeds only if the extraction and the Ocaml + signature are compiled with the same {\ocaml} compiler used to built + \Coq. This command succeeds only if the extraction and the {\ocaml} compilation succeed (and it fails if the current target language - of the extraction is not Ocaml). + of the extraction is not {\ocaml}). \end{description} \asection{Extraction options} @@ -109,26 +109,26 @@ one monolithic file or one file per \Coq\ library. \comindex{Extraction Language} The ability to fix target language is the first and more important -of the extraction options. Default is Ocaml. +of the extraction options. Default is {\ocaml}. \begin{description} -\item {\tt Extraction Language Ocaml}. +\item {\tt Extraction Language OCaml}. \item {\tt Extraction Language Haskell}. \item {\tt Extraction Language Scheme}. \end{description} \asubsection{Inlining and optimizations} -Since Objective Caml is a strict language, the extracted code has to +Since {\ocaml} is a strict language, the extracted code has to be optimized in order to be efficient (for instance, when using induction principles we do not want to compute all the recursive calls but only the needed ones). So the extraction mechanism provides an automatic optimization routine that will be called each time the user -want to generate Ocaml programs. The optimizations can be split in two +want to generate {\ocaml} programs. The optimizations can be split in two groups: the type-preserving ones -- essentially constant inlining and reductions -- and the non type-preserving ones -- some function abstractions of dummy types are removed when it is deemed safe in order to have more elegant types. Therefore some constants may not appear in the -resulting monolithic Ocaml program. In the case of modular extraction, +resulting monolithic {\ocaml} program. In the case of modular extraction, even if some inlining is done, the inlined constant are nevertheless printed, to ensure session-independent programs. @@ -367,15 +367,15 @@ As for {\tt Extract Inductive}, this command should be used with care: \item Extracting an inductive type to a pre-existing ML inductive type is quite sound. But extracting to a general type (by providing an ad-hoc pattern-matching) will often \emph{not} be fully rigorously -correct. For instance, when extracting {\tt nat} to Ocaml's {\tt +correct. For instance, when extracting {\tt nat} to {\ocaml}'s {\tt int}, it is theoretically possible to build {\tt nat} values that are -larger than Ocaml's {\tt max\_int}. It is the user's responsibility to +larger than {\ocaml}'s {\tt max\_int}. It is the user's responsibility to be sure that no overflow or other bad events occur in practice. \item Translating an inductive type to an ML type does \emph{not} magically improve the asymptotic complexity of functions, even if the ML type is an efficient representation. For instance, when extracting -{\tt nat} to Ocaml's {\tt int}, the function {\tt mult} stays +{\tt nat} to {\ocaml}'s {\tt int}, the function {\tt mult} stays quadratic. It might be interesting to associate this translation with some specific {\tt Extract Constant} when primitive counterparts exist. \end{itemize} @@ -391,16 +391,18 @@ Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. \end{coq_example} -\noindent If an inductive constructor or type has arity 2 and the corresponding -string is enclosed by parenthesis, then the rest of the string is used -as infix constructor or type. +\noindent When extracting to {\ocaml}, if an inductive constructor or type +has arity 2 and the corresponding string is enclosed by parentheses, +and the string meets {\ocaml}'s lexical criteria for an infix symbol, +then the rest of the string is used as infix constructor or type. + \begin{coq_example} Extract Inductive list => "list" [ "[]" "(::)" ]. Extract Inductive prod => "(*)" [ "(,)" ]. \end{coq_example} \noindent As an example of translation to a non-inductive datatype, let's turn -{\tt nat} into Ocaml's {\tt int} (see caveat above): +{\tt nat} into {\ocaml}'s {\tt int} (see caveat above): \begin{coq_example} Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". @@ -415,7 +417,7 @@ directly depends from the names of the \Coq\ files. It may happen that these filenames are in conflict with already existing files, either in the standard library of the target language or in other code that is meant to be linked with the extracted code. -For instance the module {\tt List} exists both in \Coq\ and in Ocaml. +For instance the module {\tt List} exists both in \Coq\ and in {\ocaml}. It is possible to instruct the extraction not to use particular filenames. \begin{description} @@ -428,7 +430,7 @@ It is possible to instruct the extraction not to use particular filenames. Allow the extraction to use any filename. \end{description} -\noindent For Ocaml, a typical use of these commands is +\noindent For {\ocaml}, a typical use of these commands is {\tt Extraction Blacklist String List}. \asection{Differences between \Coq\ and ML type systems} @@ -436,7 +438,7 @@ It is possible to instruct the extraction not to use particular filenames. Due to differences between \Coq\ and ML type systems, some extracted programs are not directly typable in ML. -We now solve this problem (at least in Ocaml) by adding +We now solve this problem (at least in {\ocaml}) by adding when needed some unsafe casting {\tt Obj.magic}, which give a generic type {\tt 'a} to any term. @@ -453,7 +455,7 @@ Definition dp := fun (A B:Set)(x:A)(y:B)(f:forall C:Set, C->C) => (f A x, f B y). \end{verbatim} -In Ocaml, for instance, the direct extracted term would be +In {\ocaml}, for instance, the direct extracted term would be \begin{verbatim} let dp x y f = Pair((f () x),(f () y)) \end{verbatim} @@ -478,13 +480,13 @@ Inductive anything : Type := dummy : forall A:Set, A -> anything. \end{verbatim} which corresponds to the definition of an ML dynamic type. -In Ocaml, we must cast any argument of the constructor dummy. +In {\ocaml}, we must cast any argument of the constructor dummy. \end{itemize} \noindent Even with those unsafe castings, you should never get error like ``segmentation fault''. In fact even if your program may seem -ill-typed to the Ocaml type-checker, it can't go wrong: it comes +ill-typed to the {\ocaml} type-checker, it can't go wrong: it comes from a Coq well-typed terms, so for example inductives will always have the correct number of arguments, etc. diff --git a/doc/refman/Omega.tex b/doc/refman/Omega.tex index 8025fbe29..82765da6e 100644 --- a/doc/refman/Omega.tex +++ b/doc/refman/Omega.tex @@ -149,6 +149,32 @@ intro; omega. % Other examples can be found in \verb+$COQLIB/theories/DEMOS/OMEGA+. +\section{Options} + +\begin{quote} + \optindex{Stable Omega} + {\tt Unset Stable Omega} +\end{quote} +This deprecated option (on by default) is for compatibility with Coq +pre 8.5. It resets internal name counters to make executions of +{\tt omega} independent. + +\begin{quote} + \optindex{Omega UseLocalDefs} + {\tt Unset Omega UseLocalDefs} +\end{quote} +This option (on by default) allows {\tt omega} to use the bodies of +local variables. + +\begin{quote} + \optindex{Omega System} + {\tt Set Omega System} + \optindex{Omega Action} + {\tt Set Omega Action} +\end{quote} +These two options (off by default) activate the printing of debug +information. + \asection{Technical data} \label{technical} diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 8b1fc7c8f..04a8a25c1 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -299,8 +299,9 @@ The following command-line options are recognized by the commands {\tt \section{Compiled libraries checker ({\tt coqchk})} -The {\tt coqchk} command takes a list of library paths as argument. -The corresponding compiled libraries (.vo files) are searched in the +The {\tt coqchk} command takes a list of library paths as argument, described +either by their logical name or by their physical filename, which must end in +{\tt .vo}. The corresponding compiled libraries (.vo files) are searched in the path, recursively processing the libraries they depend on. The content of all these libraries is then type-checked. The effect of {\tt coqchk} is only to return with normal exit code in case of success, @@ -330,9 +331,12 @@ code, it cannot be guaranteed that the produced compiled libraries are correct. {\tt coqchk} is a standalone verifier, and thus it cannot be tainted by such malicious code. -Command-line options {\tt -I}, {\tt -R}, {\tt -where} and +Command-line options {\tt -Q}, {\tt -R}, {\tt -where} and {\tt -impredicative-set} are supported by {\tt coqchk} and have the -same meaning as for {\tt coqtop}. Extra options are: +same meaning as for {\tt coqtop}. As there is no notion of relative paths in +object files {\tt -Q} and {\tt -R} have exactly the same meaning. + +Extra options are: \begin{description} \item[{\tt -norec} {\em module}]\ % diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 5c519e46e..a1950d136 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -550,6 +550,60 @@ the same way as the {\Coq} kernel handles them. This tells if the printing matching mode is on or off. The default is on. +\subsubsection{Factorization of clauses with same right-hand side} +\label{SetPrintingFactorizableMatchPatterns} +\optindex{Printing Factorizable Match Patterns} + +When several patterns share the same right-hand side, it is +additionally possible to share the clauses using disjunctive patterns. +Assuming that the printing matching mode is on, whether {\Coq}'s +printer shall try to do this kind of factorization is governed by the +following commands: + +\begin{quote} +{\tt Set Printing Factorizable Match Patterns.} +\end{quote} +This tells {\Coq}'s printer to try to use disjunctive patterns. This is the default +behavior. + +\begin{quote} +{\tt Unset Printing Factorizable Match Patterns.} +\end{quote} +This tells {\Coq}'s printer not to try to use disjunctive patterns. + +\begin{quote} +{\tt Test Printing Factorizable Match Patterns.} +\end{quote} +This tells if the factorization of clauses with same right-hand side is +on or off. + +\subsubsection{Use of a default clause} +\label{SetPrintingAllowDefaultClause} +\optindex{Printing Allow Default Clause} + +When several patterns share the same right-hand side which do not +depend on the arguments of the patterns, yet an extra factorization is +possible: the disjunction of patterns can be replaced with a ``{\tt + \_}'' default clause. Assuming that the printing matching mode and +the factorization mode are on, whether {\Coq}'s printer shall try to +use a default clause is governed by the following commands: + +\begin{quote} +{\tt Set Printing Allow Default Clause.} +\end{quote} +This tells {\Coq}'s printer to use a default clause when relevant. This is the default +behavior. + +\begin{quote} +{\tt Unset Printing Allow Default Clause.} +\end{quote} +This tells {\Coq}'s printer not to use a default clause. + +\begin{quote} +{\tt Test Printing Allow Default Clause.} +\end{quote} +This tells if the use of a default clause is allowed. + \subsubsection{Printing of wildcard pattern \optindex{Printing Wildcard}} diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex index 436099e74..2d9853430 100644 --- a/doc/refman/RefMan-ide.tex +++ b/doc/refman/RefMan-ide.tex @@ -44,9 +44,10 @@ bottom is the status bar. In the script window, you may open arbitrarily many buffers to edit. The \emph{File} menu allows you to open files or create some, save them, print or export them into various formats. Among all these -buffers, there is always one which is the current \emph{running - buffer}, whose name is displayed on a green background, which is the -one where Coq commands are currently executed. +buffers, there is always one which is the current +\emph{running buffer}, whose name is displayed on a background in the +\emph{processed} color (green by default), which is the one where Coq commands +are currently executed. Buffers may be edited as in any text editor, and classical basic editing commands (Copy/Paste, \ldots) are available in the \emph{Edit} @@ -58,12 +59,13 @@ menu. \section{Interactive navigation into \Coq{} scripts} The running buffer is the one where navigation takes place. The -toolbar proposes five basic commands for this. The first one, +toolbar offers five basic navigation commands. The first one, represented by a down arrow icon, is for going forward executing one command. If that command is successful, the part of the script that -has been executed is displayed on a green background. If that command -fails, the error message is displayed in the message window, and the -location of the error is emphasized by a red underline. +has been executed is displayed on a background with the +processed color. If that command fails, the error message is +displayed in the message window, and the location of the error is +emphasized by an underline in the error foreground color (red by default). On Figure~\ref{fig:coqide}, the running buffer is \verb|Fermat.v|, all commands until the \verb|Theorem| have been already executed, and the @@ -71,23 +73,41 @@ user tried to go forward executing \verb|Induction n|. That command failed because no such tactic exist (tactics are now in lowercase\ldots), and the wrong word is underlined. -Notice that the green part of the running buffer is not editable. If +Notice that the processed part of the running buffer is not editable. If you ever want to modify something you have to go backward using the up arrow tool, or even better, put the cursor where you want to go back and use the \textsf{goto} button. Unlike with \verb|coqtop|, you should never use \verb|Undo| to go backward. -Two additional tool buttons exist, one to go directly to the end and -one to go back to the beginning. If you try to go to the end, or in -general to run several commands using the \textsf{goto} button, the - execution will stop whenever an error is found. +There are two additional buttons for navigation within the running buffer. +The ``down'' button with a line goes directly to the end; the ``up'' button +with a line goes back to the beginning. The handling of errors when using the +go-to-the-end button depends on whether \Coq{} is running in asynchronous mode or not +(see Chapter~\ref{Asyncprocessing}). If it is not running in that mode, execution stops +as soon as an error is found. Otherwise, execution continues, and the +error is marked with an underline in the error foreground color, with a background in +the error background color (pink by default). The same characterization of +error-handling applies when running several commands using the \textsf{goto} button. If you ever try to execute a command which happens to run during a long time, and would like to abort it before its termination, you may use the interrupt button (the white cross on a red circle). -Finally, notice that these navigation buttons are also available in -the menu, where their keyboard shortcuts are given. +There are other buttons on the \CoqIDE{} toolbar: a button to save the running +buffer; a button to close the current buffer (an ``X''); buttons to switch among +buffers (left and right arrows); an ``information'' button; and a ``gears'' button. + +The ``information'' button is described in Section~\ref{sec:trytactics}. + +The ``gears'' button submits proof terms to the \Coq{} kernel for type-checking. +When \Coq{} uses asynchronous processing (see Chapter~\ref{Asyncprocessing}), proofs may +have been completed without kernel-checking of generated proof terms. The presence of +unchecked proof terms is indicated by \texttt{Qed} statements +that have a subdued \emph{being-processed} color (light blue by default), +rather than the processed color, though their preceding proofs have the processed color. + +Notice that for all these buttons, except for the ``gears'' button, their operations +are also available in the menu, where their keyboard shortcuts are given. \section[Try tactics automatically]{Try tactics automatically\label{sec:trytactics}} @@ -96,8 +116,8 @@ trying to solve the current goal using simple tactics. If such a tactic succeeds in solving the goal, then its text is automatically inserted into the script. There is finally a combination of these tactics, called the \emph{proof wizard} which will try each of them in -turn. This wizard is also available as a tool button (the light -bulb). The set of tactics tried by the wizard is customizable in +turn. This wizard is also available as a tool button (the ``information'' +button). The set of tactics tried by the wizard is customizable in the preferences. These tactics are general ones, in particular they do not refer to @@ -132,7 +152,7 @@ arguments. \begin{figure}[t] \begin{center} -%HEVEA\imgsrc[alt="coqide query window"]{coqide-queries.png} +%HEVEA\imgsrc[alt="coqide query"]{coqide-queries.png} %BEGIN LATEX \ifpdf % si on est en pdflatex \includegraphics[width=1.0\textwidth]{coqide-queries.png} @@ -141,27 +161,21 @@ arguments. \fi %END LATEX \end{center} -\caption{\CoqIDE{}: the query window} -\label{fig:querywindow} +\caption{\CoqIDE{}: a Print query on a selected phrase} +\label{fig:queryselected} \end{figure} - -We call \emph{query} any vernacular command that do not change the -current state, such as \verb|Check|, \verb|Search|, etc. Those -commands are of course useless during compilation of a file, hence -should not be included in scripts. To run such commands without -writing them in the script, \CoqIDE{} offers another input window -called the \emph{query window}. This window can be displayed on -demand, either by using the \texttt{Window} menu, or directly using -shortcuts given in the \texttt{Queries} menu. Indeed, with \CoqIDE{} -the simplest way to perform a \texttt{Search} on some identifier -is to select it using the mouse, and pressing \verb|F2|. This will -both make appear the query window and run the \texttt{Search} in -it, displaying the result. Shortcuts \verb|F3| and \verb|F4| are for -\verb|Check| and \verb|Print| respectively. -Figure~\ref{fig:querywindow} displays the query window after selection -of the word ``mult'' in the script windows, and pressing \verb|F4| to -print its definition. +We call \emph{query} any vernacular command that does not change the +current state, such as \verb|Check|, \verb|Search|, etc. +To run such commands interactively, without writing them in scripts, +\CoqIDE{} offers a \emph{query pane}. +The query pane can be displayed on demand by using the \texttt{View} menu, +or using the shortcut \verb|F1|. Queries can also be performed by +selecting a particular phrase, then choosing an item from the +\texttt{Queries} menu. The response then appears in the message window. +Figure~\ref{fig:queryselected} shows the result after selecting +of the phrase \verb|Nat.mul| in the script window, and choosing \verb|Print| +from the \texttt{Queries} menu. \section{Compilation} diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex index c8e844302..89f5be843 100644 --- a/doc/refman/RefMan-lib.tex +++ b/doc/refman/RefMan-lib.tex @@ -55,6 +55,7 @@ Figure~\ref{init-notations}. \hline Notation & Precedence & Associativity \\ \hline +\verb!_ -> _! & 99 & right \\ \verb!_ <-> _! & 95 & no \\ \verb!_ \/ _! & 85 & right \\ \verb!_ /\ _! & 80 & right \\ diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 5fb458588..c4c0435c5 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -198,8 +198,6 @@ is understood as {\cpattern} {\tt =>} {\tacexpr}\\ & $|$ & {\tt context} {\zeroone{\ident}} {\tt [} {\cpattern} {\tt ]} {\tt =>} {\tacexpr}\\ -& $|$ & {\tt appcontext} {\zeroone{\ident}} {\tt [} {\cpattern} {\tt ]} - {\tt =>} {\tacexpr}\\ & $|$ & {\tt \_ =>} {\tacexpr}\\ \\ {\it test} & ::= & @@ -311,10 +309,11 @@ A sequence is an expression of the following form: \begin{quote} {\tacexpr}$_1$ {\tt ;} {\tacexpr}$_2$ \end{quote} -The expressions {\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated -to $v_1$ and $v_2$ which have to be tactic values. The tactic $v_1$ is -then applied and $v_2$ is applied to the goals generated by the -application of $v_1$. Sequence is left-associative. +The expression {\tacexpr}$_1$ is evaluated to $v_1$, which must be +a tactic value. The tactic $v_1$ is applied to the current goal, +possibly producing more goals. Then {\tacexpr}$_2$ is evaluated to +produce $v_2$, which must be a tactic value. The tactic $v_2$ is applied to +all the goals produced by the prior application. Sequence is associative. \subsubsection[Local application of tactics]{Local application of tactics\tacindex{[>\ldots$\mid$\ldots$\mid$\ldots]}\tacindex{;[\ldots$\mid$\ldots$\mid$\ldots]}\index{Tacticals![> \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}\index{Tacticals!; [ \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}} %\tacindex{; [ | ]} @@ -710,6 +709,55 @@ runs is displayed. Time is in seconds and is machine-dependent. The {\qstring} argument is optional. When provided, it is used to identify this particular occurrence of {\tt time}. +\subsubsection{Timing a tactic that evaluates to a term\tacindex{time\_constr}\tacindex{restart\_timer}\tacindex{finish\_timing} +\index{Tacticals!time\_constr@{\tt time\_constr}}} +\index{Tacticals!restart\_timer@{\tt restart\_timer}} +\index{Tacticals!finish\_timing@{\tt finish\_timing}} + +Tactic expressions that produce terms can be timed with the experimental tactic +\begin{quote} + {\tt time\_constr} {\tacexpr} +\end{quote} +which evaluates {\tacexpr\tt{ ()}} +and displays the time the tactic expression evaluated, assuming successful evaluation. +Time is in seconds and is machine-dependent. + +This tactic currently does not support nesting, and will report times based on the innermost execution. +This is due to the fact that it is implemented using the tactics +\begin{quote} + {\tt restart\_timer} {\qstring} +\end{quote} +and +\begin{quote} + {\tt finish\_timing} ({\qstring}) {\qstring} +\end{quote} +which (re)set and display an optionally named timer, respectively. +The parenthesized {\qstring} argument to {\tt finish\_timing} is also +optional, and determines the label associated with the timer for +printing. + +By copying the definition of {\tt time\_constr} from the standard +library, users can achive support for a fixed pattern of nesting by +passing different {\qstring} parameters to {\tt restart\_timer} and +{\tt finish\_timing} at each level of nesting. For example: + +\begin{coq_example} +Ltac time_constr1 tac := + let eval_early := match goal with _ => restart_timer "(depth 1)" end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) "(depth 1)" end in + ret. + +Goal True. + let v := time_constr + ltac:(fun _ => + let x := time_constr1 ltac:(fun _ => constr:(10 * 10)) in + let y := time_constr1 ltac:(fun _ => eval compute in x) in + y) in + pose v. +Abort. +\end{coq_example} + \subsubsection[Local definitions]{Local definitions\index{Ltac!let@\texttt{let}} \index{Ltac!let rec@\texttt{let rec}} \index{let@\texttt{let}!in Ltac} @@ -875,21 +923,6 @@ Goal True. f (3+4). \end{coq_example} -\item \index{appcontext@\texttt{appcontext}!in pattern} - \optindex{Tactic Compat Context} -For historical reasons, {\tt context} used to consider $n$-ary applications -such as {\tt (f 1 2)} as a whole, and not as a sequence of unary -applications {\tt ((f 1) 2)}. Hence {\tt context [f ?x]} would fail -to find a matching subterm in {\tt (f 1 2)}: if the pattern was a partial -application, the matched subterms would have necessarily been -applications with exactly the same number of arguments. -As a workaround, one could use the following variant of {\tt context}: -\begin{quote} -{\tt appcontext} {\ident} {\tt [} {\cpattern} {\tt ]} -\end{quote} -This syntax is now deprecated, as {\tt context} behaves as intended. The former -behavior can be retrieved with the {\tt Tactic Compat Context} flag. - \end{Variants} \subsubsection[Pattern matching on goals]{Pattern matching on goals\index{Ltac!match goal@\texttt{match goal}}\label{ltac-match-goal} @@ -1374,10 +1407,35 @@ The following two tactics behave like {\tt idtac} but enable and disable the pro {\tt stop ltac profiling}. \end{quote} +\tacindex{reset ltac profile}\tacindex{show ltac profile} +The following tactics behave like the corresponding vernacular commands and allow displaying and resetting the profile from tactic scripts for benchmarking purposes. + +\begin{quote} +{\tt reset ltac profile}. +\end{quote} + +\begin{quote} +{\tt show ltac profile}. +\end{quote} + +\begin{quote} +{\tt show ltac profile} {\qstring}. +\end{quote} + You can also pass the {\tt -profile-ltac} command line option to {\tt coqc}, which performs a {\tt Set Ltac Profiling} at the beginning of each document, and a {\tt Show Ltac Profile} at the end. Note that the profiler currently does not handle backtracking into multi-success tactics, and issues a warning to this effect in many cases when such backtracking occurs. +\subsection[Run-time optimization tactic]{Run-time optimization tactic\label{tactic-optimizeheap}}. + +The following tactic behaves like {\tt idtac}, and running it compacts the heap in the +OCaml run-time system. It is analogous to the Vernacular command {\tt Optimize Heap} (see~\ref{vernac-optimizeheap}). + +\tacindex{optimize\_heap} +\begin{quote} +{\tt optimize\_heap}. +\end{quote} + \endinput \subsection{Permutation on closed lists} diff --git a/doc/refman/RefMan-mod.tex b/doc/refman/RefMan-mod.tex index e56c8fa7f..b4e270e6c 100644 --- a/doc/refman/RefMan-mod.tex +++ b/doc/refman/RefMan-mod.tex @@ -403,10 +403,14 @@ Fail Check B.T. \end{Warnings} \subsection{\tt Print Module {\ident} -\comindex{Print Module}} +\comindex{Print Module} \optindex{Short Module Printing}} Prints the module type and (optionally) the body of the module {\ident}. +For this command and {\tt Print Module Type}, the option {\tt Short + Module Printing} (off by default) disables the printing of the types of fields, +leaving only their names. + \subsection{\tt Print Module Type {\ident} \comindex{Print Module Type}} diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 3ebeba178..1cd23c929 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -912,6 +912,15 @@ This command turns off the use of a default timeout. This command displays whether some default timeout has be set or not. +\subsection[\tt Fail \textrm{\textsl{command-or-tactic}}.]{\tt Fail \textrm{\textsl{command-or-tactic}}.\comindex{Fail}\label{Fail}} + +For debugging {\Coq} scripts, sometimes it is desirable to know +whether a command or a tactic fails. If the given command or tactic +fails, the {\tt Fail} statement succeeds, without changing the proof +state, and in interactive mode, {\Coq} prints a message confirming the failure. +If the command or tactic succeeds, the statement is an error, and +{\Coq} prints a message indicating that the failure did not occur. + \section{Controlling display} \subsection[\tt Set Silent.]{\tt Set Silent.\optindex{Silent} diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index 991c9745e..05775bfbe 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -499,7 +499,7 @@ Claude Marché coordinated the edition of the Reference Manual for Pierre Letouzey and Jacek Chrz\k{a}szcz respectively maintained the extraction tool and module system of {\Coq}. -Jean-Christophe Filliâtre, Pierre Letouzey, Hugo Herbelin ando +Jean-Christophe Filliâtre, Pierre Letouzey, Hugo Herbelin and other contributors from Sophia-Antipolis and Nijmegen participated to the extension of the library. @@ -659,7 +659,7 @@ Matthieu Sozeau extended the \textsc{Russell} language, ending in an convenient way to write programs of given specifications, Pierre Corbineau extended the Mathematical Proof Language and the automatization tools that accompany it, Pierre Letouzey supervised and -extended various parts the standard library, Stéphane Glondu +extended various parts of the standard library, Stéphane Glondu contributed a few tactics and improvements, Jean-Marc Notin provided help in debugging, general maintenance and {\tt coqdoc} support, Vincent Siles contributed extensions of the {\tt Scheme} command and @@ -680,7 +680,7 @@ Nicolas Tabareau made the adaptation of the interface of the old the interaction between Coq and its external interfaces. With Samuel Mimram, he also helped making Coq compatible with recent software tools. Russell O'Connor, Cezary Kaliscyk, Milad Niqui contributed to -improved the libraries of integers, rational, and real numbers. We +improve the libraries of integers, rational, and real numbers. We also thank many users and partners for suggestions and feedback, in particular Pierre Castéran and Arthur Charguéraud, the INRIA Marelle team, Georges Gonthier and the INRIA-Microsoft Mathematical Components team, @@ -714,7 +714,7 @@ implementation of $\mathbb{N}$, $\mathbb{Z}$ or $\mathbb{Z}/n\mathbb{Z}$. The main other evolutions of the library are due to Hugo Herbelin who -made a revision of the sorting library (includingh a certified +made a revision of the sorting library (including a certified merge-sort) and to Guillaume Melquiond who slightly revised and cleaned up the library of reals. @@ -723,7 +723,7 @@ some efficiency issues and a more flexible construction of module types, Élie Soubiran brought a new model of name equivalence, the $\Delta$-equivalence, which respects as much as possible the names given by the users. He also designed with Pierre Letouzey a new -convenient operator \verb!<+! for nesting functor application, what +convenient operator \verb!<+! for nesting functor application, that provides a light notation for inheriting the properties of cascading modules. diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 8f659ded3..6b24fdde7 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -320,10 +320,19 @@ Note that when a focused goal is proved a message is displayed together with a suggestion about the right bullet or {\tt \}} to unfocus it or focus the next one. +\begin{Variants} + +\item {\tt {\num}: \{}\\ +This focuses on the $\num^{th}$ subgoal to prove. + +\end{Variants} + \begin{ErrMsgs} \item \errindex{This proof is focused, but cannot be unfocused this way} You are trying to use {\tt \}} but the current subproof has not been fully solved. +\item \errindex{No such goal} +\item \errindex{Brackets only support the single numbered goal selector} \item see also error message about bullets below. \end{ErrMsgs} @@ -395,6 +404,8 @@ Proof. \end{ErrMsgs} +\subsection[\tt Set Bullet Behavior.]{\tt Set Bullet Behavior.\optindex{Bullet Behavior}} + The bullet behavior can be controlled by the following commands. \begin{quote} @@ -553,12 +564,12 @@ used to force Coq to optimize some of its internal data structures. This command forces Coq to shrink the data structure used to represent the ongoing proof. -\subsection[\tt Optimize Heap.]{\tt Optimize Heap.} +\subsection[\tt Optimize Heap.]{\tt Optimize Heap.\label{vernac-optimizeheap}} This command forces the OCaml runtime to perform a heap compaction. -This is in general an expensive operation. See: - \url{http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact} - +This is in general an expensive operation. See: \\ +\ \url{http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact} \\ +There is also an analogous tactic {\tt optimize\_heap} (see~\ref{tactic-optimizeheap}). %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 956f30851..30724759d 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -127,8 +127,10 @@ conclusion is {\tt (n:nat)(even n)->(Q n)}. \optindex{Boolean Equality Schemes} \optindex{Elimination Schemes} \optindex{Nonrecursive Elimination Schemes} +\optindex{Record Elimination Schemes} \optindex{Case Analysis Schemes} \optindex{Decidable Equality Schemes} +\optindex{Rewriting Schemes} \label{set-nonrecursive-elimination-schemes} } @@ -142,6 +144,7 @@ and {\tt Record} (see~\ref{Record}) do not have an automatic declaration of the induction principles. It can be activated with the command {\tt Set Nonrecursive Elimination Schemes}. It can be deactivated again with {\tt Unset Nonrecursive Elimination Schemes}. +{\tt Record Elimination Schemes} is a deprecated alias of {\tt Nonrecursive Elimination Schemes}. In addition, the {\tt Case Analysis Schemes} flag governs the generation of case analysis lemmas for inductive types, i.e. corresponding to the @@ -156,6 +159,9 @@ However you have to be careful with this option since \Coq~ may now reject well-defined inductive types because it cannot compute a Boolean equality for them. +The {\tt Rewriting Schemes} flag governs generation of equality +related schemes such as congruence. + \subsection{\tt Combined Scheme} \label{CombinedScheme} \comindex{Combined Scheme} diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex index be199e0b2..31dabcdd4 100644 --- a/doc/refman/RefMan-ssr.tex +++ b/doc/refman/RefMan-ssr.tex @@ -3096,10 +3096,10 @@ the tactic \ssrC{rewrite (=~ multi1)} is equivalent to \end{lstlisting} except that the constants \ssrC{eqba, eqab, mult1_rev} have not been created. -Rewriting with multirules -is useful to implement simplification or transformation -procedures, to be applied on terms of small to medium size. For -instance the library \ssrL{ssrnat} provides two implementations for +Rewriting with multirules is useful to implement simplification or +transformation procedures, to be applied on terms of small to medium +size. For instance, the library \ssrL{ssrnat} --- available in the +external math-comp library --- provides two implementations for arithmetic operations on natural numbers: an elementary one and a tail recursive version, less inefficient but also less convenient for reasoning purposes. The library also provides one lemma per such diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index eecb5ac7c..a4ed2134e 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -3,25 +3,32 @@ In this chapter, we introduce advanced commands to modify the way {\Coq} parses and prints objects, i.e. the translations between the -concrete and internal representations of terms and commands. The main -commands are {\tt Notation} and {\tt Infix} which are described in -section \ref{Notation}. It also happens that the same symbolic -notation is expected in different contexts. To achieve this form of -overloading, {\Coq} offers a notion of interpretation scope. This is -described in Section~\ref{scopes}. - -\Rem The commands {\tt Grammar}, {\tt Syntax} and {\tt Distfix} which -were present for a while in {\Coq} are no longer available from {\Coq} -version 8.0. The underlying AST structure is also no longer available. -The functionalities of the command {\tt Syntactic Definition} are -still available; see Section~\ref{Abbreviations}. +concrete and internal representations of terms and commands. + +The main commands to provide custom symbolic notations for terms are +{\tt Notation} and {\tt Infix}. They are described in Section +\ref{Notation}. There is also a variant of {\tt Notation} which does +not modify the parser. This provides with a form of abbreviation and +it is described in Section~\ref{Abbreviations}. It is sometimes +expected that the same symbolic notation has different meanings in +different contexts. To achieve this form of overloading, {\Coq} offers +a notion of interpretation scope. This is described in +Section~\ref{scopes}. + +The main command to provide custom notations for tactics is {\tt + Tactic Notation}. It is described in Section~\ref{Tactic-Notation}. + +% No need any more to remind this +%% \Rem The commands {\tt Grammar}, {\tt Syntax} and {\tt Distfix} which +%% were present for a while in {\Coq} are no longer available from {\Coq} +%% version 8.0. The underlying AST structure is also no longer available. \section[Notations]{Notations\label{Notation} \comindex{Notation}} \subsection{Basic notations} -A {\em notation} is a symbolic abbreviation denoting some term +A {\em notation} is a symbolic expression denoting some term or term pattern. A typical notation is the use of the infix symbol \verb=/\= to denote @@ -37,7 +44,7 @@ string \verb="A /\ B"= (called a {\em notation}) tells how it is symbolically written. A notation is always surrounded by double quotes (except when the -abbreviation is a single identifier; see \ref{Abbreviations}). The +abbreviation has the form of an ordinary applicative expression; see \ref{Abbreviations}). The notation is composed of {\em tokens} separated by spaces. Identifiers in the string (such as \texttt{A} and \texttt{B}) are the {\em parameters} of the notation. They must occur at least once each in the @@ -61,7 +68,7 @@ syntactic expression (see \ref{ReservedNotation}), explicit precedences and associativity rules have to be given. \Rem The right-hand side of a notation is interpreted at the time the -notation is given. In particular, implicit arguments (see +notation is given. In particular, disambiguation of constants, implicit arguments (see Section~\ref{Implicit Arguments}), coercions (see Section~\ref{Coercions}), etc. are resolved at the time of the declaration of the notation. @@ -105,8 +112,8 @@ parentheses are mandatory (this is a ``no associativity'')\footnote{ which {\Coq} is built, namely {\camlpppp}, currently does not implement the no-associativity and replaces it by a left associativity; hence it is the same for {\Coq}: no-associativity is in fact left associativity}. -We don't know of a special convention of the associativity of -disjunction and conjunction, so let's apply for instance a right +We do not know of a special convention of the associativity of +disjunction and conjunction, so let us apply for instance a right associativity (which is the choice of {\Coq}). Precedence levels and associativity rules of notations have to be @@ -142,7 +149,8 @@ Notation "x = y" := (@eq _ x y) (at level 70, no associativity). \end{coq_example*} One can define {\em closed} notations whose both sides are symbols. In -this case, the default precedence level for inner subexpression is 200. +this case, the default precedence level for inner subexpression is +200, and the default level for the notation itself is 0. \begin{coq_eval} Set Printing Depth 50. @@ -150,7 +158,7 @@ Set Printing Depth 50. (**** an incompatibility with the reserved notation ********) \end{coq_eval} \begin{coq_example*} -Notation "( x , y )" := (@pair _ _ x y) (at level 0). +Notation "( x , y )" := (@pair _ _ x y). \end{coq_example*} One can also define notations for binders. @@ -161,17 +169,17 @@ Set Printing Depth 50. (**** an incompatibility with the reserved notation ********) \end{coq_eval} \begin{coq_example*} -Notation "{ x : A | P }" := (sig A (fun x => P)) (at level 0). +Notation "{ x : A | P }" := (sig A (fun x => P)). \end{coq_example*} In the last case though, there is a conflict with the notation for -type casts. This last notation, as shown by the command {\tt Print Grammar +type casts. The notation for type casts, as shown by the command {\tt Print Grammar constr} is at level 100. To avoid \verb=x : A= being parsed as a type cast, it is necessary to put {\tt x} at a level below 100, typically 99. Hence, a -correct definition is +correct definition is the following. \begin{coq_example*} -Notation "{ x : A | P }" := (sig A (fun x => P)) (at level 0, x at level 99). +Notation "{ x : A | P }" := (sig A (fun x => P)) (x at level 99). \end{coq_example*} %This change has retrospectively an effect on the notation for notation @@ -182,14 +190,17 @@ Notation "{ x : A | P }" := (sig A (fun x => P)) (at level 0, x at level 99). %Notation "{ A } + { B }" := (sumbool A B) (at level 0, A at level 99). %\end{coq_example*} -See the next section for more about factorization. +More generally, it is required that notations are explicitly +factorized on the left. See the next section for more about +factorization. \subsection{Simple factorization rules} -{\Coq} extensible parsing is performed by Camlp5 which is essentially a -LL1 parser. Hence, some care has to be taken not to hide already -existing rules by new rules. Some simple left factorization work has -to be done. Here is an example. +{\Coq} extensible parsing is performed by {\camlpppp} which is +essentially a LL1 parser: it decides which notation to parse by +looking tokens from left to right. Hence, some care has to be taken +not to hide already existing rules by new rules. Some simple left +factorization work has to be done. Here is an example. \begin{coq_eval} (********** The next rule for notation _ < _ < _ produces **********) @@ -242,17 +253,19 @@ on the {\Coq} printer. For example: Check (and True True). \end{coq_example} -However, printing, especially pretty-printing, requires -more care than parsing. We may want specific indentations, -line breaks, alignment if on several lines, etc. +However, printing, especially pretty-printing, also requires some +care. We may want specific indentations, line breaks, alignment if on +several lines, etc. For pretty-printing, {\Coq} relies on {\ocaml} +formatting library, which provides indentation and automatic line +breaks depending on page width by means of {\em formatting boxes}. -The default printing of notations is very rudimentary. For printing a -notation, a {\em formatting box} is opened in such a way that if the +The default printing of notations is rudimentary. For printing a +notation, a formatting box is opened in such a way that if the notation and its arguments cannot fit on a single line, a line break is inserted before the symbols of the notation and the arguments on the next lines are aligned with the argument on the first line. -A first, simple control that a user can have on the printing of a +A first simple control that a user can have on the printing of a notation is the insertion of spaces at some places of the notation. This is performed by adding extra spaces between the symbols and parameters: each extra space (other than the single space needed @@ -277,6 +290,13 @@ Notation "'If' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) \end{coq_example} \end{small} +\begin{coq_example} +Check + (IF_then_else (IF_then_else True False True) + (IF_then_else True False True) + (IF_then_else True False True)). +\end{coq_example} + A {\em format} is an extension of the string denoting the notation with the possible following elements delimited by single quotes: @@ -313,22 +333,15 @@ Notations do not survive the end of sections. No typing of the denoted expression is performed at definition time. Type-checking is done only at the time of use of the notation. -\begin{coq_example} -Check - (IF_then_else (IF_then_else True False True) - (IF_then_else True False True) - (IF_then_else True False True)). -\end{coq_example} - \Rem Sometimes, a notation is expected only for the parser. %(e.g. because %the underlying parser of {\Coq}, namely {\camlpppp}, is LL1 and some extra %rules are needed to circumvent the absence of factorization). -To do so, the option {\em only parsing} is allowed in the list of modifiers of +To do so, the option {\tt only parsing} is allowed in the list of modifiers of \texttt{Notation}. -Conversely, the {\em only printing} can be used to declare +Conversely, the {\tt only printing} can be used to declare that a notation should only be used for printing and should not declare a parsing rule. In particular, such notations do not modify the parser. @@ -339,16 +352,16 @@ The \texttt{Infix} command is a shortening for declaring notations of infix symbols. Its syntax is \begin{quote} -\noindent\texttt{Infix "{\symbolentry}" :=} {\qualid} {\tt (} \nelist{\em modifier}{,} {\tt )}. +\noindent\texttt{Infix "{\symbolentry}" :=} {\term} {\tt (} \nelist{\em modifier}{,} {\tt )}. \end{quote} and it is equivalent to \begin{quote} -\noindent\texttt{Notation "x {\symbolentry} y" := ({\qualid} x y) (} \nelist{\em modifier}{,} {\tt )}. +\noindent\texttt{Notation "x {\symbolentry} y" := ({\term} x y) (} \nelist{\em modifier}{,} {\tt )}. \end{quote} -where {\tt x} and {\tt y} are fresh names distinct from {\qualid}. Here is an example. +where {\tt x} and {\tt y} are fresh names. Here is an example. \begin{coq_example*} Infix "/\" := and (at level 80, right associativity). @@ -380,12 +393,14 @@ reserved. Hence their precedence and associativity cannot be changed. \comindex{CoFixpoint {\ldots} where {\ldots}} \comindex{Inductive {\ldots} where {\ldots}}} -Thanks to reserved notations, the inductive, co-inductive, recursive -and corecursive definitions can benefit of customized notations. To do -this, insert a {\tt where} notation clause after the definition of the -(co)inductive type or (co)recursive term (or after the definition of -each of them in case of mutual definitions). The exact syntax is given -on Figure~\ref{notation-syntax}. Here are examples: +Thanks to reserved notations, the inductive, co-inductive, record, +recursive and corecursive definitions can benefit of customized +notations. To do this, insert a {\tt where} notation clause after the +definition of the (co)inductive type or (co)recursive term (or after +the definition of each of them in case of mutual definitions). The +exact syntax is given on Figure~\ref{notation-syntax} for inductive, +co-inductive, recursive and corecursive definitions and on +Figure~\ref{record-syntax} for records. Here are examples: \begin{coq_eval} Set Printing Depth 50. @@ -479,20 +494,28 @@ Locate "exists _ .. _ , _". \\ \\ {\modifiers} - & ::= & \nelist{\ident}{,} {\tt at level} {\naturalnumber} \\ - & $|$ & \nelist{\ident}{,} {\tt at next level} \\ - & $|$ & {\tt at level} {\naturalnumber} \\ - & $|$ & {\tt left associativity} \\ - & $|$ & {\tt right associativity} \\ - & $|$ & {\tt no associativity} \\ + & ::= & {\tt at level} {\naturalnumber} \\ + & $|$ & \nelist{\ident}{,} {\tt at level} {\naturalnumber} \zeroone{\binderinterp}\\ + & $|$ & \nelist{\ident}{,} {\tt at next level} \zeroone{\binderinterp}\\ + & $|$ & {\ident} {\binderinterp} \\ & $|$ & {\ident} {\tt ident} \\ - & $|$ & {\ident} {\tt binder} \\ - & $|$ & {\ident} {\tt closed binder} \\ & $|$ & {\ident} {\tt global} \\ & $|$ & {\ident} {\tt bigint} \\ + & $|$ & {\ident} \zeroone{{\tt strict}} {\tt pattern} \zeroone{{\tt at level} {\naturalnumber}}\\ + & $|$ & {\ident} {\tt binder} \\ + & $|$ & {\ident} {\tt closed binder} \\ + & $|$ & {\tt left associativity} \\ + & $|$ & {\tt right associativity} \\ + & $|$ & {\tt no associativity} \\ & $|$ & {\tt only parsing} \\ & $|$ & {\tt only printing} \\ - & $|$ & {\tt format} {\str} + & $|$ & {\tt format} {\str} \\ +\\ +\\ +{\binderinterp} + & ::= & {\tt as ident} \\ + & $|$ & {\tt as pattern} \\ + & $|$ & {\tt as strict pattern} \\ \end{tabular} \end{centerframe} \end{small} @@ -500,9 +523,93 @@ Locate "exists _ .. _ , _". \label{notation-syntax} \end{figure} -\subsection{Notations and simple binders} +\subsection{Notations and binders} + +Notations can include binders. This section lists +different ways to deal with binders. For further examples, see also +Section~\ref{RecursiveNotationsWithBinders}. -Notations can be defined for binders as in the example: +\subsubsection{Binders bound in the notation and parsed as identifiers} + +Here is the basic example of a notation using a binder: + +\begin{coq_example*} +Notation "'sigma' x : A , B" := (sigT (fun x : A => B)) + (at level 200, x ident, A at level 200, right associativity). +\end{coq_example*} + +The binding variables in the right-hand side that occur as a parameter +of the notation (here {\tt x}) dynamically bind all the occurrences +in their respective binding scope after instantiation of the +parameters of the notation. This means that the term bound to {\tt B} can +refer to the variable name bound to {\tt x} as shown in the following +application of the notation: + +\begin{coq_example} +Check sigma z : nat, z = 0. +\end{coq_example} + +Notice the modifier {\tt x ident} in the declaration of the +notation. It tells to parse {\tt x} as a single identifier. + +\subsubsection{Binders bound in the notation and parsed as patterns} + +In the same way as patterns can be used as binders, as in {\tt fun + '(x,y) => x+y} or {\tt fun '(existT \_ x \_) => x}, notations can be +defined so that any pattern (in the sense of the entry {\pattern} of +Figure~\ref{term-syntax-aux}) can be used in place of the +binder. Here is an example: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Notation "'subset' ' p , P " := (sig (fun p => P)) + (at level 200, p pattern, format "'subset' ' p , P"). +\end{coq_example*} + +\begin{coq_example} +Check subset '(x,y), x+y=0. +\end{coq_example} + +The modifier {\tt p pattern} in the declaration of the notation +tells to parse $p$ as a pattern. Note that a single +variable is both an identifier and a pattern, so, e.g., the following +also works: + +% Note: we rely on the notation of the standard library which does not +% print the expected output, so we hide the output. +\begin{coq_example} +Check subset 'x, x=0. +\end{coq_example} + +If one wants to prevent such a notation to be used for printing when the +pattern is reduced to a single identifier, one has to use instead +the modifier {\tt p strict pattern}. For parsing, however, a {\tt + strict pattern} will continue to include the case of a +variable. Here is an example showing the difference: + +\begin{coq_example*} +Notation "'subset_bis' ' p , P" := (sig (fun p => P)) + (at level 200, p strict pattern). +Notation "'subset_bis' p , P " := (sig (fun p => P)) + (at level 200, p ident). +\end{coq_example*} + +\begin{coq_example} +Check subset_bis 'x, x=0. +\end{coq_example} + +The default level for a {\tt pattern} is 0. One can use a different level by +using {\tt pattern at level} $n$ where the scale is the same as the one for +terms (Figure~\ref{init-notations}). + +\subsubsection{Binders bound in the notation and parsed as terms} + +Sometimes, for the sake of factorization of rules, a binder has to be +parsed as a term. This is typically the case for a notation such as +the following: \begin{coq_eval} Set Printing Depth 50. @@ -510,18 +617,53 @@ Set Printing Depth 50. (**** an incompatibility with the reserved notation ********) \end{coq_eval} \begin{coq_example*} -Notation "{ x : A | P }" := (sig (fun x : A => P)) (at level 0). +Notation "{ x : A | P }" := (sig (fun x : A => P)) + (at level 0, x at level 99 as ident). +\end{coq_example*} + +This is so because the grammar also contains rules starting with +{\tt \{} and followed by a term, such as the rule for the notation + {\tt \{ A \} + \{ B \}} for the constant {\tt + sumbool}~(see Section~\ref{sumbool}). + +Then, in the rule, {\tt x ident} is replaced by {\tt x at level 99 as + ident} meaning that {\tt x} is parsed as a term at level 99 (as done +in the notation for {\tt sumbool}), but that this term has actually to +be an identifier. + +The notation {\tt \{ x | P \}} is already defined in the standard +library with the {\tt as ident} modifier. We cannot redefine it but +one can define an alternative notation, say {\tt \{ p such that P }\}, +using instead {\tt as pattern}. + +% Note, this conflicts with the default rule in the standard library, so +% we don't show the +\begin{coq_example*} +Notation "{ p 'such' 'that' P }" := (sig (fun p => P)) + (at level 0, p at level 99 as pattern). \end{coq_example*} -The binding variables in the left-hand-side that occur as a parameter -of the notation naturally bind all their occurrences appearing in -their respective scope after instantiation of the parameters of the -notation. +Then, the following works: +\begin{coq_example} +Check {(x,y) such that x+y=0}. +\end{coq_example} + +To enforce that the pattern should not be used for printing when it +is just an identifier, one could have said {\tt p at level + 99 as strict pattern}. + +Note also that in the absence of a {\tt as ident}, {\tt as strict + pattern} or {\tt as pattern} modifiers, the default is to consider +subexpressions occurring in binding position and parsed as terms to be +{\tt as ident}. -Contrastingly, the binding variables that are not a parameter of the -notation do not capture the variables of same name that -could appear in their scope after instantiation of the -notation. E.g., for the notation +\subsubsection{Binders not bound in the notation} +\label{NotationsWithBinders} + +We can also have binders in the right-hand side of a notation which +are not themselves bound in the notation. In this case, the binders +are considered up to renaming of the internal binder. E.g., for the +notation \begin{coq_example*} Notation "'exists_different' n" := (exists p:nat, p<>n) (at level 200). @@ -537,14 +679,6 @@ Set Printing Depth 50. Fail Check (exists_different p). \end{coq_example} -\Rem Binding variables must not necessarily be parsed using the -{\tt ident} entry. For factorization purposes, they can be said to be -parsed at another level (e.g. {\tt x} in \verb="{ x : A | P }"= must be -parsed at level 99 to be factorized with the notation -\verb="{ A } + { B }"= for which {\tt A} can be any term). -However, even if parsed as a term, this term must at the end be effectively -a single identifier. - \subsection{Notations with recursive patterns} \label{RecursiveNotations} @@ -565,24 +699,22 @@ notation parses any number of time (but at least one time) a sequence of expressions separated by the sequence of tokens $s$ (in the example, $s$ is just ``{\tt ;}''). -In the right-hand side, the term enclosed within {\tt ..} must be a -pattern with two holes of the form $\phi([~]_E,[~]_I)$ where the first -hole is occupied either by $x$ or by $y$ and the second hole is -occupied by an arbitrary term $t$ called the {\it terminating} -expression of the recursive notation. The subterm {\tt ..} $\phi(x,t)$ -{\tt ..} (or {\tt ..} $\phi(y,t)$ {\tt ..}) must itself occur at -second position of the same pattern where the first hole is occupied -by the other variable, $y$ or $x$. Otherwise said, the right-hand side -must contain a subterm of the form either $\phi(x,${\tt ..} -$\phi(y,t)$ {\tt ..}$)$ or $\phi(y,${\tt ..} $\phi(x,t)$ {\tt ..}$)$. -The pattern $\phi$ is the {\em iterator} of the recursive notation -and, of course, the name $x$ and $y$ can be chosen arbitrarily. - -The parsing phase produces a list of expressions which are used to -fill in order the first hole of the iterating pattern which is +The right-hand side must contain a subterm of the form either +$\phi(x,${\tt ..} $\phi(y,t)$ {\tt ..}$)$ or $\phi(y,${\tt ..} +$\phi(x,t)$ {\tt ..}$)$ where $\phi([~]_E,[~]_I)$, called the {\em + iterator} of the recursive notation is an arbitrary expression with +distinguished placeholders and +where $t$ is called the {\tt terminating expression} of the recursive +notation. In the example, we choose the name s$x$ and $y$ but in +practice they can of course be chosen arbitrarily. Note that the +placeholder $[~]_I$ has to occur only once but the $[~]_E$ can occur +several times. + +Parsing the notation produces a list of expressions which are used to +fill the first placeholder of the iterating pattern which itself is repeatedly nested as many times as the length of the list, the second -hole being the nesting point. In the innermost occurrence of the -nested iterating pattern, the second hole is finally filled with the +placeholder being the nesting point. In the innermost occurrence of the +nested iterating pattern, the second placeholder is finally filled with the terminating expression. In the example above, the iterator $\phi([~]_E,[~]_I)$ is {\tt cons @@ -609,24 +741,26 @@ notations, they can also be declared within interpretation scopes (see section \ref{scopes}). \subsection{Notations with recursive patterns involving binders} +\label{RecursiveNotationsWithBinders} Recursive notations can also be used with binders. The basic example is: \begin{coq_example*} -Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) +Notation "'exists' x .. y , p" := + (ex (fun x => .. (ex (fun y => p)) ..)) (at level 200, x binder, y binder, right associativity). \end{coq_example*} The principle is the same as in Section~\ref{RecursiveNotations} -except that in the iterator $\phi([~]_E,[~]_I)$, the first hole is a -placeholder occurring at the position of the binding variable of a {\tt +except that in the iterator $\phi([~]_E,[~]_I)$, the placeholder $[~]_E$ can +also occur in position of the binding variable of a {\tt fun} or a {\tt forall}. To specify that the part ``$x$ {\tt ..} $y$'' of the notation parses a sequence of binders, $x$ and $y$ must be marked as {\tt - binder} in the list of modifiers of the notation. Then, the list of -binders produced at the parsing phase are used to fill in the first -hole of the iterating pattern which is repeatedly nested as many times + binder} in the list of modifiers of the notation. The +binders of the parsed sequence are used to fill the occurrences of the first +placeholder of the iterating pattern which is repeatedly nested as many times as the number of binders generated. If ever the generalization operator {\tt `} (see Section~\ref{implicit-generalization}) is used in the binding list, the added binders are taken into account too. @@ -635,14 +769,14 @@ Binders parsing exist in two flavors. If $x$ and $y$ are marked as {\tt binder}, then a sequence such as {\tt a b c : T} will be accepted and interpreted as the sequence of binders {\tt (a:T) (b:T) (c:T)}. For instance, in the notation above, the syntax {\tt exists - a b : nat, a = b} is provided. + a b : nat, a = b} is valid. The variables $x$ and $y$ can also be marked as {\tt closed binder} in which case only well-bracketed binders of the form {\tt (a b c:T)} or {\tt \{a b c:T\}} etc. are accepted. With closed binders, the recursive sequence in the left-hand side can -be of the general form $x$ $s$ {\tt ..} $s$ $y$ where $s$ is an +be of the more general form $x$ $s$ {\tt ..} $s$ $y$ where $s$ is an arbitrary sequence of tokens. With open binders though, $s$ has to be empty. Here is an example of recursive notation with closed binders: @@ -661,6 +795,40 @@ Notation "'FUNAPP' x .. y , f" := (at level 200, x binder, y binder, right associativity). \end{coq_example*} +If an occurrence of the $[~]_E$ is not in position of a binding +variable but of a term, it is the name used in the binding which is +used. Here is an example: + +\begin{coq_example*} +Notation "'exists_non_null' x .. y , P" := + (ex (fun x => x <> 0 /\ .. (ex (fun y => y <> 0 /\ P)) ..)) + (at level 200, x binder). +\end{coq_example*} + +\subsection{Predefined entries} + +By default, sub-expressions are parsed as terms and the corresponding +grammar entry is called {\tt constr}. However, one may sometimes want +to restrict the syntax of terms in a notation. For instance, the +following notation will accept to parse only global reference in +position of {\tt x}: + +\begin{coq_example*} +Notation "'apply' f a1 .. an" := (.. (f a1) .. an) + (at level 10, f global, a1, an at level 9). +\end{coq_example*} + +In addition to {\tt global}, one can restrict the syntax of a +sub-expression by using the entry names {\tt ident} or {\tt pattern} +already seen in Section~\ref{NotationsWithBinders}, even when the +corresponding expression is not used as a binder in the right-hand +side. E.g.: + +\begin{coq_example*} +Notation "'apply_id' f a1 .. an" := (.. (f a1) .. an) + (at level 10, f ident, a1, an at level 9). +\end{coq_example*} + \subsection{Summary} \paragraph{Syntax of notations} @@ -754,7 +922,7 @@ stack by using the command {\tt Close Scope} {\scope}. \end{quote} Notice that this command does not only cancel the last {\tt Open Scope -{\scope}} but all the invocation of it. +{\scope}} but all the invocations of it. \Rem {\tt Open Scope} and {\tt Close Scope} do not survive the end of sections where they occur. When defined outside of a section, they are @@ -1108,7 +1276,7 @@ Check reflexive iff. \end{coq_example} An abbreviation expects no precedence nor associativity, since it -follows the usual syntax of application. Abbreviations are used as +is parsed as usual application. Abbreviations are used as much as possible by the {\Coq} printers unless the modifier \verb=(only parsing)= is given. @@ -1121,7 +1289,7 @@ abbreviation but at the time it is used. Especially, abbreviations can be bound to terms with holes (i.e. with ``\_''). The general syntax for abbreviations is \begin{quote} -\zeroone{{\tt Local}} \texttt{Notation} {\ident} \sequence{\ident} {\ident} \texttt{:=} {\term} +\zeroone{{\tt Local}} \texttt{Notation} {\ident} \sequence{\ident}{} \texttt{:=} {\term} \zeroone{{\tt (only parsing)}}~\verb=.= \end{quote} @@ -1147,13 +1315,15 @@ at the time of use of the abbreviation. %\verb=(only parsing)= is given) while syntactic definitions were not. \section{Tactic Notations +\label{Tactic-Notation} \comindex{Tactic Notation}} Tactic notations allow to customize the syntax of the tactics of the -tactic language\footnote{Tactic notations are just a simplification of -the {\tt Grammar tactic simple\_tactic} command that existed in -versions prior to version 8.0.}. Tactic notations obey the following -syntax +tactic language. +%% \footnote{Tactic notations are just a simplification of +%% the {\tt Grammar tactic simple\_tactic} command that existed in +%% versions prior to version 8.0.} +Tactic notations obey the following syntax: \medskip \noindent @@ -1196,7 +1366,9 @@ level indicates the parsing precedence of the tactic notation. This information is particularly relevant for notations of tacticals. Levels 0 to 5 are available (default is 0). To know the parsing precedences of the -existing tacticals, use the command {\tt Print Grammar tactic.} +existing tacticals, use the command +\comindex{Print Grammar tactic} + {\tt Print Grammar tactic.} Each type of tactic argument has a specific semantic regarding how it is parsed and how it is interpreted. The semantic is described in the diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 675c2bf17..66a5f107a 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3334,6 +3334,14 @@ evaluating purely computational expressions (i.e. with little dead code). \end{Variants} +\Rem The following option makes {\tt cbv} (and its derivative {\tt + compute}) print information about the constants it encounters and +the unfolding decisions it makes. +\begin{quote} + \optindex{Debug Cbv} + {\tt Set Debug Cbv} +\end{quote} + % Obsolete? Anyway not very important message %\begin{ErrMsgs} %\item \errindex{Delta must be specified before} @@ -3507,6 +3515,13 @@ of {\tt cbn} while doing reductions in unification, type inference and tactic applications. It can result in expensive unifications, as refolding currently uses a potentially exponential heuristic. +\begin{quote} + \optindex{Debug RAKAM} + {\tt Set Debug RAKAM} +\end{quote} +This option makes {\tt cbn} print various debugging information. +{\tt RAKAM} is the Refolding Algebraic Krivine Abstract Machine. + \subsection{\tt unfold \qualid} \tacindex{unfold} \label{unfold} @@ -3703,6 +3718,9 @@ hints of the database named {\tt core}. This variant is very useful for getting a better understanding of automation, or to know what lemmas/assumptions were used. +\item {\tt debug auto} Behaves like {\tt auto} but shows the tactics + it tries to solve the goal, including failing paths. + \item {\tt \zeroone{info\_}auto \zeroone{\num}} \zeroone{{\tt using} \nterm{lemma}$_1$ {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$} \zeroone{{\tt with} \ident$_1$ {\ldots} \ident$_n$} @@ -3723,6 +3741,8 @@ hints of the database named {\tt core}. \item {\tt info\_trivial} +\item {\tt debug trivial} + \item {\tt \zeroone{info\_}trivial} \zeroone{{\tt using} \nterm{lemma}$_1$ {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$} \zeroone{{\tt with} \ident$_1$ {\ldots} \ident$_n$} @@ -3732,6 +3752,19 @@ hints of the database named {\tt core}. \Rem {\tt auto} either solves completely the goal or else leaves it intact. \texttt{auto} and \texttt{trivial} never fail. +\Rem The following options enable printing of informative or debug +information for the {\tt auto} and {\tt trivial} tactics: +\begin{quote} + \optindex{Info Auto} + {\tt Set Info Auto} + \optindex{Debug Auto} + {\tt Set Debug Auto} + \optindex{Info Trivial} + {\tt Set Info Trivial} + \optindex{Debug Trivial} + {\tt Set Debug Trivial} +\end{quote} + \SeeAlso Section~\ref{Hints-databases} \subsection{\tt eauto} @@ -3768,6 +3801,14 @@ Note that {\tt ex\_intro} should be declared as a hint. \end{Variants} +\Rem {\tt eauto} obeys the following options: +\begin{quote} + \optindex{Info Eauto} + {\tt Set Info Eauto} + \optindex{Debug Eauto} + {\tt Set Debug Eauto} +\end{quote} + \SeeAlso Section~\ref{Hints-databases} \subsection{\tt autounfold with \ident$_1$ \mbox{\dots} \ident$_n$} @@ -4710,6 +4751,13 @@ congruence. described above. \end{ErrMsgs} +\noindent {\bf Remark: } {\tt congruence} can be made to print debug +information by setting the following option: + +\begin{quote} +\optindex{Congruence Verbose} +{\tt Set Congruence Verbose} +\end{quote} \section{Checking properties of terms} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index c411db100..962aa98b6 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -4,53 +4,24 @@ The distribution provides utilities to simplify some tedious works beside proof development, tactics writing or documentation. -\section[Building a toplevel extended with user tactics]{Building a toplevel extended with user tactics\label{Coqmktop}\ttindex{coqmktop}} +\section[Using Coq as a library]{Using Coq as a library} -The native-code version of \Coq\ cannot dynamically load user tactics -using {\ocaml} code. It is possible to build a toplevel of \Coq, -with {\ocaml} code statically linked, with the tool {\tt - coqmktop}. - -For example, one can build a native-code \Coq\ toplevel extended with a tactic -which source is in {\tt tactic.ml} with the command -\begin{verbatim} - % coqmktop -opt -o mytop.out tactic.cmx -\end{verbatim} -where {\tt tactic.ml} has been compiled with the native-code -compiler {\tt ocamlopt}. This command generates an executable -called {\tt mytop.out}. To use this executable to compile your \Coq\ -files, use {\tt coqc -image mytop.out}. - -A basic example is the native-code version of \Coq\ ({\tt coqtop.opt}), -which can be generated by {\tt coqmktop -opt -o coqopt.opt}. - - -\paragraph[Application: how to use the {\ocaml} debugger with Coq.]{Application: how to use the {\ocaml} debugger with Coq.\index{Debugger}} - -One useful application of \texttt{coqmktop} is to build a \Coq\ toplevel in -order to debug your tactics with the {\ocaml} debugger. -You need to have configured and compiled \Coq\ for debugging -(see the file \texttt{INSTALL} included in the distribution). -Then, you must compile the Caml modules of your tactic with the -option \texttt{-g} (with the bytecode compiler) and build a stand-alone -bytecode toplevel with the following command: +In previous versions, \texttt{coqmktop} was used to build custom +toplevels --- for example for better debugging or custom static +linking. Nowadays, the preferred method is to use \texttt{ocamlfind}. +The most basic custom toplevel is built using: \begin{quotation} -\texttt{\% coqmktop -g -o coq-debug}~\emph{<your \texttt{.cmo} files>} +\texttt{\% ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg + -package coq.toplevel toplevel/coqtop\_bin.ml -o my\_toplevel.native} \end{quotation} - -To launch the \ocaml\ debugger with the image you need to execute it in -an environment which correctly sets the \texttt{COQLIB} variable. -Moreover, you have to indicate the directories in which -\texttt{ocamldebug} should search for Caml modules. - -A possible solution is to use a wrapper around \texttt{ocamldebug} -which detects the executables containing the word \texttt{coq}. In -this case, the debugger is called with the required additional -arguments. In other cases, the debugger is simply called without additional -arguments. Such a wrapper can be found in the \texttt{dev/} -subdirectory of the sources. +For example, to statically link LTAC, you can just do: +\begin{quotation} +\texttt{\% ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg + -package coq.toplevel -package coq.ltac toplevel/coqtop\_bin.ml -o my\_toplevel.native} +\end{quotation} +and similarly for other plugins. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 75fac9454..6c84a1818 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -68,6 +68,13 @@ is only valid as long as \texttt{Top.4} is strictly smaller than monomorphic (not universe polymorphic), so the two universes (in this case \texttt{Top.3} and \texttt{Top.4}) are actually global levels. +When printing \texttt{pidentity}, we can see the universes it binds in +the annotation \texttt{@\{Top.2\}}. Additionally, when \texttt{Set + Printing Universes} is on we print the ``universe context'' of +\texttt{pidentity} consisting of the bound universes and the +constraints they must verify (for \texttt{pidentity} there are no +constraints). + Inductive types can also be declared universes polymorphic on universes appearing in their parameters or fields. A typical example is given by monoids: @@ -138,7 +145,7 @@ producing global universe constraints, one can use the \optindex{Polymorphic Inductive Cumulativity} Polymorphic inductive types, coinductive types, variants and records can be -declared cumulative using the \texttt{Cumulative}. Alternatively, +declared cumulative using the \texttt{Cumulative} prefix. Alternatively, there is an option \texttt{Set Polymorphic Inductive Cumulativity} which when set, makes all subsequent \emph{polymorphic} inductive definitions cumulative. When set, inductive types and the like can be enforced to be @@ -151,15 +158,22 @@ Polymorphic Cumulative Inductive list {A : Type} := \begin{coq_example} Print list. \end{coq_example} -When printing \texttt{list}, the part of the output of the form -\texttt{$\mathtt{\sim}$@\{i\} <= $\mathtt{\sim}$@\{j\} iff } -indicates the universe constraints in order to have the subtyping -$\WTEGLECONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ -(for fully applied instances of \texttt{list}) whenever $\WTEGCONV{A}{B}$. -In the case of \texttt{list} there is no constraint! -This also means that any two instances of \texttt{list} are convertible: -$\WTEGCONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ whenever $\WTEGCONV{A}{B}$ and -furthermore their corresponding (when fully applied to convertible arguments) constructors. +When printing \texttt{list}, the universe context indicates the +subtyping constraints by prefixing the level names with symbols. + +Because inductive subtypings are only produced by comparing inductives +to themselves with universes changed, they amount to variance +information: each universe is either invariant, covariant or +irrelevant (there are no contravariant subtypings in Coq), +respectively represented by the symbols \texttt{=}, \texttt{+} and +\texttt{*}. + +Here we see that \texttt{list} binds an irrelevant universe, so any +two instances of \texttt{list} are convertible: +$\WTEGCONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ whenever +$\WTEGCONV{A}{B}$ and furthermore their corresponding (when fully +applied to convertible arguments) constructors. + See Chapter~\ref{Cic} for more details on convertibility and subtyping. The following is an example of a record with non-trivial subtyping relation: \begin{coq_example*} @@ -168,8 +182,9 @@ Polymorphic Cumulative Record packType := {pk : Type}. \begin{coq_example} Print packType. \end{coq_example} -Notice that as expected, \texttt{packType@\{i\}} and \texttt{packType@\{j\}} are -convertible if and only if \texttt{i $=$ j}. +\texttt{packType} binds a covariant universe, i.e. +$\WTEGCONV{\mathtt{packType@\{i\}}}{\mathtt{packType@\{j\}}}$ whenever +\texttt{i $\leq$ j}. Cumulative inductive types, coninductive types, variants and records only make sense when they are universe polymorphic. Therefore, an @@ -285,8 +300,10 @@ universes and explicitly instantiate polymorphic definitions. \label{UniverseCmd}} In the monorphic case, this command declares a new global universe named -{\ident}. It supports the polymorphic flag only in sections, meaning the -universe quantification will be discharged on each section definition +{\ident}, which can be referred to using its qualified name as +well. Global universe names live in a separate namespace. The command +supports the polymorphic flag only in sections, meaning the universe +quantification will be discharged on each section definition independently. One cannot mix polymorphic and monomorphic declarations in the same section. diff --git a/doc/refman/coqide-queries.png b/doc/refman/coqide-queries.png Binary files differindex dea5626f8..7a46ac4e6 100644 --- a/doc/refman/coqide-queries.png +++ b/doc/refman/coqide-queries.png diff --git a/doc/refman/coqide.png b/doc/refman/coqide.png Binary files differindex a6a0f5850..e300401c9 100644 --- a/doc/refman/coqide.png +++ b/doc/refman/coqide.png diff --git a/engine/eConstr.ml b/engine/eConstr.ml index afdceae06..9ac16b5b4 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -150,6 +150,8 @@ type rel_declaration = (constr, types) Context.Rel.Declaration.pt type named_context = (constr, types) Context.Named.pt type rel_context = (constr, types) Context.Rel.pt +type 'a puniverses = 'a * EInstance.t + let in_punivs a = (a, EInstance.empty) let mkProp = of_kind (Sort (ESorts.make Sorts.prop)) @@ -645,6 +647,37 @@ let eq_constr_universes_proj env sigma m n = let res = eq_constr' (unsafe_to_constr m) (unsafe_to_constr n) in if res then Some !cstrs else None +let universes_of_constr env sigma c = + let open Univ in + let open Declarations in + let rec aux s c = + match kind sigma c with + | Const (c, u) -> + begin match (Environ.lookup_constant c env).const_universes with + | Polymorphic_const _ -> + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + | Monomorphic_const (univs, _) -> + LSet.union s univs + end + | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> + begin match (Environ.lookup_mind mind env).mind_universes with + | Cumulative_ind _ | Polymorphic_ind _ -> + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + | Monomorphic_ind (univs,_) -> + LSet.union s univs + end + | Sort u -> + let sort = ESorts.kind sigma u in + if Sorts.is_small sort then s + else + let u = Sorts.univ_of_sort sort in + LSet.fold LSet.add (Universe.levels u) s + | Evar (k, args) -> + let concl = Evd.evar_concl (Evd.find sigma k) in + fold sigma aux (aux s (of_constr concl)) c + | _ -> fold sigma aux s c + in aux LSet.empty c + open Context open Environ @@ -662,6 +695,10 @@ let cast_rel_context : type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt = fun Refl x -> x +let cast_rec_decl : + type a b. (a,b) eq -> (a, a) Constr.prec_declaration -> (b, b) Constr.prec_declaration = + fun Refl x -> x + let cast_named_decl : type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt = fun Refl x -> x @@ -737,6 +774,20 @@ let rec isArity sigma c = | Sort _ -> true | _ -> false +type arity = rel_context * ESorts.t + +let destArity sigma = + let open Context.Rel.Declaration in + let rec prodec_rec l c = + match kind sigma c with + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c + | Cast (c,_,_) -> prodec_rec l c + | Sort s -> l,s + | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.") + in + prodec_rec [] + let mkProd_or_LetIn decl c = let open Context.Rel.Declaration in match decl with @@ -770,6 +821,7 @@ let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d let push_rel d e = push_rel (cast_rel_decl unsafe_eq d) e let push_rel_context d e = push_rel_context (cast_rel_context unsafe_eq d) e +let push_rec_types d e = push_rec_types (cast_rec_decl unsafe_eq d) e let push_named d e = push_named (cast_named_decl unsafe_eq d) e let push_named_context d e = push_named_context (cast_named_context unsafe_eq d) e let push_named_context_val d e = push_named_context_val (cast_named_decl unsafe_eq d) e @@ -784,6 +836,15 @@ let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e) let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e) +let map_rel_context_in_env f env sign = + let rec aux env acc = function + | d::sign -> + aux (push_rel d env) (Context.Rel.Declaration.map_constr (f env) d :: acc) sign + | [] -> + acc + in + aux env [] (List.rev sign) + let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in evd, of_constr t diff --git a/engine/eConstr.mli b/engine/eConstr.mli index e9ef302cf..6fa338c73 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -56,6 +56,8 @@ sig val is_empty : t -> bool end +type 'a puniverses = 'a * EInstance.t + (** {5 Destructors} *) val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_term @@ -144,7 +146,11 @@ val isFix : Evd.evar_map -> t -> bool val isCoFix : Evd.evar_map -> t -> bool val isCase : Evd.evar_map -> t -> bool val isProj : Evd.evar_map -> t -> bool + +type arity = rel_context * ESorts.t +val destArity : Evd.evar_map -> types -> arity val isArity : Evd.evar_map -> t -> bool + val isVarId : Evd.evar_map -> Id.t -> t -> bool val isRelN : Evd.evar_map -> int -> t -> bool @@ -187,9 +193,9 @@ val whd_evar : Evd.evar_map -> constr -> constr val eq_constr : Evd.evar_map -> t -> t -> bool val eq_constr_nounivs : Evd.evar_map -> t -> t -> bool -val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option -val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option -val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.universe_constraints option +val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option +val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option +val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) @@ -201,6 +207,10 @@ val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a +(** Gather the universes transitively used in the term, including in the + type of evars appearing in it. *) +val universes_of_constr : Environ.env -> Evd.evar_map -> t -> Univ.LSet.t + (** {6 Substitutions} *) module Vars : @@ -241,6 +251,7 @@ end val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env +val push_rec_types : (t, t) Constr.prec_declaration -> env -> env val push_named : named_declaration -> env -> env val push_named_context : named_context -> env -> env @@ -256,6 +267,9 @@ val lookup_rel : int -> env -> rel_declaration val lookup_named : variable -> env -> named_declaration val lookup_named_val : variable -> named_context_val -> named_declaration +val map_rel_context_in_env : + (env -> constr -> constr) -> env -> rel_context -> rel_context + (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 907f1b1ac..f82ffccdc 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -199,9 +199,10 @@ let whd_head_evar sigma c = let meta_counter_summary_name = "meta counter" (* Generator of metavariables *) -let new_meta = - let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in - fun () -> incr meta_ctr; !meta_ctr +let meta_ctr, meta_counter_summary_tag = + Summary.ref_tag 0 ~name:meta_counter_summary_name + +let new_meta () = incr meta_ctr; !meta_ctr let mk_new_meta () = EConstr.mkMeta(new_meta()) @@ -256,22 +257,6 @@ let make_pure_subst evi args = * we have the property that u and phi(t) are convertible in env. *) -let csubst_subst (k, s) c = - (** Safe because this is a substitution *) - let c = EConstr.Unsafe.to_constr c in - let rec subst n c = match Constr.kind c with - | Rel m -> - if m <= n then c - else if m - n <= k then EConstr.Unsafe.to_constr (Int.Map.find (k - m + n) s) - else mkRel (m - k) - | _ -> Constr.map_with_binders succ subst n c - in - let c = if k = 0 then c else subst 0 c in - EConstr.of_constr c - -let subst2 subst vsubst c = - csubst_subst subst (EConstr.Vars.replace_vars vsubst c) - let next_ident_away id avoid = let avoid id = Id.Set.mem id avoid in next_ident_away_from id avoid @@ -281,19 +266,79 @@ let next_name_away na avoid = let id = match na with Name id -> id | Anonymous -> default_non_dependent_ident in next_ident_away_from id avoid -type csubst = int * EConstr.t Int.Map.t - -let empty_csubst = (0, Int.Map.empty) +type subst_val = +| SRel of int +| SVar of Id.t + +type csubst = { + csubst_len : int; + (** Cardinal of [csubst_rel] *) + csubst_var : Constr.t Id.Map.t; + (** A mapping of variables to variables. We use the more general + [Constr.t] to share allocations, but all values are of shape [Var _]. *) + csubst_rel : Constr.t Int.Map.t; + (** A contiguous mapping of integers to variables. Same remark for values. *) + csubst_rev : subst_val Id.Map.t; + (** Reverse mapping of the substitution *) +} +(** This type represent a name substitution for the named and De Bruijn parts of + a environment. For efficiency we also store the reverse substitution. + Invariant: all identifiers in the codomain of [csubst_var] and [csubst_rel] + must be pairwise distinct. *) + +let empty_csubst = { + csubst_len = 0; + csubst_rel = Int.Map.empty; + csubst_var = Id.Map.empty; + csubst_rev = Id.Map.empty; +} + +let csubst_subst { csubst_len = k; csubst_var = v; csubst_rel = s } c = + (** Safe because this is a substitution *) + let c = EConstr.Unsafe.to_constr c in + let rec subst n c = match Constr.kind c with + | Rel m -> + if m <= n then c + else if m - n <= k then Int.Map.find (k - m + n) s + else mkRel (m - k) + | Var id -> + begin try Id.Map.find id v with Not_found -> c end + | _ -> Constr.map_with_binders succ subst n c + in + let c = if k = 0 && Id.Map.is_empty v then c else subst 0 c in + EConstr.of_constr c type ext_named_context = - csubst * (Id.t * EConstr.constr) list * - Id.Set.t * EConstr.named_context - -let push_var id (n, s) = - let s = Int.Map.add n (EConstr.mkVar id) s in - (succ n, s) - -let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) = + csubst * Id.Set.t * EConstr.named_context + +let push_var id { csubst_len = n; csubst_var = v; csubst_rel = s; csubst_rev = r } = + let s = Int.Map.add n (Constr.mkVar id) s in + let r = Id.Map.add id (SRel n) r in + { csubst_len = succ n; csubst_var = v; csubst_rel = s; csubst_rev = r } + +(** Post-compose the substitution with the generator [src ↦ tgt] *) +let update_var src tgt subst = + let cur = + try Some (Id.Map.find src subst.csubst_rev) + with Not_found -> None + in + match cur with + | None -> + (** Missing keys stand for identity substitution [src ↦ src] *) + let csubst_var = Id.Map.add src (Constr.mkVar tgt) subst.csubst_var in + let csubst_rev = Id.Map.add tgt (SVar src) subst.csubst_rev in + { subst with csubst_var; csubst_rev } + | Some bnd -> + let csubst_rev = Id.Map.add tgt bnd (Id.Map.remove src subst.csubst_rev) in + match bnd with + | SRel m -> + let csubst_rel = Int.Map.add m (Constr.mkVar tgt) subst.csubst_rel in + { subst with csubst_rel; csubst_rev } + | SVar id -> + let csubst_var = Id.Map.add id (Constr.mkVar tgt) subst.csubst_var in + { subst with csubst_var; csubst_rev } + +let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) = let open EConstr in let open Vars in let map_decl f d = @@ -329,18 +374,17 @@ let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) = binding named [id], we will keep [id0] (the name given by the user) and rename [id0] into [id] in the named context. Unless [id] is a section variable. *) - let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in - let vsubst = (id0,mkVar id)::vsubst in - let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (subst2 subst vsubst) in + let subst = update_var id0 id subst in + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in let nc = List.map (replace_var_named_declaration id0 id) nc in - (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc) + (push_var id0 subst, Id.Set.add id avoid, d :: nc) | _ -> (* spiwack: if [id0] is a section variable renaming it is incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) - let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (subst2 subst vsubst) in - (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc) + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (csubst_subst subst) in + (push_var id subst, Id.Set.add id avoid, d :: nc) let push_rel_context_to_named_context env sigma typ = (* compute the instances relative to the named context and rel_context *) @@ -349,17 +393,17 @@ let push_rel_context_to_named_context env sigma typ = let ids = List.map get_id (named_context env) in let inst_vars = List.map mkVar ids in if List.is_empty (Environ.rel_context env) then - (named_context_val env, typ, inst_vars, empty_csubst, []) + (named_context_val env, typ, inst_vars, empty_csubst) else let avoid = List.fold_right Id.Set.add ids Id.Set.empty in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in (* move the rel context to a named context and extend the named instance *) (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) - let (subst, vsubst, _, env) = + let (subst, _, env) = Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) - (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) in - (val_of_named_context env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst) + (rel_context env) ~init:(empty_csubst, avoid, named_context env) in + (val_of_named_context env, csubst_subst subst typ, inst_rels@inst_vars, subst) (*------------------------------------* * Entry points to define new evars * @@ -424,8 +468,8 @@ let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?prin (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env evd typ in - let map c = subst2 subst vsubst c in + let sign,typ',instance,subst = push_rel_context_to_named_context env evd typ in + let map c = csubst_subst subst c in let candidates = Option.map (fun l -> List.map map l) candidates in let instance = match filter with @@ -691,6 +735,55 @@ let undefined_evars_of_evar_info evd evi = (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) +type undefined_evars_cache = { + mutable cache : (EConstr.named_declaration * Evar.Set.t) ref Id.Map.t; +} + +let create_undefined_evars_cache () = { cache = Id.Map.empty; } + +let cached_evar_of_hyp cache sigma decl accu = match cache with +| None -> + let fold c acc = + let evs = undefined_evars_of_term sigma c in + Evar.Set.union evs acc + in + NamedDecl.fold_constr fold decl accu +| Some cache -> + let id = NamedDecl.get_id decl in + let r = + try Id.Map.find id cache.cache + with Not_found -> + (** Dummy value *) + let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in + let () = cache.cache <- Id.Map.add id r cache.cache in + r + in + let (decl', evs) = !r in + let evs = + if NamedDecl.equal (==) decl decl' then snd !r + else + let fold c acc = + let evs = undefined_evars_of_term sigma c in + Evar.Set.union evs acc + in + let evs = NamedDecl.fold_constr fold decl Evar.Set.empty in + let () = r := (decl, evs) in + evs + in + Evar.Set.fold Evar.Set.add evs accu + +let filtered_undefined_evars_of_evar_info ?cache sigma evi = + let evars_of_named_context cache accu nc = + let fold decl accu = cached_evar_of_hyp cache sigma (EConstr.of_named_decl decl) accu in + Context.Named.fold_outside fold nc ~init:accu + in + let accu = match evi.evar_body with + | Evar_empty -> Evar.Set.empty + | Evar_defined b -> evars_of_term b + in + let accu = Evar.Set.union (undefined_evars_of_term sigma (EConstr.of_constr evi.evar_concl)) accu in + evars_of_named_context cache accu (evar_filtered_context evi) + (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an [evar_map]. If unification only need to check superficially, tactics diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 5fd4634d6..923bf49a9 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -133,6 +133,12 @@ val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t +type undefined_evars_cache + +val create_undefined_evars_cache : unit -> undefined_evars_cache + +val filtered_undefined_evars_of_evar_info : ?cache:undefined_evars_cache -> evar_map -> evar_info -> Evar.Set.t + (** [occur_evar_upto sigma k c] returns [true] if [k] appears in [c]. It looks up recursively in [sigma] for the value of existential variables. *) @@ -216,14 +222,13 @@ val empty_csubst : csubst val csubst_subst : csubst -> constr -> constr type ext_named_context = - csubst * (Id.t * constr) list * - Id.Set.t * named_context + csubst * Id.Set.t * named_context val push_rel_decl_to_named_context : evar_map -> rel_declaration -> ext_named_context -> ext_named_context val push_rel_context_to_named_context : Environ.env -> evar_map -> types -> - named_context_val * types * constr list * csubst * (Id.t*constr) list + named_context_val * types * constr list * csubst val generalize_evar_over_rels : evar_map -> existential -> types * constr list @@ -236,7 +241,7 @@ val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> val subterm_source : Evar.t -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located -val meta_counter_summary_name : string +val meta_counter_summary_tag : int Summary.Dyn.tag (** Deprecated *) type type_constraint = types option diff --git a/engine/evd.ml b/engine/evd.ml index d57ae89dd..0e9472158 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -401,7 +401,7 @@ let rename evk id (evtoid, idtoev) = | None -> (EvMap.add evk id evtoid, Id.Map.add id evk idtoev) | Some id' -> if Id.Map.mem id idtoev then anomaly (str "Evar name already in use."); - (EvMap.update evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev)) + (EvMap.set evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in @@ -466,9 +466,8 @@ let add d e i = add_with_name d e i let evar_counter_summary_name = "evar counter" (* Generator of existential names *) -let new_untyped_evar = - let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in - fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr +let evar_ctr, evar_counter_summary_tag = Summary.ref_tag 0 ~name:evar_counter_summary_name +let new_untyped_evar () = incr evar_ctr; Evar.unsafe_of_int !evar_ctr let new_evar evd ?name evi = let evk = new_untyped_evar () in @@ -856,7 +855,7 @@ let normalize_universe evd = let normalize_universe_instance evd l = let vars = ref (UState.subst evd.universes) in - let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + let normalize = Universes.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in Univ.Instance.subst_fn normalize l let normalize_sort evars s = diff --git a/engine/evd.mli b/engine/evd.mli index fb5a6cd16..b28ce2a62 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -208,7 +208,7 @@ val is_defined : evar_map -> Evar.t-> bool val is_undefined : evar_map -> Evar.t-> bool (** Whether an evar is not defined in an evarmap. *) -val add_constraints : evar_map -> Univ.constraints -> evar_map +val add_constraints : evar_map -> Univ.Constraint.t -> evar_map (** Add universe constraints in an evar map. *) val undefined_map : evar_map -> evar_info Evar.Map.t @@ -316,7 +316,7 @@ val whd_sort_variable : evar_map -> constr -> constr exception UniversesDiffer -val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map +val add_universe_constraints : evar_map -> Universes.Constraints.t -> evar_map (** Add the given universe unification constraints to the evar map. @raises UniversesDiffer in case a first-order unification fails. @raises UniverseInconsistency @@ -491,7 +491,7 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * UState.t val evar_universe_context_set : UState.t -> Univ.ContextSet.t -val evar_universe_context_constraints : UState.t -> Univ.constraints +val evar_universe_context_constraints : UState.t -> Univ.Constraint.t val evar_context_universe_context : UState.t -> Univ.UContext.t [@@ocaml.deprecated "alias of UState.context"] @@ -513,7 +513,7 @@ val universe_of_name : evar_map -> Id.t -> Univ.Level.t val universe_binders : evar_map -> Universes.universe_binders val add_constraints_context : UState.t -> - Univ.constraints -> UState.t + Univ.Constraint.t -> UState.t val normalize_evar_universe_context_variables : UState.t -> @@ -613,7 +613,7 @@ type unsolvability_explanation = SeveralInstancesFound of int (* This stuff is internal and should not be used. Currently a hack in the STM relies on it. *) -val evar_counter_summary_name : string +val evar_counter_summary_tag : int Summary.Dyn.tag (** {5 Deprecated functions} *) val create_evar_defs : evar_map -> evar_map diff --git a/engine/ftactic.mli b/engine/ftactic.mli index c108c0c2e..65ee929c8 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -39,10 +39,10 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t +val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t +val enter : (Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 9dc5d473b..3674bb943 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -107,7 +107,6 @@ struct let print_debug s = make (fun _ -> Feedback.msg_info s) let print_info s = make (fun _ -> Feedback.msg_info s) let print_warning s = make (fun _ -> Feedback.msg_warning s) - let print_error s = make (fun _ -> Feedback.msg_error s) let print_notice s = make (fun _ -> Feedback.msg_notice s) let run = fun x -> diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 8c8f9fe93..50b4abd8b 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -61,7 +61,6 @@ module NonLogical : sig val print_warning : Pp.t -> unit t val print_notice : Pp.t -> unit t val print_info : Pp.t -> unit t - val print_error : Pp.t -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index 3b945c87f..c41b0b0dc 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -634,32 +634,42 @@ let shelve_goals l = InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) -(** [contained_in_info e evi] checks whether the evar [e] appears in - the hypotheses, the conclusion or the body of the evar_info - [evi]. Note: since we want to use it on goals, the body is actually - supposed to be empty. *) -let contained_in_info sigma e evi = - Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) - (** [depends_on sigma src tgt] checks whether the goal [src] appears as an existential variable in the definition of the goal [tgt] in [sigma]. *) let depends_on sigma src tgt = let evi = Evd.find sigma tgt in - contained_in_info sigma src evi + Evar.Set.mem src (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + +let unifiable_delayed g l = + CList.exists (fun (tgt, lazy evs) -> not (Evar.equal g tgt) && Evar.Set.mem g evs) l + +let free_evars sigma l = + let cache = Evarutil.create_undefined_evars_cache () in + let map ev = + (** Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) + let evi = Evd.find sigma ev in + let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in + (ev, fevs) + in + List.map map l (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. *) let unifiable sigma g l = - CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l + let l = free_evars sigma l in + unifiable_delayed g l (** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] where [u] is composed of the unifiable goals, i.e. the goals on whose definition other goals of [l] depend, and [n] are the non-unifiable goals. *) let partition_unifiable sigma l = - CList.partition (fun g -> unifiable sigma g l) l + let fevs = free_evars sigma l in + CList.partition (fun g -> unifiable_delayed g fevs) l (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not @@ -1013,14 +1023,14 @@ let catchable_exception = function module Goal = struct - type 'a t = { + type t = { env : Environ.env; sigma : Evd.evar_map; concl : EConstr.constr ; self : Evar.t ; (* for compatibility with old-style definitions *) } - let assume (gl : 'a t) = (gl :> [ `NF ] t) + let assume (gl : t) = (gl : t) let env {env} = env let sigma {sigma} = sigma @@ -1076,7 +1086,7 @@ module Goal = struct end end - let enter_one f = + let enter_one ?(__LOC__=__LOC__) f = let open Proof in Comb.get >>= function | [goal] -> begin @@ -1087,7 +1097,8 @@ module Goal = struct let (e, info) = CErrors.push e in tclZERO ~info e end - | _ -> assert false (* unsatisfied not-exactly-one-goal precondition *) + | _ -> + CErrors.anomaly Pp.(str __LOC__ ++ str " enter_one") let goals = Pv.get >>= fun step -> diff --git a/engine/proofview.mli b/engine/proofview.mli index 59728a2fd..721ce507d 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -461,56 +461,49 @@ end module Goal : sig - (** Type of goals. - - The first parameter type is a phantom argument indicating whether the data - contained in the goal has been normalized w.r.t. the current sigma. If it - is the case, it is flagged [ `NF ]. You may still access the un-normalized - data using {!assume} if you known you do not rely on the assumption of - being normalized, at your own risk. - - *) - type 'a t + (** Type of goals. *) + type t (** Assume that you do not need the goal to be normalized. *) - val assume : 'a t -> [ `NF ] t + val assume : t -> t + [@@ocaml.deprecated "Normalization is enforced by EConstr, [assume] is not needed anymore"] (** Normalises the argument goal. *) - val normalize : 'a t -> [ `NF ] t tactic + val normalize : t -> t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) - val concl : 'a t -> constr - val hyps : 'a t -> named_context - val env : 'a t -> Environ.env - val sigma : 'a t -> Evd.evar_map - val extra : 'a t -> Evd.Store.t + val concl : t -> constr + val hyps : t -> named_context + val env : t -> Environ.env + val sigma : t -> Evd.evar_map + val extra : t -> Evd.Store.t (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic + val nf_enter : (t -> unit tactic) -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ] t -> unit tactic) -> unit tactic + val enter : (t -> unit tactic) -> unit tactic (** Like {!enter}, but assumes exactly one goal under focus, raising *) (** a fatal error otherwise. *) - val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic + val enter_one : ?__LOC__:string -> (t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. FIXME: encapsulate the level in an existential type. *) - val goals : [ `LZ ] t tactic list tactic + val goals : t tactic list tactic (** [unsolved g] is [true] if [g] is still unsolved in the current proof state. *) - val unsolved : 'a t -> bool tactic + val unsolved : t -> bool tactic (** Compatibility: avoid if possible *) - val goal : [ `NF ] t -> Evar.t + val goal : t -> Evar.t end diff --git a/engine/termops.ml b/engine/termops.ml index 07fe90222..40b3d0d8b 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -288,6 +288,7 @@ let has_no_evar sigma = with Exit -> false let pr_evd_level evd = UState.pr_uctx_level (Evd.evar_universe_context evd) +let reference_of_level evd l = UState.reference_of_level (Evd.evar_universe_context evd) l let pr_evar_universe_context ctx = let open UState in @@ -1462,6 +1463,18 @@ let prod_applist sigma c l = | _ -> anomaly (Pp.str "Not enough prod's.") in app [] c l +let prod_applist_assum sigma n c l = + let open EConstr in + let rec app n subst c l = + if Int.equal n 0 then + if l == [] then Vars.substl subst c + else anomaly (Pp.str "Not enough arguments.") + else match EConstr.kind sigma c, l with + | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (Vars.substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough prod/let's.") in + app n [] c l + (* Combinators on judgments *) let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } diff --git a/engine/termops.mli b/engine/termops.mli index c9a530076..a3559a693 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -159,8 +159,18 @@ val eta_reduce_head : Evd.evar_map -> constr -> constr (** Flattens application lists *) val collapse_appl : Evd.evar_map -> constr -> constr +(** [prod_applist] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_applist : Evd.evar_map -> constr -> constr list -> constr +(** In [prod_applist_assum n c args], [c] is supposed to have the + form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it + returns [c] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. + Note that [n] counts both let-ins and prods, while the length of [args] + only counts prods. In other words, varying [n] changes how many + trailing let-ins are expanded. *) +val prod_applist_assum : Evd.evar_map -> int -> constr -> constr list -> constr + (** Remove recursively the casts around a term i.e. [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : Evd.evar_map -> constr -> constr @@ -271,6 +281,8 @@ val is_Prop : Evd.evar_map -> constr -> bool val is_Set : Evd.evar_map -> constr -> bool val is_Type : Evd.evar_map -> constr -> bool +val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.reference + (** Combinators on judgments *) val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment diff --git a/engine/uState.ml b/engine/uState.ml index 4e30640e4..4b650c9c9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -22,6 +22,7 @@ type uinfo = { type t = { uctx_names : Universes.universe_binders * uinfo Univ.LMap.t; uctx_local : Univ.ContextSet.t; (** The local context of variables *) + uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) uctx_univ_variables : Universes.universe_opt_subst; (** The local universes that are unification variables *) uctx_univ_algebraic : Univ.LSet.t; @@ -34,6 +35,7 @@ type t = let empty = { uctx_names = UNameMap.empty, Univ.LMap.empty; uctx_local = Univ.ContextSet.empty; + uctx_seff_univs = Univ.LSet.empty; uctx_univ_variables = Univ.LMap.empty; uctx_univ_algebraic = Univ.LSet.empty; uctx_universes = UGraph.initial_universes; @@ -60,6 +62,7 @@ let union ctx ctx' = else if is_empty ctx' then ctx else let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in + let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) (Univ.ContextSet.levels ctx.uctx_local) in @@ -70,6 +73,7 @@ let union ctx ctx' = let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; + uctx_seff_univs = seff; uctx_univ_variables = Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = @@ -131,7 +135,7 @@ let of_binders b = let universe_binders ctx = fst ctx.uctx_names let instantiate_variable l b v = - try v := Univ.LMap.update l (Some b) !v + try v := Univ.LMap.set l (Some b) !v with Not_found -> assert false exception UniversesDiffer @@ -197,14 +201,18 @@ let process_universe_constraints ctx cstrs = | None -> user_err Pp.(str "Algebraic universe on the right") | Some r' -> if Univ.Level.is_small r' then - let levels = Univ.Universe.levels l in - let fold l' local = - let l = Univ.Universe.make l' in - if Univ.Level.is_small l' || is_local l' then - equalize_variables false l l' r r' local - else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) - in - Univ.LSet.fold fold levels local + if not (Univ.Universe.is_levels l) + then + raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + else + let levels = Univ.Universe.levels l in + let fold l' local = + let l = Univ.Universe.make l' in + if Univ.Level.is_small l' || is_local l' then + equalize_variables false l l' r r' local + else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + in + Univ.LSet.fold fold levels local else Univ.enforce_leq l r local end @@ -236,8 +244,8 @@ let add_constraints ctx cstrs = uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } -(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) -(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) +(* let addconstrkey = CProfile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = CProfile.profile2 addconstrkey add_constraints_context;; *) let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in @@ -263,13 +271,15 @@ let constrain_variables diff ctx = in { ctx with uctx_local = (univs, local); uctx_univ_variables = vars } - -let pr_uctx_level uctx = +let reference_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Id.print (Option.get (Univ.LMap.find l map_rev).uname) + try Libnames.Ident (Loc.tag @@ Option.get (Univ.LMap.find l map_rev).uname) with Not_found | Option.IsNone -> - Universes.pr_with_global_universes l + Universes.reference_of_level l + +let pr_uctx_level uctx l = + Libnames.pr_reference (reference_of_level uctx l) type universe_decl = (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl @@ -363,12 +373,21 @@ let check_univ_decl ~poly uctx decl = ctx let restrict ctx vars = + let vars = Univ.LSet.union vars ctx.uctx_seff_univs in let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars) (fst ctx.uctx_names) vars in let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in { ctx with uctx_local = uctx' } +let demote_seff_univs entry uctx = + let open Entries in + match entry.const_entry_universes with + | Polymorphic_const_entry _ -> uctx + | Monomorphic_const_entry (univs, _) -> + let seff = Univ.LSet.union uctx.uctx_seff_univs univs in + { uctx with uctx_seff_univs = seff } + type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -430,7 +449,7 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = - let u = Universes.new_univ_level (Global.current_dirpath ()) in + let u = Universes.new_univ_level () in let ctx' = Univ.ContextSet.add_universe u ctx in let uctx', pred = match rigid with @@ -501,7 +520,7 @@ let is_sort_variable uctx s = | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + (Univ.LSet.diff ctx def, Universes.subst_univs_constraints usubst cst) let normalize_variables uctx = let normalized_variables, undef, def, subst = @@ -550,7 +569,8 @@ let refresh_undefined_univ_variables uctx = let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; - uctx_local = ctx'; + uctx_local = ctx'; + uctx_seff_univs = uctx.uctx_seff_univs; uctx_univ_variables = vars; uctx_univ_algebraic = alg; uctx_universes = univs; uctx_initial_universes = initial } in @@ -567,7 +587,8 @@ let normalize uctx = Universes.refresh_constraints uctx.uctx_initial_universes us' in { uctx_names = uctx.uctx_names; - uctx_local = us'; + uctx_local = us'; + uctx_seff_univs = uctx.uctx_seff_univs; (* not sure about this *) uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; diff --git a/engine/uState.mli b/engine/uState.mli index 16fba41e0..6657d6047 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -53,7 +53,7 @@ val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) -val constraints : t -> Univ.constraints +val constraints : t -> Univ.Constraint.t (** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) val context : t -> Univ.UContext.t @@ -68,12 +68,12 @@ val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes (** {5 Constraints handling} *) -val add_constraints : t -> Univ.constraints -> t +val add_constraints : t -> Univ.Constraint.t -> t (** @raise UniversesDiffer when universes differ *) -val add_universe_constraints : t -> Universes.universe_constraints -> t +val add_universe_constraints : t -> Universes.Constraints.t -> t (** @raise UniversesDiffer when universes differ *) @@ -87,6 +87,8 @@ val universe_of_name : t -> Id.t -> Univ.Level.t val restrict : t -> Univ.LSet.t -> t +val demote_seff_univs : Safe_typing.private_constants Entries.definition_entry -> t -> t + type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -154,3 +156,4 @@ val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) val pr_uctx_level : t -> Univ.Level.t -> Pp.t +val reference_of_level : t -> Univ.Level.t -> Libnames.reference diff --git a/engine/universes.ml b/engine/universes.ml index 5ac1bc685..3a00f0fd1 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -14,10 +14,37 @@ open Constr open Environ open Univ open Globnames - -let pr_with_global_universes l = - try Id.print (LMap.find l (snd (Global.global_universe_names ()))) - with Not_found -> Level.pr l +open Nametab + +let reference_of_level l = + match Level.name l with + | Some (d, n as na) -> + let qid = + try Nametab.shortest_qualid_of_universe na + with Not_found -> + let name = Id.of_string_soft (string_of_int n) in + Libnames.make_qualid d name + in Libnames.Qualid (Loc.tag @@ qid) + | None -> Libnames.Ident (Loc.tag @@ Id.of_string_soft (Level.to_string l)) + +let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l) + +(** Global universe information outside the kernel, to handle + polymorphic universe names in sections that have to be discharged. *) + +let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref) + +let add_global_universe u p = + match Level.name u with + | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map + | None -> () + +let is_polymorphic l = + match Level.name l with + | Some n -> + (try Nametab.UnivIdMap.find n !universe_map + with Not_found -> false) + | None -> false (** Local universe names of polymorphic references *) @@ -53,12 +80,14 @@ let ubinder_obj : Globnames.global_reference * universe_binders -> Libobject.obj rebuild_function = (fun x -> x); } let register_universe_binders ref ubinders = - (* Add the polymorphic (section) universes *) let open Names in - let ubinders = Id.Map.fold (fun id (poly,lvl) ubinders -> - if poly then Id.Map.add id lvl ubinders - else ubinders) - (fst (Global.global_universe_names ())) ubinders + (* Add the polymorphic (section) universes *) + let ubinders = UnivIdMap.fold (fun lvl poly ubinders -> + let qid = Nametab.shortest_qualid_of_universe lvl in + let level = Level.make (fst lvl) (snd lvl) in + if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders + else ubinders) + !universe_map ubinders in if not (Id.Map.is_empty ubinders) then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders)) @@ -152,6 +181,30 @@ let enforce_eq_instances_univs strict x y c = (fun x y -> Constraints.add (Universe.make x, d, Universe.make y)) ax ay c +let enforce_univ_constraint (u,d,v) = + match d with + | Eq -> enforce_eq u v + | Le -> enforce_leq u v + | Lt -> enforce_leq (super u) v + +let subst_univs_level fn l = + try Some (fn l) + with Not_found -> None + +let subst_univs_constraint fn (u,d,v as c) cstrs = + let u' = subst_univs_level fn u in + let v' = subst_univs_level fn v in + match u', v' with + | None, None -> Constraint.add c cstrs + | Some u, None -> enforce_univ_constraint (u,d,Universe.make v) cstrs + | None, Some v -> enforce_univ_constraint (Universe.make u,d,v) cstrs + | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs + +let subst_univs_constraints subst csts = + Constraint.fold + (fun c cstrs -> subst_univs_constraint subst c cstrs) + csts Constraint.empty + let subst_univs_universe_constraint fn (u,d,v) = let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in if Universe.equal u' v' then None @@ -236,14 +289,17 @@ let eq_constr_universes_proj env m n = res, !cstrs (* Generator of levels *) -let new_univ_level, set_remote_new_univ_level = +type universe_id = DirPath.t * int + +let new_univ_id, set_remote_new_univ_id = RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) + ~build:(fun n -> Global.current_dirpath (), n) -let new_univ_level _ = new_univ_level () - (* Univ.Level.make db (new_univ_level ()) *) +let new_univ_level () = + let dp, id = new_univ_id () in + Univ.Level.make dp id -let fresh_level () = new_univ_level (Global.current_dirpath ()) +let fresh_level () = new_univ_level () (* TODO: remove *) let new_univ dp = Univ.Universe.make (new_univ_level dp) @@ -251,7 +307,7 @@ let new_Type dp = mkType (new_univ dp) let new_Type_sort dp = Type (new_univ dp) let fresh_universe_instance ctx = - let init _ = new_univ_level (Global.current_dirpath ()) in + let init _ = new_univ_level () in Instance.of_array (Array.init (AUContext.size ctx) init) let fresh_instance_from_context ctx = @@ -262,7 +318,7 @@ let fresh_instance_from_context ctx = let fresh_instance ctx = let ctx' = ref LSet.empty in let init _ = - let u = new_univ_level (Global.current_dirpath ()) in + let u = new_univ_level () in ctx' := LSet.add u !ctx'; u in let inst = Instance.of_array (Array.init (AUContext.size ctx) init) @@ -459,7 +515,7 @@ module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) let add_list_map u t map = try let l = LMap.find u map in - LMap.update u (t :: l) map + LMap.set u (t :: l) map with Not_found -> LMap.add u [t] map @@ -487,13 +543,60 @@ let choose_canonical ctx flexible algs s = let canon = LSet.choose algs in canon, (global, rigid, LSet.remove canon flexible) +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +let subst_univs_fn_constr f c = + let changed = ref false in + let fu = Univ.subst_univs_universe f in + let fi = Univ.Instance.subst_fn (level_subst_of f) in + let rec aux t = + match kind t with + | Sort (Sorts.Type u) -> + let u' = fu u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | Const (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | _ -> map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_constr subst c = + if Univ.is_empty_subst subst then c + else + let f = Univ.make_subst subst in + subst_univs_fn_constr f c + +let subst_univs_constr = + if Flags.profile then + let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in + CProfile.profile2 subst_univs_constr_key subst_univs_constr + else subst_univs_constr + let subst_univs_fn_puniverses lsubst (c, u as cu) = let u' = Instance.subst_fn lsubst u in if u' == u then cu else (c, u') let nf_evars_and_universes_opt_subst f subst = let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in - let lsubst = Univ.level_subst_of subst in + let lsubst = level_subst_of subst in let rec aux c = match kind c with | Evar (evk, args) -> @@ -552,7 +655,7 @@ let normalize_univ_variable_subst subst = let find l = Univ.LMap.find l !subst in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in + try subst := Univ.LMap.set l b !subst; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_universe_opt_subst subst = @@ -573,7 +676,7 @@ let normalize_opt_subst ctx = in !ectx type universe_opt_subst = Universe.t option universe_map - + let make_opt_subst s = fun x -> (match Univ.LMap.find x s with @@ -582,8 +685,7 @@ let make_opt_subst s = let subst_opt_univs_constr s = let f = make_opt_subst s in - Vars.subst_univs_fn_constr f - + subst_univs_fn_constr f let normalize_univ_variables ctx = let ctx = normalize_opt_subst ctx in @@ -914,8 +1016,8 @@ let normalize_context_set ctx us algs = let us = normalize_opt_subst us in (us, algs), (ctx', Constraint.union noneqs eqs) -(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) -(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) +(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *) +(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *) let is_trivial_leq (l,d,r) = Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) @@ -1001,14 +1103,3 @@ let solve_constraints_system levels level_bounds level_min = done; done; v - - -(** Operations for universe_info_ind *) - -(** Given a universe context representing constraints of an inductive - this function produces a UInfoInd.t that with the trivial subtyping relation. *) -let univ_inf_ind_from_universe_context univcst = - let freshunivs = Instance.of_array - (Array.map (fun _ -> new_univ_level ()) - (Instance.to_array (UContext.instance univcst))) - in CumulativityInfo.from_universe_context univcst freshunivs diff --git a/engine/universes.mli b/engine/universes.mli index 1401c4ee8..cb6e2ba1b 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -18,6 +18,13 @@ val is_set_minimization : unit -> bool (** Universes *) val pr_with_global_universes : Level.t -> Pp.t +val reference_of_level : Level.t -> Libnames.reference + +(** Global universe information outside the kernel, to handle + polymorphic universes in sections that have to be discharged. *) +val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit + +val is_polymorphic : Level.t -> bool (** Local universe name <-> level mapping *) @@ -40,14 +47,17 @@ val universe_binders_with_opt_names : Globnames.global_reference -> Univ.Level.t list -> univ_name_list option -> universe_binders (** The global universe counter *) -val set_remote_new_univ_level : Level.t RemoteCounter.installer +type universe_id = DirPath.t * int + +val set_remote_new_univ_id : universe_id RemoteCounter.installer (** Side-effecting functions creating new universe levels. *) -val new_univ_level : DirPath.t -> Level.t -val new_univ : DirPath.t -> Universe.t -val new_Type : DirPath.t -> types -val new_Type_sort : DirPath.t -> Sorts.t +val new_univ_id : unit -> universe_id +val new_univ_level : unit -> Level.t +val new_univ : unit -> Universe.t +val new_Type : unit -> types +val new_Type_sort : unit -> Sorts.t val new_global_univ : unit -> Universe.t in_universe_context_set val new_sort_in_family : Sorts.family -> Sorts.t @@ -64,21 +74,23 @@ type universe_constraint_type = ULe | UEq | ULub type universe_constraint = Universe.t * universe_constraint_type * Universe.t module Constraints : sig include Set.S with type elt = universe_constraint - + val pr : t -> Pp.t end type universe_constraints = Constraints.t -type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option -type 'a universe_constrained = 'a * universe_constraints -type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints +[@@ocaml.deprecated "Use Constraints.t"] + +type 'a constraint_accumulator = Constraints.t -> 'a -> 'a option +type 'a universe_constrained = 'a * Constraints.t +type 'a universe_constraint_function = 'a -> 'a -> Constraints.t -> Constraints.t val subst_univs_universe_constraints : universe_subst_fn -> - universe_constraints -> universe_constraints + Constraints.t -> Constraints.t val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function -val to_constraints : UGraph.t -> universe_constraints -> constraints +val to_constraints : UGraph.t -> Constraints.t -> Constraint.t (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of {!eq_constr_univs_infer} taking kind-of-term functions, to expose @@ -142,6 +154,11 @@ val extend_context : 'a in_universe_context_set -> ContextSet.t -> module UF : Unionfind.PartitionSig with type elt = Level.t +val level_subst_of : universe_subst_fn -> universe_level_subst_fn +val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t + +val subst_univs_constr : universe_subst -> constr -> constr + type universe_opt_subst = Universe.t option universe_map val make_opt_subst : universe_opt_subst -> universe_subst_fn @@ -204,9 +221,3 @@ val pr_universe_opt_subst : universe_opt_subst -> Pp.t val solve_constraints_system : Universe.t option array -> Universe.t array -> Universe.t array -> Universe.t array - -(** Operations for universe_info_ind *) - -(** Given a universe context representing constraints of an inductive - this function produces a UInfoInd.t that with the trivial subtyping relation. *) -val univ_inf_ind_from_universe_context : UContext.t -> CumulativityInfo.t diff --git a/engine/univops.ml b/engine/univops.ml index 9a9ae12ca..df25d8725 100644 --- a/engine/univops.ml +++ b/engine/univops.ml @@ -9,12 +9,25 @@ open Univ open Constr -let universes_of_constr c = +let universes_of_constr env c = + let open Declarations in let rec aux s c = match kind c with - | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.fold LSet.add (Instance.levels u) s - | Sort u when not (Sorts.is_small u) -> + | Const (c, u) -> + begin match (Environ.lookup_constant c env).const_universes with + | Polymorphic_const _ -> + LSet.fold LSet.add (Instance.levels u) s + | Monomorphic_const (univs, _) -> + LSet.union s univs + end + | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> + begin match (Environ.lookup_mind mind env).mind_universes with + | Cumulative_ind _ | Polymorphic_ind _ -> + LSet.fold LSet.add (Instance.levels u) s + | Monomorphic_ind (univs,_) -> + LSet.union s univs + end + | Sort u when not (Sorts.is_small u) -> let u = Sorts.univ_of_sort u in LSet.fold LSet.add (Universe.levels u) s | _ -> Constr.fold aux s c diff --git a/engine/univops.mli b/engine/univops.mli index 9af568bcb..30fcc4368 100644 --- a/engine/univops.mli +++ b/engine/univops.mli @@ -9,7 +9,8 @@ open Constr open Univ -(** Shrink a universe context to a restricted set of variables *) +(** The universes of monomorphic constants appear. *) +val universes_of_constr : Environ.env -> constr -> LSet.t -val universes_of_constr : constr -> LSet.t +(** Shrink a universe context to a restricted set of variables *) val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 9742a002d..01138702b 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -138,7 +138,6 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = <:expr< let f = $lid:f$ in fun ist v -> Ftactic.enter (fun gl -> - let gl = Proofview.Goal.assume gl in let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 0b33dab05..c52a0040b 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -45,7 +45,7 @@ let rec make_let raw e = function <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l -let make_clause (pt,_,e) = +let make_clause (pt,e) = (make_patt pt, ploc_vala None, make_let false e pt) @@ -76,7 +76,7 @@ let make_prod_item = function <:expr< Tacentries.TacNonTerm (Loc.tag ( $mlexpr_of_symbol g$ , $mlexpr_of_option mlexpr_of_ident id$ ) ) >> let mlexpr_of_clause cl = - mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl + mlexpr_of_list (fun (a,_) -> mlexpr_of_list make_prod_item a) cl (** Special treatment of constr entries *) let is_constr_gram = function @@ -88,8 +88,8 @@ let make_var = function | ExtNonTerminal (_, p) -> p | _ -> assert false -let declare_tactic loc tacname ~level classification clause = match clause with -| [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> +let declare_tactic loc tacname ~level clause = match clause with +| [(ExtTerminal name) :: rem, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in @@ -141,16 +141,14 @@ EXTEND str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; level = OPT [ "AT"; UIDENT "LEVEL"; level = INT -> level ]; - c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> let level = match level with Some i -> int_of_string i | None -> 0 in - declare_tactic loc s ~level c l ] ] + declare_tactic loc s ~level l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; - c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; - "->"; "["; e = Pcaml.expr; "]" -> (l,c,e) + "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ] ; tacargs: diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index f6f46710c..a561ea370 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -82,7 +82,7 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, ploc_vala None, - <:expr< fun loc -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) + <:expr< fun () -> ( CErrors.anomaly (Pp.str "No classification given for command " ^ s ) ) >>) let make_fun_clauses loc s l = let map c = diff --git a/ide/config_lexer.mli b/ide/config_lexer.mli new file mode 100644 index 000000000..0c0c5d1e7 --- /dev/null +++ b/ide/config_lexer.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val print_file : string -> string list Util.String.Map.t -> unit +val load_file : string -> string list Util.String.Map.t diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang index 7cfc16701..bd9cb4bfa 100644 --- a/ide/coq-ssreflect.lang +++ b/ide/coq-ssreflect.lang @@ -228,7 +228,7 @@ <keyword>Implicit\%{space}+Arguments</keyword> <keyword>(Import)|(Include)</keyword> <keyword>Require(\%{space}+((Import)|(Export)))?</keyword> - <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> + <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(OCaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword> <include> <context sub-pattern="1" style-ref="vernac-keyword"/> diff --git a/ide/coq.lang b/ide/coq.lang index 484264ece..e9eab48de 100644 --- a/ide/coq.lang +++ b/ide/coq.lang @@ -188,7 +188,7 @@ <keyword>(\%{locality}|(Reserved|Tactic)\%{space})?Notation</keyword> <keyword>\%{locality}Infix</keyword> <keyword>Declare\%{space}ML\%{space}Module</keyword> - <keyword>Extraction\%{space}Language\%{space}(Ocaml|Haskell|Scheme|JSON)</keyword> + <keyword>Extraction\%{space}Language\%{space}(OCaml|Haskell|Scheme|JSON)</keyword> </context> <context id="hint-command" style-ref="vernac-keyword"> diff --git a/ide/coq.ml b/ide/coq.ml index 42ab86dd6..34b4875af 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -9,6 +9,8 @@ open Ideutils open Preferences +let ideslave_coqtop_flags = ref None + (** * Version and date *) let get_version_date () = @@ -375,7 +377,7 @@ let spawn_handle args respawner feedback_processor = in let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: async_default :: "-ideslave" :: args) in let env = - match !Flags.ideslave_coqtop_flags with + match !ideslave_coqtop_flags with | None -> None | Some s -> let open Str in diff --git a/ide/coq.mli b/ide/coq.mli index 463dd134a..8c4727b37 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -171,3 +171,6 @@ val check_connection : string list -> unit val interrupter : (int -> unit) ref val save_all : (unit -> unit) ref + +(* Flags to be used for ideslave *) +val ideslave_coqtop_flags : string option ref diff --git a/ide/coq_commands.mli b/ide/coq_commands.mli new file mode 100644 index 000000000..53026be38 --- /dev/null +++ b/ide/coq_commands.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val tactics : string list list +val commands : string list list +val state_preserving : string list diff --git a/ide/coq_lex.mli b/ide/coq_lex.mli new file mode 100644 index 000000000..417e0a76f --- /dev/null +++ b/ide/coq_lex.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val delimit_sentences : (int -> GText.tag -> unit) -> string -> unit + +exception Unterminated diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index 8bfd937e3..fcc242e07 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -17,7 +17,13 @@ let space = [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *) -let undotted_sep = '{' | '}' | '-'+ | '+'+ | '*'+ +let number = [ '0'-'9' ]+ + +let string = "\"" _+ "\"" + +let undotted_sep = (number space* ':' space*)? '{' | '}' | '-'+ | '+'+ | '*'+ + +let vernac_control = "Fail" | "Time" | "Redirect" space+ string | "Timeout" space+ number let dot_sep = '.' (space | eof) @@ -65,7 +71,7 @@ and sentence initial stamp = parse stamp (utf8_lexeme_start lexbuf) Tags.Script.sentence; sentence true stamp lexbuf } - | undotted_sep { + | (vernac_control space+)* undotted_sep { (* Separators like { or } and bullets * - + are only active at the start of a sentence *) if initial then stamp (utf8_lexeme_start lexbuf + String.length (Lexing.lexeme lexbuf) - 1) Tags.Script.sentence; diff --git a/ide/coqide.ml b/ide/coqide.ml index 842d06859..4de9a5288 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1221,9 +1221,14 @@ let build_ui () = (* Emacs/PG mode *) NanoPG.init w notebook all_menus; - (* Reset on tab switch *) - let _ = notebook#connect#switch_page ~callback:(fun _ -> - if reset_on_tab_switch#get then Nav.restart ()) + (* On tab switch, reset, update location *) + let _ = notebook#connect#switch_page ~callback:(fun n -> + let _ = if reset_on_tab_switch#get then Nav.restart () in + try + let session = notebook#get_nth_term n in + let ins = session.buffer#get_iter_at_mark `INSERT in + Ideutils.display_location ins + with _ -> ()) in (* Vertical Separator between Scripts and Goals *) @@ -1355,7 +1360,7 @@ let read_coqide_args argv = Backtrace.record_backtrace true; filter_coqtop coqtop project_files ("-debug"::out) args |"-coqtop-flags" :: flags :: args-> - Flags.ideslave_coqtop_flags := Some flags; + Coq.ideslave_coqtop_flags := Some flags; filter_coqtop coqtop project_files out args |arg::args when out = [] && Minilib.is_prefix_of "-psn_" arg -> (* argument added by MacOS during .app launch *) diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index 8d99cc3e6..6e330c62b 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -55,6 +55,8 @@ let os_specific_init () = () (** Win32 *) +IFDEF WIN32 THEN + (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) @@ -86,7 +88,6 @@ let reroute_stdout_stderr () = (* We also provide specific kill and interrupt functions. *) -IFDEF WIN32 THEN external win32_kill : int -> unit = "win32_kill" external win32_interrupt : int -> unit = "win32_interrupt" let () = diff --git a/ide/coqide_main.mli b/ide/coqide_main.mli new file mode 100644 index 000000000..e1555ba2e --- /dev/null +++ b/ide/coqide_main.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/ide/coqide_ui.mli b/ide/coqide_ui.mli new file mode 100644 index 000000000..9f6fa5635 --- /dev/null +++ b/ide/coqide_ui.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val init : unit -> unit +val ui_m : GAction.ui_manager diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index f0575e325..7c0a7495a 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -7,11 +7,7 @@ (************************************************************************) let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) -let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0) let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) -let bn = Glib.Utf8.to_unichar "\n" ~pos:(ref 0) -let space = Glib.Utf8.to_unichar " " ~pos:(ref 0) -let tab = Glib.Utf8.to_unichar "\t" ~pos:(ref 0) (* TODO: avoid num and prime at the head of a word *) @@ -30,17 +26,6 @@ let ends_word (it:GText.iter) = not (is_word_char c) ) - -let inside_word (it:GText.iter) = - let c = it#char in - not (starts_word it) && - not (ends_word it) && - is_word_char c - - -let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it - - let find_word_start (it:GText.iter) = let rec step_to_start it = Minilib.log "Find word start"; @@ -72,100 +57,6 @@ let get_word_around (it:GText.iter) = let stop = find_word_end it in start,stop - -let rec complete_backward w (it:GText.iter) = - Minilib.log "Complete backward..."; - match it#backward_search w with - | None -> (Minilib.log "backward_search failed";None) - | Some (start,stop) -> - Minilib.log ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset)); - if starts_word start then - let ne = find_word_end stop in - if ne#compare stop = 0 - then complete_backward w start - else Some (start,stop,ne) - else complete_backward w start - - -let rec complete_forward w (it:GText.iter) = - Minilib.log "Complete forward..."; - match it#forward_search w with - | None -> None - | Some (start,stop) -> - if starts_word start then - let ne = find_word_end stop in - if ne#compare stop = 0 then - complete_forward w stop - else Some (stop,stop,ne) - else complete_forward w stop - - -let find_comment_end (start:GText.iter) = - let rec find_nested_comment (search_start:GText.iter) (search_end:GText.iter) (comment_end:GText.iter) = - match (search_start#forward_search ~limit:search_end "(*"),(comment_end#forward_search "*)") with - | None,_ -> comment_end - | Some _, None -> raise Not_found - | Some (_,next_search_start),Some (next_search_end,next_comment_end) -> - find_nested_comment next_search_start next_search_end next_comment_end - in - match start#forward_search "*)" with - | None -> raise Not_found - | Some (search_end,comment_end) -> find_nested_comment start search_end comment_end - - -let rec find_string_end (start:GText.iter) = - let dblquote = int_of_char '"' in - let rec escaped_dblquote c = - (c#char = dblquote) && not (escaped_dblquote c#backward_char) - in - match start#forward_search "\"" with - | None -> raise Not_found - | Some (stop,next_start) -> - if escaped_dblquote stop#backward_char - then find_string_end next_start - else next_start - - -let rec find_next_sentence (from:GText.iter) = - match (from#forward_search ".") with - | None -> raise Not_found - | Some (non_vernac_search_end,next_sentence) -> - match from#forward_search ~limit:non_vernac_search_end "(*",from#forward_search ~limit:non_vernac_search_end "\"" with - | None,None -> - if Glib.Unichar.isspace next_sentence#char || next_sentence#compare next_sentence#forward_char == 0 - then next_sentence else find_next_sentence next_sentence - | None,Some (_,string_search_start) -> find_next_sentence (find_string_end string_search_start) - | Some (_,comment_search_start),None -> find_next_sentence (find_comment_end comment_search_start) - | Some (_,comment_search_start),Some (_,string_search_start) -> - find_next_sentence ( - if comment_search_start#compare string_search_start < 0 - then find_comment_end comment_search_start - else find_string_end string_search_start) - - -let find_nearest_forward (cursor:GText.iter) targets = - let fold_targets acc target = - match cursor#forward_search target,acc with - | Some (t_start,_),Some nearest when (t_start#compare nearest < 0) -> Some t_start - | Some (t_start,_),None -> Some t_start - | _ -> acc - in - match List.fold_left fold_targets None targets with - | None -> raise Not_found - | Some nearest -> nearest - - -let find_nearest_backward (cursor:GText.iter) targets = - let fold_targets acc target = - match cursor#backward_search target,acc with - | Some (t_start,_),Some nearest when (t_start#compare nearest > 0) -> Some t_start - | Some (t_start,_),None -> Some t_start - | _ -> acc - in - match List.fold_left fold_targets None targets with - | None -> raise Not_found - | Some nearest -> nearest - (** On double-click on a view, select the whole word. This is a workaround for a deficient word handling in TextView. *) let fix_double_click self = diff --git a/ide/gtk_parsing.mli b/ide/gtk_parsing.mli new file mode 100644 index 000000000..b54f731b3 --- /dev/null +++ b/ide/gtk_parsing.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val fix_double_click : + < buffer : < get_iter : [> `INSERT ] -> GText.iter; + move_mark : [> `INSERT | `SEL_BOUND ] -> + where:GText.iter -> unit; + .. >; + event : < connect : + < button_press : + callback:([> `TWO_BUTTON_PRESS ] Gdk.event -> + bool) -> + 'a; + .. >; + .. >; + .. > -> + unit +val starts_word : GText.iter -> bool +val ends_word : GText.iter -> bool +val find_word_start : GText.iter -> GText.iter +val find_word_end : GText.iter -> GText.iter diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index cfc0e09a0..fe86df084 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -13,7 +13,6 @@ open Util open Pp open Printer -module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration @@ -55,7 +54,7 @@ let coqide_known_option table = List.mem table [ ["Printing";"Universes"]; ["Printing";"Unfocused"]] -let is_known_option cmd = match cmd with +let is_known_option cmd = match Vernacprop.under_control cmd with | VernacSetOption (o,BoolValue true) | VernacUnsetOption o -> coqide_known_option o | _ -> false @@ -70,9 +69,7 @@ let ide_cmd_checks ~id (loc,ast) = if is_known_option ast then warn "Set this option from the IDE menu instead"; if is_navigation_vernac ast || is_undo ast then - warn "Use IDE navigation instead"; - if is_query ast then - warn "Query commands should not be inserted in scripts" + warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) @@ -377,15 +374,8 @@ let init = match file with | None -> init_sid | Some file -> - let dir = Filename.dirname file in - let open Loadpath in let open CUnix in let doc, initial_id, _ = - let doc = get_doc () in - if not (is_in_load_paths (physical_path_of_string dir)) then begin - let pa = Pcoq.Gram.parsable (Stream.of_string (Printf.sprintf "Add LoadPath \"%s\". " dir)) in - let loc_ast = Stm.parse_sentence ~doc init_sid pa in - Stm.add false ~doc ~ontop:init_sid loc_ast - end else doc, init_sid, `NewTip in + get_doc (), init_sid, `NewTip in if Filename.check_suffix file ".v" then Stm.set_compilation_hints file; set_doc (Stm.finish ~doc); @@ -464,10 +454,13 @@ let slave_feeder fmt xml_oc msg = let msg_format = ref (fun () -> let margin = Option.default 72 (Topfmt.get_margin ()) in Xmlprotocol.Richpp margin -) + ) -let loop doc = - set_doc doc; +(* The loop ignores the command line arguments as the current model delegates + its handing to the toplevel container. *) +let loop _args ~state = + let open Vernac.State in + set_doc state.doc; init_signal_handler (); catch_break := false; let in_ch, out_ch = Spawned.get_channels () in @@ -514,10 +507,10 @@ let rec parse = function | x :: rest -> x :: parse rest | [] -> [] -let () = Coqtop.toploop_init := (fun args -> - let args = parse args in +let () = Coqtop.toploop_init := (fun coq_args extra_args -> + let args = parse extra_args in Flags.quiet := true; - CoqworkmgrApi.(init Flags.High); + CoqworkmgrApi.(init High); args) let () = Coqtop.toploop_run := loop diff --git a/ide/ide_slave.mli b/ide/ide_slave.mli new file mode 100644 index 000000000..e1555ba2e --- /dev/null +++ b/ide/ide_slave.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 0977a1890..9c5b06a0d 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -69,6 +69,12 @@ let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = let set_location = ref (function s -> failwith "not ready") +let display_location ins = + let line = ins#line + 1 in + let off = ins#line_offset + 1 in + let msg = Printf.sprintf "Line: %5d Char: %3d" line off in + !set_location msg + (** A utf8 char is either a single byte (ascii char, 0xxxxxxx) or multi-byte (with a leading byte 11xxxxxx and extra bytes 10xxxxxx) *) @@ -465,4 +471,3 @@ let browse_keyword prerr text = let u = Lazy.force url_for_keyword text in browse prerr (doc_url() ^ u) with Not_found -> prerr ("No documentation found for \""^text^"\".\n") - diff --git a/ide/ideutils.mli b/ide/ideutils.mli index f06a48aeb..99ff763e2 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -56,6 +56,7 @@ val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list -> #GText.buffer_skel -> Richpp.richpp -> unit val set_location : (string -> unit) ref +val display_location : GText.iter -> unit (* In win32, when a command-line is to be executed via cmd.exe (i.e. Sys.command, Unix.open_process, ...), it cannot contain several @@ -95,4 +96,3 @@ val io_read_all : Glib.Io.channel -> string val run_command : (string -> unit) -> (Unix.process_status -> unit) -> string -> unit - diff --git a/ide/macos_prehook.mli b/ide/macos_prehook.mli new file mode 100644 index 000000000..e1555ba2e --- /dev/null +++ b/ide/macos_prehook.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/ide/minilib.ml b/ide/minilib.ml index 2b278fac6..572222c06 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -20,7 +20,7 @@ type level = [ | `FATAL ] (** Some excerpt of Util and similar files to avoid loading the whole - module and its dependencies (and hence Compat and Camlp4) *) + module and its dependencies (and hence Compat and Camlp5) *) let debug = ref false diff --git a/ide/minilib.mli b/ide/minilib.mli index c96e59b22..4f5fbe7db 100644 --- a/ide/minilib.mli +++ b/ide/minilib.mli @@ -7,7 +7,7 @@ (***********************************************************************) (** Some excerpts of Util and similar files to avoid depending on them - and hence on Compat and Camlp4 *) + and hence on Compat and Camlp5 *) val print_list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit diff --git a/ide/nanoPG.mli b/ide/nanoPG.mli new file mode 100644 index 000000000..3ad8435b5 --- /dev/null +++ b/ide/nanoPG.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val get_documentation : unit -> string +val init : GWindow.window -> Session.session Wg_Notebook.typed_notebook -> + GAction.action_group list -> unit diff --git a/ide/session.ml b/ide/session.ml index 0a09cc9f5..8dada8ff2 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -209,10 +209,7 @@ let set_buffer_handlers let mark_set_cb it m = debug_edit_zone (); let ins = get_insert () in - let line = ins#line + 1 in - let off = ins#line_offset + 1 in - let msg = Printf.sprintf "Line: %5d Char: %3d" line off in - let () = !Ideutils.set_location msg in + let () = Ideutils.display_location ins in match GtkText.Mark.get_name m with | Some "insert" -> () | Some s -> Minilib.log (s^" moved") diff --git a/ide/utf8_convert.mli b/ide/utf8_convert.mli new file mode 100644 index 000000000..06a131a68 --- /dev/null +++ b/ide/utf8_convert.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val f : string -> string diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index a62ff2de5..cb182465a 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -84,8 +84,10 @@ class finder name (view : GText.view) = method private backward_search starti = let text = view#buffer#start_iter#get_text ~stop:starti in let regexp = self#regex in - try - let i = Str.search_backward regexp text (String.length text - 1) in + let offs = (String.length text - 1) in + if offs < 0 then None + else try + let i = Str.search_backward regexp text offs in let j = Str.match_end () in Some(view#buffer#start_iter#forward_chars (b2c text i), view#buffer#start_iter#forward_chars (b2c text j)) @@ -101,24 +103,33 @@ class finder name (view : GText.view) = with Not_found -> None method replace_all () = - let rec replace_at (iter : GText.iter) = + let rec replace_at (iter : GText.iter) ct tot = let found = self#forward_search iter in match found with - | None -> () + | None -> + let tot_str = if Int.equal ct tot then "" else " of " ^ string_of_int tot in + let occ_str = CString.plural tot "occurrence" in + let _ = Ideutils.flash_info ("Replaced " ^ string_of_int ct ^ tot_str ^ " " ^ occ_str) in + () | Some (start, stop) -> let text = iter#get_text ~stop:view#buffer#end_iter in let start_mark = view#buffer#create_mark start in let stop_mark = view#buffer#create_mark ~left_gravity:false stop in + let mod_save = view#buffer#modified in + let _ = view#buffer#set_modified false in let _ = view#buffer#delete_interactive ~start ~stop () in let iter = view#buffer#get_iter_at_mark (`MARK start_mark) in - let _ = view#buffer#insert_interactive ~iter (self#replacement text)in + let _ = view#buffer#insert_interactive ~iter (self#replacement text) in + let edited = view#buffer#modified in + let _ = view#buffer#set_modified (edited || mod_save) in let next = view#buffer#get_iter_at_mark (`MARK stop_mark) in let () = view#buffer#delete_mark (`MARK start_mark) in let () = view#buffer#delete_mark (`MARK stop_mark) in - replace_at next + let next_ct = if edited then ct + 1 else ct in + replace_at next next_ct (tot + 1) in let () = view#buffer#begin_user_action () in - let () = replace_at view#buffer#start_iter in + let () = replace_at view#buffer#start_iter 0 0 in view#buffer#end_user_action () method private set_not_found () = @@ -130,22 +141,52 @@ class finder name (view : GText.view) = method private set_normal () = find_entry#misc#modify_base [`NORMAL, `NAME "white"] - method private find_from backward (starti : GText.iter) = + method private find_from backward ?(wrapped=false) (starti : GText.iter) = let found = if backward then self#backward_search starti else self#forward_search starti in match found with | None -> if not backward && not (starti#equal view#buffer#start_iter) then - self#find_from backward view#buffer#start_iter + self#find_from backward ~wrapped:true view#buffer#start_iter else if backward && not (starti#equal view#buffer#end_iter) then - self#find_from backward view#buffer#end_iter + self#find_from backward ~wrapped:true view#buffer#end_iter else + let _ = Ideutils.flash_info "String not found" in self#set_not_found () | Some (start, stop) -> + let text = view#buffer#start_iter#get_text ~stop:view#buffer#end_iter in + let rec find_all offs accum = + if offs > String.length text then + List.rev accum + else try + let i = Str.search_forward self#regex text offs in + let j = Str.match_end () in + find_all (j + 1) (i :: accum) + with Not_found -> List.rev accum + in + let occurs = find_all 0 [] in + let num_occurs = List.length occurs in + (* assoc table of offset, occurrence index pairs *) + let occur_tbl = List.mapi (fun ndx occ -> (occ,ndx+1)) occurs in let _ = view#buffer#select_range start stop in let scroll = `MARK (view#buffer#create_mark stop) in let _ = view#scroll_to_mark ~use_align:false scroll in + let _ = + try + let occ_ndx = List.assoc start#offset occur_tbl in + let occ_str = CString.plural num_occurs "occurrence" in + let wrap_str = if wrapped then + if backward then " (wrapped backwards)" + else " (wrapped)" + else "" + in + Ideutils.flash_info + (string_of_int occ_ndx ^ " of " ^ string_of_int num_occurs ^ + " " ^ occ_str ^ wrap_str) + with Not_found -> + CErrors.anomaly (Pp.str "Occurrence of Find string not in table") + in self#set_found () method find_forward () = diff --git a/install.sh b/install.sh index f8589a3c7..4f60080a1 100755 --- a/install.sh +++ b/install.sh @@ -4,13 +4,13 @@ dest="$1" shift for f; do - bn=`basename $f` - dn=`dirname $f` + bn=$(basename "$f") + dn=$(dirname "$f") install -d "$dest/$dn" case $bn in - *.cmxs|*.py) install -m 755 $f "$dest/$dn/$bn" + *.cmxs|*.py) install -m 755 "$f" "$dest/$dn/$bn" ;; - *) install -m 644 $f "$dest/$dn/$bn" + *) install -m 644 "$f" "$dest/$dn/$bn" ;; esac done diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8b78a91b5..8aca6e333 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -67,7 +67,7 @@ let rec cases_pattern_expr_eq p1 p2 = if CAst.(p1.v == p2.v) then true else match CAst.(p1.v, p2.v) with | CPatAlias(a1,i1), CPatAlias(a2,i2) -> - Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 + Name.equal (snd i1) (snd i2) && cases_pattern_expr_eq a1 a2 | CPatCstr(c1,a1,b1), CPatCstr(c2,a2,b2) -> eq_reference c1 c2 && Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && @@ -112,10 +112,10 @@ let rec constr_expr_eq e1 e2 = eq_located Id.equal id1 id2 && List.equal cofix_expr_eq fl1 fl2 | CProdN(bl1,a1), CProdN(bl2,a2) -> - List.equal binder_expr_eq bl1 bl2 && + List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> - List.equal binder_expr_eq bl1 bl2 && + List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> Name.equal na1 na2 && @@ -173,10 +173,12 @@ let rec constr_expr_eq e1 e2 = | CDelimiters(s1,e1), CDelimiters(s2,e2) -> String.equal s1 s2 && constr_expr_eq e1 e2 + | CProj(p1,c1), CProj(p2,c2) -> + eq_reference p1 p2 && constr_expr_eq c1 c2 | (CRef _ | CFix _ | CCoFix _ | CProdN _ | CLambdaN _ | CLetIn _ | CAppExpl _ | CApp _ | CRecord _ | CCases _ | CLetTuple _ | CIf _ | CHole _ | CPatVar _ | CEvar _ | CSort _ | CCast _ | CNotation _ | CPrim _ - | CGeneralization _ | CDelimiters _), _ -> false + | CGeneralization _ | CDelimiters _ | CProj _), _ -> false and args_eq (a1,e1) (a2,e2) = Option.equal (eq_located explicitation_eq) e1 e2 && @@ -188,13 +190,9 @@ and case_expr_eq (e1, n1, p1) (e2, n2, p2) = Option.equal cases_pattern_expr_eq p1 p2 and branch_expr_eq (_, (p1, e1)) (_, (p2, e2)) = - List.equal (eq_located (List.equal cases_pattern_expr_eq)) p1 p2 && + List.equal (List.equal cases_pattern_expr_eq) p1 p2 && constr_expr_eq e1 e2 -and binder_expr_eq ((n1, _, e1) : binder_expr) (n2, _, e2) = - (** Don't care about the [binder_kind] *) - List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 - and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = (eq_located Id.equal id1 id2) && Option.equal (eq_located Id.equal) j1 j2 && @@ -224,9 +222,10 @@ and local_binder_eq l1 l2 = match l1, l2 with List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 | _ -> false -and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = +and constr_notation_substitution_eq (e1, el1, b1, bl1) (e2, el2, b2, bl2) = List.equal constr_expr_eq e1 e2 && List.equal (List.equal constr_expr_eq) el1 el2 && + List.equal cases_pattern_expr_eq b1 b2 && List.equal (List.equal local_binder_eq) bl1 bl2 and instance_eq (x1,c1) (x2,c2) = @@ -260,7 +259,6 @@ let local_binders_loc bll = match bll with (* Legacy functions *) let down_located f (_l, x) = f x -let located_fold_left f x (_l, y) = f x y let is_constructor id = try Globnames.isConstructRef @@ -271,7 +269,7 @@ let is_constructor id = let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with | CPatRecord l -> List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l - | CPatAlias (pat,id) -> f id a + | CPatAlias (pat,(loc,na)) -> Name.fold_right f na (cases_pattern_fold_names f a pat) | CPatOr (patl) -> List.fold_left (cases_pattern_fold_names f) a patl | CPatCstr (_,patl1,patl2) -> @@ -292,8 +290,7 @@ let ids_of_pattern = let ids_of_pattern_list = List.fold_left - (located_fold_left - (List.fold_left (cases_pattern_fold_names Id.Set.add))) + (List.fold_left (cases_pattern_fold_names Id.Set.add)) Id.Set.empty let ids_of_cases_indtype p = @@ -307,14 +304,6 @@ let ids_of_cases_tomatch tms = (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) tms Id.Set.empty -let rec fold_constr_expr_binders g f n acc b = function - | (nal,bk,t)::l -> - let nal = snd (List.split nal) in - let n' = List.fold_right (Name.fold_right g) nal n in - f n (fold_constr_expr_binders g f n' acc b l) t - | [] -> - f n acc b - let rec fold_local_binders g f n acc b = function | CLocalAssum (nal,bk,t)::l -> let nal = snd (List.split nal) in @@ -331,12 +320,12 @@ let rec fold_local_binders g f n acc b = function let fold_constr_expr_with_binders g f n acc = CAst.with_val (function | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) - | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l + | CProdN (l,b) | CLambdaN (l,b) -> fold_local_binders g f n acc b l | CLetIn (na,a,t,b) -> f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b | CCast (a,CastCoerce) -> f n acc a - | CNotation (_,(l,ll,bll)) -> + | CNotation (_,(l,ll,bl,bll)) -> (* The following is an approximation: we don't know exactly if an ident is binding nor to which subterms bindings apply *) let acc = List.fold_left (f n) acc (l@List.flatten ll) in @@ -367,6 +356,8 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (_,_) -> Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + | CProj (_,c) -> + f n acc c ) let free_vars_of_constr_expr c = @@ -380,12 +371,6 @@ let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Used in correctness and interface *) let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e -let map_binders f g e bl = - (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) - let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in - let (e,rbl) = List.fold_left h (e,[]) bl in - (e, List.rev rbl) - let map_local_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) let h (e,bl) = function @@ -404,15 +389,15 @@ let map_constr_expr_with_binders g f e = CAst.map (function | CApp ((p,a),l) -> CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) | CProdN (bl,b) -> - let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) + let (e,bl) = map_local_binders f g e bl in CProdN (bl,f e b) | CLambdaN (bl,b) -> - let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) + let (e,bl) = map_local_binders f g e bl in CLambdaN (bl,f e b) | CLetIn (na,a,t,b) -> CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) - | CNotation (n,(l,ll,bll)) -> + | CNotation (n,(l,ll,bl,bll)) -> (* This is an approximation because we don't know what binds what *) - CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, + CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, bl, List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) | CDelimiters (s,a) -> CDelimiters (s,f e a) @@ -448,6 +433,8 @@ let map_constr_expr_with_binders g f e = CAst.map (function let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,bl',t',d')) dl) + | CProj (p,c) -> + CProj (p, f e c) ) (* Used in constrintern *) @@ -469,9 +456,10 @@ let locs_of_notation ?loc locs ntn = | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) -let ntn_loc ?loc (args,argslist,binderslist) = +let ntn_loc ?loc (args,argslist,binders,binderslist) = locs_of_notation ?loc (List.map constr_loc (args@List.flatten argslist)@ + List.map cases_pattern_expr_loc binders@ List.map local_binders_loc binderslist) let patntn_loc ?loc (args,argslist) = @@ -525,9 +513,9 @@ let split_at_annot bl na = let mkIdentC id = CAst.make @@ CRef (Ident (Loc.tag id),None) let mkRefC r = CAst.make @@ CRef (r,None) let mkCastC (a,k) = CAst.make @@ CCast (a,k) -let mkLambdaC (idl,bk,a,b) = CAst.make @@ CLambdaN ([idl,bk,a],b) +let mkLambdaC (idl,bk,a,b) = CAst.make @@ CLambdaN ([CLocalAssum (idl,bk,a)],b) let mkLetInC (id,a,t,b) = CAst.make @@ CLetIn (id,a,t,b) -let mkProdC (idl,bk,a,b) = CAst.make @@ CProdN ([idl,bk,a],b) +let mkProdC (idl,bk,a,b) = CAst.make @@ CProdN ([CLocalAssum (idl,bk,a)],b) let mkAppC (f,l) = let l = List.map (fun x -> (x,None)) l in @@ -535,56 +523,11 @@ let mkAppC (f,l) = | CApp (g,l') -> CAst.make @@ CApp (g, l' @ l) | _ -> CAst.make @@ CApp ((None, f), l) -let add_name_in_env env n = - match snd n with - | Anonymous -> env - | Name id -> id :: env - -let fresh_var env c = - Namegen.next_ident_away (Id.of_string "pat") - (List.fold_left (fun accu id -> Id.Set.add id accu) (free_vars_of_constr_expr c) env) - -let expand_binders ?loc mkC bl c = - let rec loop ?loc bl c = - match bl with - | [] -> ([], c) - | b :: bl -> - match b with - | CLocalDef ((loc1,_) as n, oty, b) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = add_name_in_env env n in - (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) - | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = List.fold_left add_name_in_env env nl in - (env, mkC ?loc (nl,bk,t) c) - | CLocalAssum ([],_,_) -> loop ?loc bl c - | CLocalPattern (loc1, (p, ty)) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let ni = fresh_var env c in - let id = (loc1, Name ni) in - let ty = match ty with - | Some ty -> ty - | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) - in - let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in - let c = CAst.make ?loc @@ - CCases - (LetPatternStyle, None, [(e,None,None)], - [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) - in - (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) - in - let (_, c) = loop ?loc bl c in - c - let mkCProdN ?loc bll c = - let mk ?loc b c = CAst.make ?loc @@ CProdN ([b],c) in - expand_binders ?loc mk bll c + CAst.make ?loc @@ CProdN (bll,c) let mkCLambdaN ?loc bll c = - let mk ?loc b c = CAst.make ?loc @@ CLambdaN ([b],c) in - expand_binders ?loc mk bll c + CAst.make ?loc @@ CLambdaN (bll,c) let coerce_reference_to_id = function | Ident (_,id) -> id @@ -604,6 +547,49 @@ let coerce_to_name = function | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") +let mkCPatOr ?loc = function + | [pat] -> pat + | disjpat -> CAst.make ?loc @@ (CPatOr disjpat) + +let mkAppPattern ?loc p lp = + let open CAst in + make ?loc @@ (match p.v with + | CPatAtom (Some r) -> CPatCstr (r, None, lp) + | CPatCstr (r, None, l2) -> + CErrors.user_err ?loc:p.loc ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") + | CPatCstr (r, l1, l2) -> CPatCstr (r, l1 , l2@lp) + | CPatNotation (n, s, l) -> CPatNotation (n , s, l@lp) + | _ -> CErrors.user_err + ?loc:p.loc ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) + +let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function + | CRef (r,None) -> + CPatAtom (Some r) + | CHole (None,Misctypes.IntroAnonymous,None) -> + CPatAtom None + | CLetIn ((loc,Name id),b,None,{ CAst.v = CRef (Ident (_,id'),None) }) when Id.equal id id' -> + CPatAlias (coerce_to_cases_pattern_expr b, (loc,Name id)) + | CApp ((None,p),args) when List.for_all (fun (_,e) -> e=None) args -> + (mkAppPattern (coerce_to_cases_pattern_expr p) (List.map (fun (a,_) -> coerce_to_cases_pattern_expr a) args)).CAst.v + | CAppExpl ((None,r,i),args) -> + CPatCstr (r,Some (List.map coerce_to_cases_pattern_expr args),[]) + | CNotation (ntn,(c,cl,[],[])) -> + CPatNotation (ntn,(List.map coerce_to_cases_pattern_expr c, + List.map (List.map coerce_to_cases_pattern_expr) cl),[]) + | CPrim p -> + CPatPrim p + | CRecord l -> + CPatRecord (List.map (fun (r,p) -> (r,coerce_to_cases_pattern_expr p)) l) + | CDelimiters (s,p) -> + CPatDelimiters (s,coerce_to_cases_pattern_expr p) + | CCast (p,CastConv t) -> + CPatCast (coerce_to_cases_pattern_expr p,t) + | _ -> + CErrors.user_err ?loc ~hdr:"coerce_to_cases_pattern_expr" + (str "This expression should be coercible to a pattern.")) c + let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { Goptions.optdepr = false; diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 3ecb3d321..0b00b0e4d 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -54,6 +54,11 @@ val mkCLambdaN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_e val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr (** Same as [prod_constr_expr], with location *) +val mkCPatOr : ?loc:Loc.t -> cases_pattern_expr list -> cases_pattern_expr + +val mkAppPattern : ?loc:Loc.t -> cases_pattern_expr -> cases_pattern_expr list -> cases_pattern_expr +(** Apply a list of pattern arguments to a pattern *) + (** @deprecated variant of mkCLambdaN *) val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr [@@ocaml.deprecated "deprecated variant of mkCLambdaN"] @@ -73,6 +78,8 @@ val coerce_to_id : constr_expr -> Id.t located val coerce_to_name : constr_expr -> Name.t located (** Destruct terms of the form [CRef (Ident _)] or [CHole _]. *) +val coerce_to_cases_pattern_expr : constr_expr -> cases_pattern_expr + (** {6 Binder manipulation} *) val default_binder_kind : binder_kind @@ -84,7 +91,7 @@ val names_of_local_assums : local_binder_expr list -> Name.t located list (** Same as [names_of_local_binder_exprs], but does not take the [let] bindings into account. *) -(** { 6 Folds and maps } *) +(** {6 Folds and maps} *) (** Used in typeclasses *) val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e1df24f71..9e18966b6 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -257,7 +257,7 @@ let insert_pat_delimiters ?loc p = function let insert_pat_alias ?loc p = function | Anonymous -> p - | Name id -> CAst.make ?loc @@ CPatAlias (p,id) + | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(loc,na)) (**********************************************************************) (* conversion of references *) @@ -323,34 +323,35 @@ let is_zero s = Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) in aux 0 -let make_notation_gen loc ntn mknot mkprim destprim l = +let make_notation_gen loc ntn mknot mkprim destprim l bl = match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> - mknot (loc,ntn,([mknot (loc,"( _ )",l)])) + assert (bl=[]); + mknot (loc,ntn,([mknot (loc,"( _ )",l,[])]),[]) | _ -> match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], [] when is_number x -> mkprim (loc, Numeral (x,false)) | [Terminal x], [] when is_number x -> mkprim (loc, Numeral (x,true)) - | _ -> mknot (loc,ntn,l) + | _ -> mknot (loc,ntn,l,bl) -let make_notation loc ntn (terms,termlists,binders as subst) = - if not (List.is_empty termlists) || not (List.is_empty binders) then +let make_notation loc ntn (terms,termlists,binders,binderlists as subst) = + if not (List.is_empty termlists) || not (List.is_empty binderlists) then CAst.make ?loc @@ CNotation (ntn,subst) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CAst.make ?loc @@ CNotation (ntn,(l,[],[]))) + (fun (loc,ntn,l,bl) -> CAst.make ?loc @@ CNotation (ntn,(l,[],bl,[]))) (fun (loc,p) -> CAst.make ?loc @@ CPrim p) - destPrim terms + destPrim terms binders let make_pat_notation ?loc ntn (terms,termlists as subst) args = if not (List.is_empty termlists) then (CAst.make ?loc @@ CPatNotation (ntn,subst,args)) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CAst.make ?loc @@ CPatNotation (ntn,(l,[]),args)) + (fun (loc,ntn,l,_) -> CAst.make ?loc @@ CPatNotation (ntn,(l,[]),args)) (fun (loc,p) -> CAst.make ?loc @@ CPatPrim p) - destPatPrim terms + destPatPrim terms [] let mkPat ?loc qid l = CAst.make ?loc @@ (* Normally irrelevant test with v8 syntax, but let's do it anyway *) @@ -383,7 +384,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_pattern scopes vars pat - (uninterp_cases_pattern_notations pat) + (uninterp_cases_pattern_notations scopes pat) with No_match -> lift (fun ?loc -> function | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) @@ -514,7 +515,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = try if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_ind_pattern scopes vars ind args - (uninterp_ind_pattern_notations ind) + (uninterp_ind_pattern_notations scopes ind) with No_match -> let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in @@ -533,6 +534,10 @@ let occur_name na aty = | Name id -> occur_var_constr_expr id aty | Anonymous -> false +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + let is_projection nargs = function | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> (try @@ -734,7 +739,7 @@ let rec extern inctx scopes vars r = try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation scopes vars r'' (uninterp_notations r'') + extern_notation scopes vars r'' (uninterp_notations scopes r'') with No_match -> lift (fun ?loc -> function | GRef (ref,us) -> extern_global (select_stronger_impargs (implicits_of_global ref)) @@ -817,13 +822,11 @@ let rec extern inctx scopes vars r = | GProd (na,bk,t,c) -> let t = extern_typ scopes vars t in - let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in - CProdN ([(Loc.tag na)::idl,Default bk,t],c) + factorize_prod scopes (add_vname vars na) na bk t c | GLambda (na,bk,t,c) -> let t = extern_typ scopes vars t in - let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in - CLambdaN ([(Loc.tag na)::idl,Default bk,t],c) + factorize_lambda inctx scopes (add_vname vars na) na bk t c | GCases (sty,rtntypopt,tml,eqns) -> let vars' = @@ -852,7 +855,7 @@ let rec extern inctx scopes vars r = ) x)) tml in - let eqns = List.map (extern_eqn inctx scopes vars) eqns in + let eqns = List.map (extern_eqn inctx scopes vars) (factorize_eqns eqns) in CCases (sty,rtntypopt',tml,eqns) | GLetTuple (nal,(na,typopt),tm,b) -> @@ -908,6 +911,9 @@ let rec extern inctx scopes vars r = | GCast (c, c') -> CCast (sub_extern true scopes vars c, Miscops.map_cast_type (extern_typ scopes vars) c') + | GProj (p, c) -> + let pr = extern_reference ?loc Id.Set.empty (ConstRef (Projection.constant p)) in + CProj (pr, sub_extern inctx scopes vars c) ) r' and extern_typ (_,scopes) = @@ -916,24 +922,60 @@ and extern_typ (_,scopes) = and sub_extern inctx (_,scopes) = extern inctx (None,scopes) and factorize_prod scopes vars na bk aty c = - let c = extern_typ scopes vars c in - match na, c with - | Name id, { CAst.loc ; v = CProdN ([nal,Default bk',ty],c) } - when binding_kind_eq bk bk' && constr_expr_eq aty ty - && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> - nal,c - | _ -> - [],c + let store, get = set_temporary_memory () in + match na, DAst.get c with + | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> + (match get () with + | [(_,(ids,disj_of_patl,b))] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in + let b = extern_typ scopes vars b in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let binder = CLocalPattern (c.loc,(p,None)) in + (match b.v with + | CProdN (bl,b) -> CProdN (binder::bl,b) + | _ -> CProdN ([binder],b)) + | _ -> assert false) + | _, _ -> + let c = extern_typ scopes vars c in + match na, c.v with + | Name id, CProdN (CLocalAssum(nal,Default bk',ty)::bl,b) + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> + CProdN (CLocalAssum(Loc.tag na::nal,Default bk,aty)::bl,b) + | _, CProdN (bl,b) -> + CProdN (CLocalAssum([Loc.tag na],Default bk,aty)::bl,b) + | _, _ -> + CProdN ([CLocalAssum([Loc.tag na],Default bk,aty)],c) and factorize_lambda inctx scopes vars na bk aty c = - let c = sub_extern inctx scopes vars c in - match c with - | { CAst.loc; v = CLambdaN ([nal,Default bk',ty],c) } - when binding_kind_eq bk bk' && constr_expr_eq aty ty - && not (occur_name na ty) (* avoid na in ty escapes scope *) -> - nal,c - | _ -> - [],c + let store, get = set_temporary_memory () in + match na, DAst.get c with + | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> + (match get () with + | [(_,(ids,disj_of_patl,b))] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in + let b = sub_extern inctx scopes vars b in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let binder = CLocalPattern (c.loc,(p,None)) in + (match b.v with + | CLambdaN (bl,b) -> CLambdaN (binder::bl,b) + | _ -> CLambdaN ([binder],b)) + | _ -> assert false) + | _, _ -> + let c = sub_extern inctx scopes vars c in + match c.v with + | CLambdaN (CLocalAssum(nal,Default bk',ty)::bl,b) + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_name na ty) (* avoid na in ty escapes scope *) -> + CLambdaN (CLocalAssum(Loc.tag na::nal,Default bk,aty)::bl,b) + | CLambdaN (bl,b) -> + CLambdaN (CLocalAssum([Loc.tag na],Default bk,aty)::bl,b) + | _ -> + CLambdaN ([CLocalAssum([Loc.tag na],Default bk,aty)],c) and extern_local_binder scopes vars = function [] -> ([],[],[]) @@ -962,13 +1004,13 @@ and extern_local_binder scopes vars = function | GLocalPattern ((p,_),_,bk,ty) -> let ty = if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in - let p = extern_cases_pattern vars p in + let p = mkCPatOr (List.map (extern_cases_pattern vars) p) in let (assums,ids,l) = extern_local_binder scopes vars l in (assums,ids, CLocalPattern(Loc.tag @@ (p,ty)) :: l) -and extern_eqn inctx scopes vars (loc,(ids,pl,c)) = - Loc.tag ?loc ([loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], - extern inctx scopes vars c) +and extern_eqn inctx scopes vars (loc,(ids,pll,c)) = + let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in + Loc.tag ?loc (pll,extern inctx scopes vars c) and extern_notation (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match @@ -1011,7 +1053,7 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) - let terms,termlists,binders = + let terms,termlists,binders,binderlists = match_notation_constr !print_universes t pat in (* Try availability of interpretation ... *) let e = @@ -1032,11 +1074,15 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> List.map (extern true (scopt,scl@scopes') vars) c) termlists in - let bll = - List.map (fun (bl,(scopt,scl)) -> - pi3 (extern_local_binder (scopt,scl@scopes') vars bl)) + let bl = + List.map (fun (bl,(scopt,scl)) -> + mkCPatOr (List.map (extern_cases_pattern_in_scope (scopt,scl@scopes') vars) bl)) binders in - insert_delimiters (make_notation loc ntn (l,ll,bll)) key) + let bll = + List.map (fun (bl,(scopt,scl)) -> + pi3 (extern_local_binder (scopt,scl@scopes') vars bl)) + binderlists in + insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key) | SynDefRule kn -> let l = List.map (fun (c,(scopt,scl)) -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 977146b2f..694bec897 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -213,20 +213,20 @@ let expand_notation_string ntn n = (* This contracts the special case of "{ _ }" for sumbool, sumor notations *) (* Remark: expansion of squash at definition is done in metasyntax.ml *) -let contract_notation ntn (l,ll,bll) = +let contract_curly_brackets ntn (l,ll,bl,bll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | { CAst.v = CNotation ("{ _ }",([a],[],[])) } :: l -> + | { CAst.v = CNotation ("{ _ }",([a],[],[],[])) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',(l,ll,bll) + !ntn',(l,ll,bl,bll) -let contract_pat_notation ntn (l,ll) = +let contract_curly_brackets_pat ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] @@ -271,29 +271,24 @@ let error_expect_binder_notation_type ?loc id = (Id.print id ++ str " is expected to occur in binding position in the right-hand side.") -let set_var_scope ?loc id istermvar env ntnvars = +let set_var_scope ?loc id istermvar (tmp_scope,subscopes as scopes) ntnvars = try - let isonlybinding,idscopes,typ = Id.Map.find id ntnvars in - if istermvar then isonlybinding := false; + let used_as_binder,idscopes,typ = Id.Map.find id ntnvars in + if not istermvar then used_as_binder := true; let () = if istermvar then (* scopes have no effect on the interpretation of identifiers *) begin match !idscopes with - | None -> idscopes := Some (env.tmp_scope, env.scopes) - | Some (tmp, scope) -> - let s1 = make_current_scope tmp scope in - let s2 = make_current_scope env.tmp_scope env.scopes in - if not (List.equal String.equal s1 s2) then error_inconsistent_scope ?loc id s1 s2 + | None -> idscopes := Some scopes + | Some (tmp_scope', subscopes') -> + let s' = make_current_scope tmp_scope' subscopes' in + let s = make_current_scope tmp_scope subscopes in + if not (List.equal String.equal s' s) then error_inconsistent_scope ?loc id s' s end in match typ with - | NtnInternTypeBinder -> + | Notation_term.NtnInternTypeOnlyBinder -> if istermvar then error_expect_binder_notation_type ?loc id - | NtnInternTypeConstr -> - (* We need sometimes to parse idents at a constr level for - factorization and we cannot enforce this constraint: - if not istermvar then error_expect_constr_notation_type loc id *) - () - | NtnInternTypeIdent -> () + | Notation_term.NtnInternTypeAny -> () with Not_found -> (* Not in a notation *) () @@ -302,15 +297,11 @@ let set_type_scope env = {env with tmp_scope = Notation.current_type_scope_name let reset_tmp_scope env = {env with tmp_scope = None} -let rec it_mkGProd ?loc env body = - match env with - (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) - | [] -> body +let set_env_scopes env (scopt,subscopes) = + {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} -let rec it_mkGLambda ?loc env body = - match env with - (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) - | [] -> body +let mkGProd ?loc (na,bk,t) body = DAst.make ?loc @@ GProd (na, bk, t, body) +let mkGLambda ?loc (na,bk,t) body = DAst.make ?loc @@ GLambda (na, bk, t, body) (**********************************************************************) (* Utilities for binders *) @@ -378,12 +369,12 @@ let push_name_env ?(global_level=false) ntnvars implargs env = check_hidden_implicit_parameters ?loc id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; - set_var_scope ?loc id false env ntnvars; + set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding ?loc id; {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} -let intern_generalized_binder ?(global_level=false) intern_type lvar +let intern_generalized_binder ?(global_level=false) intern_type ntnvars env (loc, na) b b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = @@ -394,7 +385,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env (l, x) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x)) + (fun env (l, x) -> push_name_env ~global_level ntnvars (Variable,[],[],[])(*?*) env (l, Name x)) env fvs in let bl = List.map (fun (loc, id) -> @@ -413,9 +404,9 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name | _ -> na - in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (loc,(na,b',ty')) :: List.rev bl + in (push_name_env ~global_level ntnvars (impls_type_list ty')(*?*) env' (loc,na)), (loc,(na,b',ty')) :: List.rev bl -let intern_assumption intern lvar env nal bk ty = +let intern_assumption intern ntnvars env nal bk ty = let intern_type env = intern (set_type_scope env) in match bk with | Default k -> @@ -424,11 +415,11 @@ let intern_assumption intern lvar env nal bk ty = let impls = impls_type_list ty in List.fold_left (fun (env, bl) (loc, na as locna) -> - (push_name_env lvar impls env locna, + (push_name_env ntnvars impls env locna, (Loc.tag ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal | Generalized (b,b',t) -> - let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in + let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b b' t ty in env, b let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function @@ -443,39 +434,48 @@ let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd") -let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function +let intern_letin_binder intern ntnvars env ((loc,na as locna),def,ty) = + let term = intern env def in + let ty = Option.map (intern env) ty in + (push_name_env ntnvars (impls_term_list term) env locna, + (na,Explicit,term,ty)) + +let intern_cases_pattern_as_binder ?loc ntnvars env p = + let il,disjpat = + let (il, subst_disjpat) = !intern_cases_pattern_fwd ntnvars (None,env.scopes) p in + let substl,disjpat = List.split subst_disjpat in + if not (List.for_all (fun subst -> Id.Map.equal Id.equal subst Id.Map.empty) substl) then + user_err ?loc (str "Unsupported nested \"as\" clause."); + il,disjpat + in + let env = List.fold_right (fun (loc,id) env -> push_name_env ntnvars (Variable,[],[],[]) env (loc,Name id)) il env in + let na = alias_of_pat (List.hd disjpat) in + let ienv = Name.fold_right Id.Set.remove na env.ids in + let id = Namegen.next_name_away_with_default "pat" na ienv in + let na = (loc, Name id) in + env,((disjpat,il),id),na + +let intern_local_binder_aux ?(global_level=false) intern ntnvars (env,bl) = function | CLocalAssum(nal,bk,ty) -> - let env, bl' = intern_assumption intern lvar env nal bk ty in + let env, bl' = intern_assumption intern ntnvars env nal bk ty in let bl' = List.map (fun (loc,(na,c,t)) -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef((loc,na as locna),def,ty) -> - let term = intern env def in - let ty = Option.map (intern env) ty in - (push_name_env lvar (impls_term_list term) env locna, - (DAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) + let env,(na,bk,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in + env, (DAst.make ?loc @@ GLocalDef (na,bk,def,ty)) :: bl | CLocalPattern (loc,(p,ty)) -> let tyc = match ty with | Some ty -> ty | None -> CAst.make ?loc @@ CHole(None,Misctypes.IntroAnonymous,None) in - let il,cp = - match !intern_cases_pattern_fwd (None,env.scopes) p with - | (il, [(subst,cp)]) -> - if not (Id.Map.equal Id.equal subst Id.Map.empty) then - user_err ?loc (str "Unsupported nested \"as\" clause."); - il,cp - | _ -> assert false - in - let env = {env with ids = List.fold_right Id.Set.add il env.ids} in - let id = Namegen.next_ident_away (Id.of_string "pat") env.ids in - let na = (loc, Name id) in + let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc ntnvars env p in let bk = Default Explicit in - let _, bl' = intern_assumption intern lvar env [na] bk tyc in + let _, bl' = intern_assumption intern ntnvars env [na] bk tyc in let _,(_,bk,t) = List.hd bl' in - (env, (DAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) + (env, (DAst.make ?loc @@ GLocalPattern((disjpat,List.map snd il),id,bk,t)) :: bl) -let intern_generalization intern env lvar loc bk ak c = +let intern_generalization intern env ntnvars loc bk ak c = let c = intern {env with unb = true} c in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:env.ids c in let env', c' = @@ -504,10 +504,26 @@ let intern_generalization intern env lvar loc bk ak c = GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) in List.fold_right (fun (loc, id as lid) (env, acc) -> - let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in + let env' = push_name_env ntnvars (Variable,[],[],[]) env (loc, Name id) in (env', abs lid acc)) fvs (env,c) in c' +let rec expand_binders ?loc mk bl c = + match bl with + | [] -> c + | b :: bl -> + match DAst.get b with + | GLocalDef (n, bk, 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) + | GLocalPattern ((disjpat,ids), id, bk, ty) -> + let tm = DAst.make ?loc (GVar id) in + (* Distribute the disjunctive patterns over the shared right-hand side *) + let eqnl = List.map (fun pat -> (loc,(ids,[pat],c))) disjpat in + let c = DAst.make ?loc @@ GCases (Misctypes.LetPatternStyle, None, [tm,(Anonymous,None)], eqnl) in + expand_binders ?loc mk bl (mk ?loc (Name id,Explicit,ty) c) + (**********************************************************************) (* Syntax extensions *) @@ -515,7 +531,7 @@ let option_mem_assoc id = function | Some (id',c) -> Id.equal id id' | None -> false -let find_fresh_name renaming (terms,termlists,binders) avoid id = +let find_fresh_name renaming (terms,termlists,binders,binderlists) avoid id = let fold1 _ (c, _) accu = Id.Set.union (free_vars_of_constr_expr c) accu in let fold2 _ (l, _) accu = let fold accu c = Id.Set.union (free_vars_of_constr_expr c) accu in @@ -528,14 +544,53 @@ let find_fresh_name renaming (terms,termlists,binders) avoid id = (* TODO binders *) next_ident_away_from id (fun id -> Id.Set.mem id fvs3) -let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function - | Anonymous -> (renaming,env),Anonymous +let is_var store pat = + match DAst.get pat with + | PatVar na -> store na; true + | _ -> false + +let out_var pat = + match pat.CAst.v with + | CPatAtom (Some (Ident (_,id))) -> Name id + | CPatAtom None -> Anonymous + | _ -> assert false + +let term_of_name = function + | Name id -> DAst.make (GVar id) + | Anonymous -> + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + DAst.make (GHole (Evar_kinds.QuestionMark (st,Anonymous), Misctypes.IntroAnonymous, None)) + +let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function + | Anonymous -> (renaming,env), None, Anonymous | Name id -> + let store,get = set_temporary_memory () in try - (* Binders bound in the notation are considered first-order objects *) - let _,na as locna = coerce_to_name (fst (Id.Map.find id terms)) in - let env = push_name_env Id.Map.empty (Variable,[],[],[]) env locna in - (renaming,env), na + (* We instantiate binder name with patterns which may be parsed as terms *) + let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let pat, na = match disjpat with + | [pat] when is_var store pat -> let na = get () in None, na + | _ -> Some ((List.map snd ids,disjpat),id), snd na in + (renaming,env), pat, na + with Not_found -> + try + (* Trying to associate a pattern *) + let pat,(onlyident,scopes) = Id.Map.find id binders in + let env = set_env_scopes env scopes in + if onlyident then + (* Do not try to interpret a variable as a constructor *) + let na = out_var pat in + let env = push_name_env ntnvars (Variable,[],[],[]) env (pat.CAst.loc, na) in + (renaming,env), None, na + else + (* Interpret as a pattern *) + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let pat, na = + match disjpat with + | [pat] when is_var store pat -> let na = get () in None, na + | _ -> Some ((List.map snd ids,disjpat),id), snd na in + (renaming,env), pat, na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) @@ -543,49 +598,27 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function let renaming' = if Id.equal id id' then renaming else Id.Map.add id id' renaming in - (renaming',env), Name id' - -type letin_param_r = - | LPLetIn of Name.t * glob_constr * glob_constr option - | LPCases of (cases_pattern * Id.t list) * Id.t -(* Unused thus fatal warning *) -(* and letin_param = letin_param_r Loc.located *) - -let make_letins = - List.fold_right - (fun a c -> - match a with - | loc, LPLetIn (na,b,t) -> - DAst.make ?loc @@ GLetIn(na,b,t,c) - | loc, LPCases ((cp,il),id) -> - let tt = (DAst.make ?loc @@ GVar id, (Name id,None)) in - DAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) - -let rec subordinate_letins letins l = match l with - | bnd :: l -> - let loc = bnd.CAst.loc in - begin match DAst.get bnd with - (* binders come in reverse order; the non-let are returned in reverse order together *) - (* with the subordinated let-in in writing order *) - | GLocalDef (na,_,b,t) -> - subordinate_letins ((Loc.tag ?loc @@ LPLetIn (na,b,t))::letins) l - | GLocalAssum (na,bk,t) -> - let letins',rest = subordinate_letins [] l in - letins',((loc,(na,bk,t)),letins)::rest - | GLocalPattern (u,id,bk,t) -> - subordinate_letins ((Loc.tag ?loc @@ LPCases (u,id))::letins) - ([DAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) - end - | [] -> - letins,[] + (renaming',env), None, Name id' + +type binder_action = +| AddLetIn of Name.t Loc.located * 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 +let error_cannot_coerce_wildcard_term ?loc () = + user_err ?loc Pp.(str "Cannot turn \"_\" into a term.") + +let error_cannot_coerce_disjunctive_pattern_term ?loc () = + user_err ?loc Pp.(str "Cannot turn a disjunctive pattern into a term.") + let terms_of_binders bl = let rec term_of_pat pt = dmap_with_loc (fun ?loc -> function | PatVar (Name id) -> CRef (Ident (loc,id), None) - | PatVar (Anonymous) -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | PatVar (Anonymous) -> error_cannot_coerce_wildcard_term ?loc () | PatCstr (c,l,_) -> let r = Qualid (loc,qualid_of_path (path_of_global (ConstructRef c))) in let hole = CAst.make ?loc @@ CHole (None,Misctypes.IntroAnonymous,None) in @@ -599,40 +632,62 @@ let terms_of_binders bl = | 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 (([u],_),_,_,_) -> term_of_pat u :: extract_variables l + | GLocalPattern ((_,_),_,_,_) -> error_cannot_coerce_disjunctive_pattern_term ?loc () end | [] -> [] in extract_variables bl -let instantiate_notation_constr loc intern ntnvars subst infos c = - let (terms,termlists,binders) = subst in +let flatten_generalized_binders_if_any y l = + match List.rev l with + | [] -> assert false + | a::l -> a, List.map (fun a -> AddBinderIter (y,a)) l (* if l not empty, this means we had a generalized binder *) + +let flatten_binders bl = + let dispatch = function + | CLocalAssum (nal,bk,t) -> List.map (fun na -> CLocalAssum ([na],bk,t)) nal + | a -> [a] in + List.flatten (List.map dispatch bl) + +let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = + let (terms,termlists,binders,binderlists) = subst in (* when called while defining a notation, avoid capturing the private binders of the expression by variables bound by the notation (see #3892) *) let avoid = Id.Map.domain ntnvars in - let rec aux (terms,binderopt,terminopt as subst') (renaming,env) c = + let rec aux (terms,binderopt,iteropt as subst') (renaming,env) c = let subinfos = renaming,{env with tmp_scope = None} in match c with - | NVar id when Id.equal id ldots_var -> Option.get terminopt + | NVar id when Id.equal id ldots_var -> + let rec aux_letin env = function + | [],terminator,_ -> aux (terms,None,None) (renaming,env) terminator + | AddPreBinderIter (y,binder)::rest,terminator,iter -> + let env,binders = intern_local_binder_aux intern ntnvars (env,[]) binder in + let binder,extra = flatten_generalized_binders_if_any y binders in + aux (terms,Some (y,binder),Some (extra@rest,terminator,iter)) (renaming,env) iter + | AddBinderIter (y,binder)::rest,terminator,iter -> + aux (terms,Some (y,binder),Some (rest,terminator,iter)) (renaming,env) iter + | 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 env (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 - | NList (x,y,iter,terminator,lassoc) -> + | NList (x,y,iter,terminator,revert) -> let l,(scopt,subscopes) = (* All elements of the list are in scopes (scopt,subscopes) *) try let l,scopes = Id.Map.find x termlists in - (if lassoc then List.rev l else l),scopes + (if revert then List.rev l else l),scopes with Not_found -> try - let (bl,(scopt,subscopes)) = Id.Map.find x binders in + let (bl,(scopt,subscopes)) = Id.Map.find x binderlists in let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in - terms_of_binders (if lassoc then bl' else List.rev bl'),(None,[]) + terms_of_binders (if revert then bl' else List.rev bl'),(None,[]) with Not_found -> anomaly (Pp.str "Inconsistent substitution of recursive notation.") in - let termin = aux (terms,None,None) subinfos terminator in - let fold a t = - let nterms = Id.Map.add y (a, (scopt, subscopes)) terms in - aux (nterms,None,Some t) subinfos iter - in - List.fold_right fold l termin + let l = List.map (fun a -> AddTermIter ((Id.Map.add y (a,(scopt,subscopes)) terms))) l in + aux (terms,None,Some (l,terminator,iter)) subinfos (NVar ldots_var) | NHole (knd, naming, arg) -> let knd = match knd with | Evar_kinds.BinderType (Name id as na) -> @@ -653,47 +708,57 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let gc = intern nenv c in (gc, Some c) in - let bindings = Id.Map.map mk_env terms in + let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = + let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in + if onlyident then + let na = out_var c in term_of_name na, None + else + let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in + match disjpat with + | [pat] -> (glob_constr_of_cases_pattern pat, None) + | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.CAst.loc () + in + let terms = Id.Map.map mk_env terms in + let binders = Id.Map.map mk_env' binders in + let bindings = Id.Map.fold Id.Map.add terms binders in Some (Genintern.generic_substitute_notation bindings arg) in DAst.make ?loc @@ GHole (knd, naming, arg) - | NBinderList (x,y,iter,terminator) -> + | NBinderList (x,y,iter,terminator,revert) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (bl,(scopt,subscopes)) = Id.Map.find x binders in - let env,bl = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in - let letins,bl = subordinate_letins [] bl in - let termin = aux (terms,None,None) (renaming,env) terminator in - let res = List.fold_left (fun t binder -> - aux (terms,Some(y,binder),Some t) subinfos iter) - termin bl in - make_letins letins res + let (bl,(scopt,subscopes)) = Id.Map.find x binderlists in + (* We flatten binders so that we can interpret them at substitution time *) + let bl = flatten_binders bl in + let bl = if revert then List.rev bl else bl in + (* We isolate let-ins which do not contribute to the repeated pattern *) + let l = List.map (function | CLocalDef (na,c,t) -> AddLetIn (na,c,t) + | binder -> AddPreBinderIter (y,binder)) bl in + (* We stack the binders to iterate or let-ins to insert *) + aux (terms,None,Some (l,terminator,iter)) subinfos (NVar ldots_var) with Not_found -> anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> - let a,letins = snd (Option.get binderopt) in - let e = make_letins letins (aux subst' infos c') in - let (_loc,(na,bk,t)) = a in - DAst.make ?loc @@ GProd (na,bk,t,e) + let binder = snd (Option.get binderopt) in + expand_binders ?loc mkGProd [binder] (aux subst' (renaming,env) c') | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> - let a,letins = snd (Option.get binderopt) in - let (_loc,(na,bk,t)) = a in - DAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) + let binder = snd (Option.get binderopt) in + expand_binders ?loc mkGLambda [binder] (aux subst' (renaming,env) c') (* Two special cases to keep binder name synchronous with BinderType *) | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> - let subinfos,na = traverse_binder subst avoid subinfos na in + let subinfos,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - DAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') + DAst.make ?loc @@ GProd (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> - let subinfos,na = traverse_binder subst avoid subinfos na in + let subinfos,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - DAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') + DAst.make ?loc @@ GLambda (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) | t -> glob_constr_of_notation_constr_with_binders ?loc - (traverse_binder subst avoid) (aux subst') subinfos t - and subst_var (terms, _binderopt, _terminopt) (renaming, env) id = + (traverse_binder intern_pat ntnvars subst avoid) (aux subst') subinfos t + and subst_var (terms, binderopt, _terminopt) (renaming, env) id = (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try @@ -701,6 +766,28 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = intern {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} a with Not_found -> + try + let pat,(onlyident,scopes) = Id.Map.find id binders in + let env = set_env_scopes env scopes in + (* We deactivate impls to avoid the check on hidden parameters *) + (* and since we are only interested in the pattern as a term *) + let env = reset_hidden_inductive_implicit_test env in + if onlyident then + term_of_name (out_var pat) + else + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + match disjpat with + | [pat] -> glob_constr_of_cases_pattern pat + | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") + with Not_found -> + try + match binderopt with + | Some (x,binder) when Id.equal x id -> + let terms = terms_of_binders [binder] in + assert (List.length terms = 1); + intern env (List.hd terms) + | _ -> raise Not_found + with Not_found -> DAst.make ?loc ( try GVar (Id.Map.find id renaming) @@ -709,27 +796,80 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = GVar id) in aux (terms,None,None) infos c -let split_by_type ids = - List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> +(* Turning substitution coming from parsing and based on production + into a substitution for interpretation and based on binding/constr + distinction *) + +let cases_pattern_of_name (loc,na) = + let atom = match na with Name id -> Some (Ident (loc,id)) | Anonymous -> None in + CAst.make ?loc (CPatAtom atom) + +let split_by_type ids subst = + let bind id scl l s = + match l with + | [] -> assert false + | a::l -> l, Id.Map.add id (a,scl) s in + let (terms,termlists,binders,binderlists),subst = + List.fold_left (fun ((terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) (id,(scl,typ)) -> match typ with - | NtnTypeConstr | NtnTypeOnlyBinder -> ((x,scl)::l1,l2,l3) - | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) - | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) + | NtnTypeConstr -> + let terms,terms' = bind id scl terms terms' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr (Extend.AsIdentOrPattern | Extend.AsStrictPattern) -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id (coerce_to_cases_pattern_expr a,(false,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr Extend.AsIdent -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id (cases_pattern_of_name (coerce_to_name a),(true,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _ as x) -> + let onlyident = (x = NtnParsedAsIdent) in + let binders,binders' = bind id (onlyident,scl) binders binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeConstrList -> + let termlists,termlists' = bind id scl termlists termlists' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinderList -> + let binderlists,binderlists' = bind id scl binderlists binderlists' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) + (subst,(Id.Map.empty,Id.Map.empty,Id.Map.empty,Id.Map.empty)) ids in + assert (terms = [] && termlists = [] && binders = [] && binderlists = []); + subst + +let split_by_type_pat ?loc ids subst = + let bind id scl l s = + match l with + | [] -> assert false + | a::l -> l, Id.Map.add id (a,scl) s in + let (terms,termlists),subst = + List.fold_left (fun ((terms,termlists),(terms',termlists')) (id,(scl,typ)) -> + match typ with + | NtnTypeConstr | NtnTypeBinder _ -> + let terms,terms' = bind id scl terms terms' in + (terms,termlists),(terms',termlists') + | NtnTypeConstrList -> + let termlists,termlists' = bind id scl termlists termlists' in + (terms,termlists),(terms',termlists') + | NtnTypeBinderList -> error_invalid_pattern_notation ?loc ()) + (subst,(Id.Map.empty,Id.Map.empty)) ids in + assert (terms = [] && termlists = []); + subst let make_subst ids l = let fold accu (id, scl) a = Id.Map.add id (a, scl) accu in List.fold_left2 fold Id.Map.empty ids l -let intern_notation intern env lvar loc ntn fullargs = - let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in +let intern_notation intern env ntnvars loc ntn fullargs = + (* Adjust to parsing of { } *) + let ntn,fullargs = contract_curly_brackets ntn fullargs in + (* Recover interpretation { } *) let ((ids,c),df) = interp_notation ?loc ntn (env.tmp_scope,env.scopes) in Dumpglob.dump_notation_location (ntn_loc ?loc fullargs ntn) ntn df; - let ids,idsl,idsbl = split_by_type ids in - let terms = make_subst ids args in - let termlists = make_subst idsl argslist in - let binders = make_subst idsbl bll in - instantiate_notation_constr loc intern lvar - (terms, termlists, binders) (Id.Map.empty, env) c + (* Dispatch parsing substitution to an interpretation substitution *) + let subst = split_by_type ids fullargs in + (* Instantiate the notation *) + instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst (Id.Map.empty, env) c (**********************************************************************) (* Discriminating between bound variables and global references *) @@ -746,17 +886,17 @@ let gvar (loc, id) us = match us with user_err ?loc (str "Variable " ++ Id.print id ++ str " cannot have a universe instance") -let intern_var genv (ltacvars,ntnvars) namedctx loc id us = +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 genv.impls) then set_var_scope ?loc id true genv ntnvars; + 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, [], [], [] end else (* Is [id] registered with implicit arguments *) try - let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in + let ty,expl_impls,impls,argsc = Id.Map.find id env.impls in let expl_impls = List.map (fun id -> CAst.make ?loc @@ CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in @@ -764,7 +904,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = gvar (loc,id) us, make_implicits_list impls, argsc, expl_impls with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) - if Id.Set.mem id genv.ids || Id.Set.mem id ltacvars.ltac_vars + if Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars then gvar (loc,id) us, [], [], [] else if Id.equal id ldots_var @@ -836,8 +976,20 @@ let intern_reference ref = in Smartlocate.global_of_extended_global r +let sort_info_of_level_info (info: Misctypes.level_info) : (Libnames.reference * int) option = + match info with + | Misctypes.UAnonymous -> None + | Misctypes.UUnknown -> None + | Misctypes.UNamed id -> Some (id, 0) + +let glob_sort_of_level (level: Misctypes.glob_level) : Misctypes.glob_sort = + match level with + | Misctypes.GProp -> Misctypes.GProp + | Misctypes.GSet -> Misctypes.GSet + | Misctypes.GType info -> Misctypes.GType [sort_info_of_level_info info] + (* Is it a global reference or a syntactic definition? *) -let intern_qualid loc qid intern env lvar us args = +let intern_qualid loc qid intern env ntnvars us args = match intern_extended_global_of_qualid (loc,qid) with | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> @@ -847,10 +999,10 @@ let intern_qualid loc qid intern env lvar us args = let args1,args2 = List.chop nids args in check_no_explicitation args1; let terms = make_subst ids (List.map fst args1) in - let subst = (terms, Id.Map.empty, Id.Map.empty) in + let subst = (terms, Id.Map.empty, Id.Map.empty, Id.Map.empty) in let infos = (Id.Map.empty, env) in let projapp = match c with NRef _ -> true | _ -> false in - let c = instantiate_notation_constr loc intern lvar subst infos c in + let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in let loc = c.CAst.loc in let err () = user_err ?loc (str "Notation " ++ pr_qualid qid @@ -867,13 +1019,17 @@ let intern_qualid loc qid intern env lvar us args = DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) | _ -> err () end + | Some [s], GSort (Misctypes.GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) + | Some [_old_level], GSort _new_sort -> + (* TODO: add old_level and new_sort to the error message *) + user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) | Some _, _ -> err () in c, projapp, args2 (* Rule out section vars since these should have been found by intern_var *) -let intern_non_secvar_qualid loc qid intern env lvar us args = - let c, _, _ as r = intern_qualid loc qid intern env lvar us args in +let intern_non_secvar_qualid loc qid intern env ntnvars us args = + let c, _, _ as r = intern_qualid loc qid intern env ntnvars us args in match DAst.get c with | GRef (VarRef _, _) -> raise Not_found | _ -> r @@ -913,11 +1069,11 @@ let interp_reference vars r = (** Private internalization patterns *) type 'a raw_cases_pattern_expr_r = - | RCPatAlias of 'a raw_cases_pattern_expr * Id.t + | RCPatAlias of 'a raw_cases_pattern_expr * Name.t Loc.located | RCPatCstr of Globnames.global_reference * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list (** [RCPatCstr (loc, c, l1, l2)] represents ((@c l1) l2) *) - | RCPatAtom of Id.t option + | RCPatAtom of (Id.t Loc.located * (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 @@ -958,8 +1114,11 @@ let rec has_duplicate = function | [] -> None | x::l -> if Id.List.mem x l then (Some x) else has_duplicate l +let loc_of_multiple_pattern pl = + Loc.merge_opt (cases_pattern_expr_loc (List.hd pl)) (cases_pattern_expr_loc (List.last pl)) + let loc_of_lhs lhs = - Loc.merge_opt (fst (List.hd lhs)) (fst (List.last lhs)) + Loc.merge_opt (loc_of_multiple_pattern (List.hd lhs)) (loc_of_multiple_pattern (List.last lhs)) let check_linearity lhs ids = match has_duplicate ids with @@ -974,7 +1133,7 @@ let check_number_of_pattern loc n l = if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = - if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then + if List.exists (fun ids' -> not (List.eq_set (fun (loc,id) (_,id') -> Id.equal id id') ids ids')) idsl then user_err ?loc (str "The components of this disjunctive pattern must bind the same variables.") @@ -1040,7 +1199,7 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 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) + 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) @@ -1213,7 +1372,7 @@ let sort_fields ~complete loc fields completer = (** {6 Manage multiple aliases} *) type alias = { - alias_ids : Id.t list; + alias_ids : Id.t Loc.located list; alias_map : Id.t Id.Map.t; } @@ -1224,17 +1383,20 @@ let empty_alias = { (* [merge_aliases] returns the sets of all aliases encountered at this point and a substitution mapping extra aliases to the first one *) -let merge_aliases aliases id = - let alias_ids = aliases.alias_ids @ [id] in +let merge_aliases aliases (loc,na) = + match na with + | Anonymous -> aliases + | Name id -> + let alias_ids = aliases.alias_ids @ [loc,id] in let alias_map = match aliases.alias_ids with | [] -> aliases.alias_map - | id' :: _ -> Id.Map.add id id' aliases.alias_map + | (_,id') :: _ -> Id.Map.add id id' aliases.alias_map in { alias_ids; alias_map; } let alias_of als = match als.alias_ids with | [] -> Anonymous -| id :: _ -> Name id +| (_,id) :: _ -> Name id (** {6 Expanding notations } @@ -1252,6 +1414,8 @@ let is_zero s = let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 let product_of_cases_patterns aliases idspl = + (* each [pl] is a disjunction of patterns over common identifiers [ids] *) + (* We stepwise build a disjunction of patterns [ptaill] over common [ids'] *) List.fold_right (fun (ids,pl) (ids',ptaill) -> (ids @ ids', (* Cartesian prod of the or-pats for the nth arg and the tail args *) @@ -1262,7 +1426,7 @@ 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 x when Id.equal x y -> DAst.get t | _ -> p end + begin match id with Some ((_,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) @@ -1291,13 +1455,16 @@ let drop_notations_pattern looked_for genv = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found in (** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) - let rec rcp_of_glob x = DAst.(map (function - | GVar id -> RCPatAtom (Some id) + let rec rcp_of_glob scopes x = DAst.(map (function + | GVar id -> RCPatAtom (Some ((x.CAst.loc,id),scopes)) | GHole (_,_,_) -> RCPatAtom (None) | GRef (g,_) -> RCPatCstr (g,[],[]) | GApp (r, l) -> begin match DAst.get r with - | GRef (g,_) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | 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,[]) | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") end @@ -1377,27 +1544,25 @@ let drop_notations_pattern looked_for genv = | CPatNotation ("- _",([a],[]),[]) when is_non_zero_pat a -> let p = match a.CAst.v with CPatPrim (Numeral (p, _)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in - rcp_of_glob pat + rcp_of_glob scopes pat | CPatNotation ("( _ )",([a],[]),[]) -> in_pat top scopes a - | CPatNotation (ntn, fullargs,extrargs) -> - let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in + | CPatNotation (ntn,fullargs,extrargs) -> + let ntn,(terms,termlists) = contract_curly_brackets_pat ntn fullargs in let ((ids',c),df) = Notation.interp_notation ?loc ntn scopes in - let (ids',idsl',_) = split_by_type ids' in + let (terms,termlists) = split_by_type_pat ?loc ids' (terms,termlists) in Dumpglob.dump_notation_location (patntn_loc ?loc fullargs ntn) ntn df; - let substlist = make_subst idsl' argsl in - let subst = make_subst ids' args in - in_not top loc scopes (subst,substlist) extrargs c + in_not top loc scopes (terms,termlists) extrargs c | CPatDelimiters (key, e) -> in_pat top (None,find_delimiters_scope ?loc key::snd scopes) e | CPatPrim p -> let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (test_kind false) p scopes in - rcp_of_glob pat - | CPatAtom Some id -> + rcp_of_glob scopes pat + | CPatAtom (Some id) -> begin match drop_syndef top scopes id [] with | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) - | None -> DAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) + | None -> DAst.make ?loc @@ RCPatAtom (Some ((loc,find_pattern_variable id),scopes)) end | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) @@ -1427,7 +1592,7 @@ let drop_notations_pattern looked_for genv = let (a,(scopt,subscopes)) = Id.Map.find id subst in in_pat top (scopt,subscopes@snd scopes) a with Not_found -> - if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some id) else + if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((loc,id),scopes)) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> @@ -1440,7 +1605,7 @@ let drop_notations_pattern looked_for genv = let pl = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl in let pl = add_local_defs_and_check_length loc genv g pl args in DAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) - | NList (x,y,iter,terminator,lassoc) -> + | 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."); (try @@ -1451,7 +1616,7 @@ let drop_notations_pattern looked_for genv = let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in let u = in_not false loc scopes (nsubst, substlist) [] iter in subst_pat_iterator ldots_var t u) - (if lassoc then List.rev l else l) termin + (if revert then List.rev l else l) termin with Not_found -> anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NHole _ -> @@ -1460,9 +1625,9 @@ let drop_notations_pattern looked_for genv = | t -> error_invalid_pattern_notation ?loc () in in_pat true -let rec intern_pat genv aliases pat = +let rec intern_pat genv ntnvars aliases pat = let intern_cstr_with_all_args loc c with_letin idslpl1 pl2 = - let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in + let idslpl2 = List.map (intern_pat genv ntnvars empty_alias) pl2 in let (ids',pll) = product_of_cases_patterns aliases (idslpl1@idslpl2) in let pl' = List.map (fun (asubst,pl) -> (asubst, DAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in @@ -1471,7 +1636,7 @@ let rec intern_pat genv aliases pat = match DAst.get pat with | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in - intern_pat genv aliases' p + intern_pat genv ntnvars aliases' p | RCPatCstr (head, expl_pl, pl) -> if !asymmetric_patterns then let len = if List.is_empty expl_pl then Some (List.length pl) else None in @@ -1484,29 +1649,30 @@ let rec intern_pat genv aliases pat = 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) - | RCPatAtom (Some id) -> - let aliases = merge_aliases aliases id in - (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) + | RCPatAtom (Some ((loc,id),scopes)) -> + let aliases = merge_aliases aliases (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) -> let { alias_ids = ids; alias_map = asubst; } = aliases in (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatOr pl -> assert (not (List.is_empty pl)); - let pl' = List.map (intern_pat genv aliases) pl in + let pl' = List.map (intern_pat genv ntnvars aliases) pl in let (idsl,pl') = List.split pl' in let ids = List.hd idsl in check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') -let intern_cases_pattern genv scopes aliases pat = - intern_pat genv aliases +let intern_cases_pattern genv ntnvars scopes aliases pat = + intern_pat genv ntnvars aliases (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) genv scopes pat) let _ = intern_cases_pattern_fwd := - fun scopes p -> intern_cases_pattern (Global.env ()) scopes empty_alias p + fun ntnvars scopes p -> intern_cases_pattern (Global.env ()) ntnvars scopes empty_alias p -let intern_ind_pattern genv scopes pat = +let intern_ind_pattern genv ntnvars scopes pat = let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat @@ -1518,10 +1684,9 @@ let intern_ind_pattern genv scopes pat = let c = (function 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 idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in - let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in + let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in (with_letin, - match product_of_cases_patterns empty_alias (List.rev_append idslpl1 idslpl2) with + match product_of_cases_patterns empty_alias idslpl with | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) | _ -> error_bad_inductive_type ?loc) | x -> error_bad_inductive_type ?loc @@ -1678,24 +1843,25 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = Array.map (fun (bl,_,_) -> bl) idl, Array.map (fun (_,ty,_) -> ty) idl, Array.map (fun (_,_,bd) -> bd) idl) - | CProdN ([],c2) -> - intern_type env c2 - | CProdN ((nal,bk,ty)::bll,c2) -> - iterate_prod ?loc env bk ty (CAst.make ?loc @@ CProdN (bll, c2)) nal + | CProdN (bl,c2) -> + let (env',bl) = List.fold_left intern_local_binder (env,[]) bl in + expand_binders ?loc mkGProd bl (intern_type env' c2) | CLambdaN ([],c2) -> + (* Such a term is built sometimes: it should not change scope *) intern env c2 - | CLambdaN ((nal,bk,ty)::bll,c2) -> - iterate_lam loc (reset_tmp_scope env) bk ty (CAst.make ?loc @@ CLambdaN (bll, c2)) nal + | CLambdaN (bl,c2) -> + let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in + expand_binders ?loc mkGLambda bl (intern env' c2) | CLetIn (na,c1,t,c2) -> let inc1 = intern (reset_tmp_scope env) c1 in let int = Option.map (intern_type env) t in DAst.make ?loc @@ GLetIn (snd na, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation ("- _", ([a],[],[])) when is_non_zero a -> + | CNotation ("- _", ([a],[],[],[])) when is_non_zero a -> let p = match a.CAst.v with CPrim (Numeral (p, _)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) - | CNotation ("( _ )",([a],[],[])) -> intern env a + | CNotation ("( _ )",([a],[],[],[])) -> intern env a | CNotation (ntn,args) -> intern_notation intern env ntnvars loc ntn args | CGeneralization (b,a,c) -> @@ -1727,8 +1893,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CRef (ref,us) -> intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref - | CNotation (ntn,([],[],[])) -> - let c = intern_notation intern env ntnvars loc ntn ([],[],[]) in + | CNotation (ntn,([],[],[],[])) -> + let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in (x,impl,scopes,l), args | _ -> (intern env f,[],[],[]), args in @@ -1830,6 +1996,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | None -> None | Some gen -> let (ltacvars, ntnvars) = lvar in + (* Preventively declare notation variables in ltac as non-bindings *) + Id.Map.iter (fun x (used_as_binder,_,_) -> used_as_binder := false) ntnvars; let ntnvars = Id.Map.domain ntnvars in let extra = ltacvars.ltac_extra in let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in @@ -1866,15 +2034,22 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CCast (c1, c2) -> DAst.make ?loc @@ GCast (intern env c1, Miscops.map_cast_type (intern_type env) c2) - ) + | CProj (pr, c) -> + match intern_reference pr with + | ConstRef p -> + DAst.make ?loc @@ GProj (Projection.make p false, intern env c) + | _ -> + raise (InternalizationError (loc,IllegalMetavariable)) (* FIXME *) + ) and intern_type env = intern (set_type_scope env) and intern_local_binder env bind : intern_env * Glob_term.extended_glob_local_binder list = intern_local_binder_aux intern ntnvars env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) - and intern_multiple_pattern env n (loc,pl) = - let idsl_pll = List.map (intern_cases_pattern globalenv (None,env.scopes) empty_alias) pl in + and intern_multiple_pattern env n pl = + let idsl_pll = List.map (intern_cases_pattern globalenv ntnvars (None,env.scopes) empty_alias) pl in + let loc = loc_of_multiple_pattern pl in check_number_of_pattern loc n pl; product_of_cases_patterns empty_alias idsl_pll @@ -1891,6 +2066,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and intern_eqn n env (loc,(lhs,rhs)) = let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in (* Linearity implies the order in ids is irrelevant *) + let eqn_ids = List.map snd eqn_ids in check_linearity lhs eqn_ids; let env_ids = List.fold_right Id.Set.add eqn_ids env.ids in List.map (fun (asubst,pl) -> @@ -1912,7 +2088,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* the "in" part *) let match_td,typ = match t with | Some t -> - let with_letin,(ind,l) = intern_ind_pattern globalenv (None,env.scopes) t in + let with_letin,(ind,l) = intern_ind_pattern globalenv ntnvars (None,env.scopes) t in let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) @@ -1953,14 +2129,6 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = [], None in (tm',(snd na,typ)), extra_id, match_td - and iterate_prod ?loc env bk ty body nal = - let env, bl = intern_assumption intern ntnvars env nal bk ty in - it_mkGProd ?loc bl (intern_type env body) - - and iterate_lam loc env bk ty body nal = - let env, bl = intern_assumption intern ntnvars env nal bk ty in - it_mkGLambda ?loc bl (intern env body) - and intern_impargs c env l subscopes args = let eargs, rargs = extract_explicit_arg l args in if !parsing_explicit then @@ -2063,7 +2231,7 @@ let intern_type env c = intern_gen IsType env c let intern_pattern globalenv patt = try - intern_cases_pattern globalenv (None,[]) empty_alias patt + intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) @@ -2094,39 +2262,36 @@ let interp_open_constr env sigma c = (* Not all evars expected to be resolved and computation of implicit args *) -let interp_constr_evars_gen_impls env evdref +let interp_constr_evars_gen_impls env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - let evd, c = understand_tcc env !evdref ~expected_type c in - evdref := evd; - c, imps + let sigma, c = understand_tcc env sigma ~expected_type c in + sigma, (c, imps) -let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c +let interp_constr_evars_impls env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env sigma ~impls WithoutTypeConstraint c let interp_casted_constr_evars_impls env evdref ?(impls=empty_internalization_env) c typ = interp_constr_evars_gen_impls env evdref ~impls (OfType typ) c -let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env evdref ~impls IsType c +let interp_type_evars_impls env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env sigma ~impls IsType c (* Not all evars expected to be resolved, with side-effect on evars *) -let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c = +let interp_constr_evars_gen env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in - let evd, c = understand_tcc env !evdref ~expected_type c in - evdref := evd; - c + understand_tcc env sigma ~expected_type c let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c -let interp_casted_constr_evars env evdref ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen env evdref ~impls (OfType (EConstr.of_constr typ)) c +let interp_casted_constr_evars env sigma ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen env sigma ~impls (OfType typ) c -let interp_type_evars env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen env evdref IsType ~impls c +let interp_type_evars env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen env sigma IsType ~impls c (* Miscellaneous *) @@ -2137,7 +2302,8 @@ let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = Id.Map.map (fun typ -> (ref true, ref None, typ)) nenv.ninterp_var_type in + let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in + let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in let c = internalize (Global.env()) {ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impls} false (empty_ltac_sign, vl) a in @@ -2146,8 +2312,9 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in - let vars = Id.Map.map (fun (isonlybinding, sc, typ) -> - (!isonlybinding, out_scope !sc, typ)) vl in + let unused = match reversible with NonInjective ids -> ids | _ -> [] in + let vars = Id.Map.mapi (fun id (used_as_binder, sc, typ) -> + (!used_as_binder && not (List.mem_f Id.equal id unused), out_scope !sc)) vl in (* Returns [a] and the ordered list of variables with their scopes *) vars, a, reversible @@ -2181,17 +2348,16 @@ let intern_context global_level env impl_env binders = with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) -let interp_glob_context_evars env evdref k bl = +let interp_glob_context_evars env sigma k bl = let open EConstr in - let (env, par, _, impls) = + let env, sigma, par, _, impls = List.fold_left - (fun (env,params,n,impls) (na, k, b, t) -> + (fun (env,sigma,params,n,impls) (na, k, b, t) -> let t' = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in - let (evd,t) = understand_tcc env !evdref ~expected_type:IsType t' in - evdref := evd; + let sigma, t = understand_tcc env sigma ~expected_type:IsType t' in match b with None -> let d = LocalAssum (na,t) in @@ -2201,16 +2367,15 @@ let interp_glob_context_evars env evdref k bl = (ExplByPos (n, na), (true, true, true)) :: impls else impls in - (push_rel d env, d::params, succ n, impls) + (push_rel d env, sigma, d::params, succ n, impls) | Some b -> - let (evd,c) = understand_tcc env !evdref ~expected_type:(OfType t) b in - evdref := evd; + let sigma, c = understand_tcc env sigma ~expected_type:(OfType t) b in let d = LocalDef (na, c, t) in - (push_rel d env, d::params, n, impls)) - (env,[],k+1,[]) (List.rev bl) - in (env, par), impls + (push_rel d env, sigma, d::params, n, impls)) + (env,sigma,[],k+1,[]) (List.rev bl) + in sigma, ((env, par), impls) -let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env evdref params = +let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = let int_env,bl = intern_context global_level env impl_env params in - let x = interp_glob_context_evars env evdref shift bl in - int_env, x + let sigma, x = interp_glob_context_evars env sigma shift bl in + sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 46f96d20b..f09b17a49 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -87,7 +87,7 @@ val intern_gen : typing_constraint -> env -> constr_expr -> glob_constr val intern_pattern : env -> cases_pattern_expr -> - Id.t list * (Id.t Id.Map.t * cases_pattern) list + Id.t Loc.located list * (Id.t Id.Map.t * cases_pattern) list val intern_context : bool -> env -> internalization_env -> local_binder_expr list -> internalization_env * glob_decl list @@ -112,28 +112,28 @@ val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * EConstr.co (** Accepting unresolved evars *) -val interp_constr_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> EConstr.constr +val interp_constr_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * EConstr.constr -val interp_casted_constr_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> types -> EConstr.constr +val interp_casted_constr_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> EConstr.types -> evar_map * EConstr.constr -val interp_type_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> EConstr.types +val interp_type_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * EConstr.types (** Accepting unresolved evars and giving back the manual implicit arguments *) -val interp_constr_evars_impls : env -> evar_map ref -> +val interp_constr_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> - EConstr.constr * Impargs.manual_implicits + evar_map * (EConstr.constr * Impargs.manual_implicits) -val interp_casted_constr_evars_impls : env -> evar_map ref -> +val interp_casted_constr_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> EConstr.types -> - EConstr.constr * Impargs.manual_implicits + evar_map * (EConstr.constr * Impargs.manual_implicits) -val interp_type_evars_impls : env -> evar_map ref -> +val interp_type_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> - EConstr.types * Impargs.manual_implicits + evar_map * (EConstr.types * Impargs.manual_implicits) (** Interprets constr patterns *) @@ -158,8 +158,8 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> EConst val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> - env -> evar_map ref -> local_binder_expr list -> - internalization_env * ((env * EConstr.rel_context) * Impargs.manual_implicits) + env -> evar_map -> local_binder_expr list -> + evar_map * (internalization_env * ((env * EConstr.rel_context) * Impargs.manual_implicits)) (* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) (* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) @@ -184,8 +184,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> Globnames.global_ guaranteed to have the same domain as the input one. *) val interp_notation_constr : env -> ?impls:internalization_env -> notation_interp_env -> constr_expr -> - (bool * subscopes * notation_var_internalization_type) Id.Map.t * - notation_constr * reversibility_flag + (bool * subscopes) Id.Map.t * notation_constr * reversibility_status (** Globalization options *) val parsing_explicit : bool ref diff --git a/interp/declare.ml b/interp/declare.ml index 1b4645aff..72cdabfd2 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -31,64 +31,6 @@ type internal_flag = | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) -(** Declaration of section variables and local definitions *) - -type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry - | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) - -type variable_declaration = DirPath.t * section_variable_entry * logical_kind - -let cache_variable ((sp,_),o) = - match o with - | Inl ctx -> Global.push_context_set false ctx - | Inr (id,(p,d,mk)) -> - (* Constr raisonne sur les noms courts *) - if variable_exists id then - alreadydeclared (Id.print id ++ str " already exists"); - - let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) - | SectionLocalAssum ((ty,ctx),poly,impl) -> - let () = Global.push_named_assum ((id,ty,poly),ctx) in - let impl = if impl then Implicit else Explicit in - impl, true, poly, ctx - | SectionLocalDef (de) -> - let univs = Global.push_named_def (id,de) in - let poly = match de.const_entry_universes with - | Monomorphic_const_entry _ -> false - | Polymorphic_const_entry _ -> true - in - Explicit, de.const_entry_opaque, - poly, univs in - Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); - add_section_variable id impl poly ctx; - Dischargedhypsmap.set_discharged_hyps sp []; - add_variable_data id (p,opaq,ctx,poly,mk) - -let discharge_variable (_,o) = match o with - | Inr (id,_) -> - if variable_polymorphic id then None - else Some (Inl (variable_context id)) - | Inl _ -> Some o - -type variable_obj = - (Univ.ContextSet.t, Id.t * variable_declaration) union - -let inVariable : variable_obj -> obj = - declare_object { (default_object "VARIABLE") with - cache_function = cache_variable; - discharge_function = discharge_variable; - classify_function = (fun _ -> Dispose) } - -(* for initial declaration *) -let declare_variable id obj = - let oname = add_leaf id (inVariable (Inr (id,obj))) in - declare_var_implicits id; - Notation.declare_ref_arguments_scope (VarRef id); - Heads.declare_head (EvalVarRef id); - oname - - (** Declaration of constants and parameters *) type constant_obj = { @@ -162,7 +104,7 @@ let discharge_constant ((sp, kn), obj) = let con = Constant.make1 kn in let from = Global.lookup_constant con in let modlist = replacement_context () in - let hyps,subst,uctx = section_segment_of_constant con in + let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in let abstract = (named_of_variable_context hyps, subst, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in @@ -195,6 +137,20 @@ let update_tables c = Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope (ConstRef c) +let register_side_effect (c, role) = + let o = inConstant { + cst_decl = None; + cst_hyps = [] ; + cst_kind = IsProof Theorem; + cst_locl = false; + } in + let id = Label.to_id (pi3 (Constant.repr3 c)) in + ignore(add_leaf id o); + update_tables c; + match role with + | Safe_typing.Subproof -> () + | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] + let declare_constant_common id cst = let o = inConstant cst in let _, kn as oname = add_leaf id o in @@ -229,25 +185,11 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e (** This globally defines the side-effects in the environment. We mark exported constants as being side-effect not to redeclare them at caching time. *) - let cd, export = Global.export_private_constants ~in_section cd in - export, ConstantEntry (PureEntry, cd) + let de, export = Global.export_private_constants ~in_section de in + export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in - let iter_eff (c, role) = - let o = inConstant { - cst_decl = None; - cst_hyps = [] ; - cst_kind = IsProof Theorem; - cst_locl = false; - } in - let id = Label.to_id (pi3 (Constant.repr3 c)) in - ignore(add_leaf id o); - update_tables c; - match role with - | Safe_typing.Subproof -> () - | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] - in - let () = List.iter iter_eff export in + let () = List.iter register_side_effect export in let cst = { cst_decl = Some decl; cst_hyps = [] ; @@ -265,6 +207,78 @@ let declare_definition ?(internal=UserIndividualRequest) declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) +(** Declaration of section variables and local definitions *) + +type section_variable_entry = + | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) + +type variable_declaration = DirPath.t * section_variable_entry * logical_kind + +let cache_variable ((sp,_),o) = + match o with + | Inl ctx -> Global.push_context_set false ctx + | Inr (id,(p,d,mk)) -> + (* Constr raisonne sur les noms courts *) + if variable_exists id then + alreadydeclared (Id.print id ++ str " already exists"); + + let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) + | SectionLocalAssum ((ty,ctx),poly,impl) -> + let () = Global.push_named_assum ((id,ty,poly),ctx) in + let impl = if impl then Implicit else Explicit in + impl, true, poly, ctx + | SectionLocalDef (de) -> + let (de, eff) = Global.export_private_constants ~in_section:true de in + let () = List.iter register_side_effect eff in + (** The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) + let (body, uctx), () = Future.force de.const_entry_body in + let poly, univs = match de.const_entry_universes with + | Monomorphic_const_entry uctx -> false, uctx + | Polymorphic_const_entry uctx -> true, Univ.ContextSet.of_context uctx + in + let univs = Univ.ContextSet.union uctx univs in + (** We must declare the universe constraints before type-checking the + term. *) + let () = Global.push_context_set (not poly) univs in + let se = { + secdef_body = body; + secdef_secctx = de.const_entry_secctx; + secdef_feedback = de.const_entry_feedback; + secdef_type = de.const_entry_type; + } in + let () = Global.push_named_def (id, se) in + Explicit, de.const_entry_opaque, + poly, univs in + Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); + add_section_variable id impl poly ctx; + Dischargedhypsmap.set_discharged_hyps sp []; + add_variable_data id (p,opaq,ctx,poly,mk) + +let discharge_variable (_,o) = match o with + | Inr (id,_) -> + if variable_polymorphic id then None + else Some (Inl (variable_context id)) + | Inl _ -> Some o + +type variable_obj = + (Univ.ContextSet.t, Id.t * variable_declaration) union + +let inVariable : variable_obj -> obj = + declare_object { (default_object "VARIABLE") with + cache_function = cache_variable; + discharge_function = discharge_variable; + classify_function = (fun _ -> Dispose) } + +(* for initial declaration *) +let declare_variable id obj = + let oname = add_leaf id (inVariable (Inr (id,obj))) in + declare_var_implicits id; + Notation.declare_ref_arguments_scope (VarRef id); + Heads.declare_head (EvalVarRef id); + oname + (** Declaration of inductive blocks *) let declare_inductive_argument_scopes kn mie = @@ -319,7 +333,8 @@ let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in - let sechyps, _, _ as info = section_segment_of_mutual_inductive mind in + let info = section_segment_of_mutual_inductive mind in + let sechyps = info.Lib.abstr_ctx in Some (discharged_hyps kn sechyps, Discharge.process_inductive info repl mie) @@ -335,7 +350,7 @@ let dummy_one_inductive_entry mie = { let dummy_inductive_entry (_,m) = ([],{ mind_entry_params = []; mind_entry_record = None; - mind_entry_finite = Decl_kinds.BiFinite; + mind_entry_finite = Declarations.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; mind_entry_universes = Monomorphic_ind_entry Univ.ContextSet.empty; mind_entry_private = None; @@ -349,13 +364,8 @@ let infer_inductive_subtyping (pth, mind_ent) = | Cumulative_ind_entry cumi -> begin let env = Global.env () in - let env' = - Environ.push_context - (Univ.CumulativityInfo.univ_context cumi) env - in (* let (env'', typed_params) = Typeops.infer_local_decls env' (mind_ent.mind_entry_params) in *) - let evd = Evd.from_env env' in - (pth, Inductiveops.infer_inductive_subtyping env' evd mind_ent) + (pth, InferCumulativity.infer_inductive env mind_ent) end type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry @@ -453,28 +463,95 @@ let input_universe_context : universe_context_decl -> Libobject.obj = let declare_universe_context poly ctx = Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) -(* Discharged or not *) -type universe_decl = polymorphic * Universes.universe_binders - -let cache_universes (p, l) = - let glob = Global.global_universe_names () in - let glob', ctx = - Id.Map.fold (fun id lev ((idl,lid),ctx) -> - ((Id.Map.add id (p, lev) idl, - Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) - l (glob, Univ.ContextSet.empty) +(** Global universes are not substitutive objects but global objects + bound at the *library* or *module* level. The polymorphic flag is + used to distinguish universes declared in polymorphic sections, which + are discharged and do not remain in scope. *) + +type universe_source = + | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) + | QualifiedUniv of Id.t (* global universe introduced by some global value *) + | UnqualifiedUniv (* other global universe *) + +type universe_decl = universe_source * Nametab.universe_id + +let add_universe src (dp, i) = + let level = Univ.Level.make dp i in + let optpoly = match src with + | BoundUniv -> Some true + | UnqualifiedUniv -> Some false + | QualifiedUniv _ -> None in - cache_universe_context (p, ctx); - Global.set_global_universe_names glob' + Option.iter (fun poly -> + let ctx = Univ.ContextSet.add_universe level Univ.ContextSet.empty in + Global.push_context_set poly ctx; + Universes.add_global_universe level poly; + if poly then Lib.add_section_context ctx) + optpoly -let input_universes : universe_decl -> Libobject.obj = +let check_exists sp = + let depth = sections_depth () in + let sp = Libnames.make_path (pop_dirpath_n depth (dirpath sp)) (basename sp) in + if Nametab.exists_universe sp then + alreadydeclared (str "Universe " ++ Id.print (basename sp) ++ str " already exists") + else () + +let qualify_univ src (sp,i as orig) = + match src with + | BoundUniv | UnqualifiedUniv -> orig + | QualifiedUniv l -> + let sp0, id = Libnames.repr_path sp in + let sp0 = DirPath.repr sp0 in + Libnames.make_path (DirPath.make (l::sp0)) id, i+1 + +let cache_universe ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,1) in + let () = check_exists sp in + let () = Nametab.push_universe (Nametab.Until i) sp id in + add_universe src id + +let load_universe i ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,i) in + let () = Nametab.push_universe (Nametab.Until i) sp id in + add_universe src id + +let open_universe i ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,i) in + let () = Nametab.push_universe (Nametab.Exactly i) sp id in + () + +let discharge_universe = function + | _, (BoundUniv, _) -> None + | _, ((QualifiedUniv _ | UnqualifiedUniv), _ as x) -> Some x + +let input_universe : universe_decl -> Libobject.obj = declare_object { (default_object "Global universe name state") with - cache_function = (fun (na, pi) -> cache_universes pi); - load_function = (fun _ (_, pi) -> cache_universes pi); - discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); - classify_function = (fun a -> Keep a) } + cache_function = cache_universe; + load_function = load_universe; + open_function = open_universe; + discharge_function = discharge_universe; + subst_function = (fun (subst, a) -> (** Actually the name is generated once and for all. *) a); + classify_function = (fun a -> Substitute a) } + +let declare_univ_binders gr pl = + if Global.is_polymorphic gr then + Universes.register_universe_binders gr pl + else + let l = match gr with + | ConstRef c -> Label.to_id @@ Constant.label c + | IndRef (c, _) -> Label.to_id @@ MutInd.label c + | VarRef id -> id + | ConstructRef _ -> + anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on an constructor reference") + in + Id.Map.iter (fun id lvl -> + match Univ.Level.name lvl with + | None -> () + | Some na -> + ignore (Lib.add_leaf id (input_universe (QualifiedUniv l, na)))) + pl let do_universe poly l = let in_section = Lib.sections_are_opened () in @@ -484,13 +561,16 @@ let do_universe poly l = (str"Cannot declare polymorphic universes outside sections") in let l = - List.fold_left (fun acc (l, id) -> - let lev = Universes.new_univ_level (Global.current_dirpath ()) in - Id.Map.add id lev acc) Id.Map.empty l + List.map (fun (l, id) -> + let lev = Universes.new_univ_id () in + (id, lev)) l in - Lib.add_anonymous_leaf (input_universes (poly, l)) + let src = if poly then BoundUniv else UnqualifiedUniv in + List.iter (fun (id,lev) -> + ignore(Lib.add_leaf id (input_universe (src, lev)))) + l -type constraint_decl = polymorphic * Univ.constraints +type constraint_decl = polymorphic * Univ.Constraint.t let cache_constraints (na, (p, c)) = let ctx = @@ -510,20 +590,15 @@ let input_constraints : constraint_decl -> Libobject.obj = discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } +let loc_of_glob_level = function + | Misctypes.GType (Misctypes.UNamed n) -> Libnames.loc_of_reference n + | _ -> None + let do_constraint poly l = - let open Misctypes in let u_of_id x = - match x with - | GProp -> Loc.tag (false, Univ.Level.prop) - | GSet -> Loc.tag (false, Univ.Level.set) - | GType None | GType (Some (_, Anonymous)) -> - user_err ~hdr:"Constraint" - (str "Cannot declare constraints on anonymous universes") - | GType (Some (loc, Name id)) -> - let names, _ = Global.global_universe_names () in - try loc, Id.Map.find id names - with Not_found -> - user_err ?loc ~hdr:"Constraint" (str "Undeclared universe " ++ Id.print id) + let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in + let loc = loc_of_glob_level x in + loc, Universes.is_polymorphic level, level in let in_section = Lib.sections_are_opened () in let () = @@ -541,7 +616,7 @@ let do_constraint poly l = ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in + let ploc, p, lu = u_of_id l and rloc, p', ru = u_of_id r in check_poly ?loc:ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l diff --git a/interp/declare.mli b/interp/declare.mli index d50d37368..f368d164e 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -80,13 +80,11 @@ val recursive_message : bool (** true = fixpoint *) -> val exists_name : Id.t -> bool - - (** Global universe contexts, names and constraints *) +val declare_univ_binders : Globnames.global_reference -> Universes.universe_binders -> unit val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> - (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> - unit +val do_constraint : polymorphic -> (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> + unit diff --git a/interp/discharge.ml b/interp/discharge.ml index 5b4b5f67b..710f88c3f 100644 --- a/interp/discharge.ml +++ b/interp/discharge.ml @@ -78,8 +78,8 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx, Type ar.template_level), true -let process_inductive (section_decls,_,_ as info) modlist mib = - let section_decls = Lib.named_of_variable_context section_decls in +let process_inductive info modlist mib = + let section_decls = Lib.named_of_variable_context info.Lib.abstr_ctx in let nparamdecls = Context.Rel.length mib.mind_params_ctxt in let subst, ind_univs = match mib.mind_universes with @@ -92,7 +92,7 @@ let process_inductive (section_decls,_,_ as info) modlist mib = let auctx = Univ.ACumulativityInfo.univ_context cumi in let subst, auctx = Lib.discharge_abstract_universe_context info auctx in let auctx = Univ.AUContext.repr auctx in - subst, Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context auctx) + subst, Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context auctx) in let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in let inds = diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 13ed65056..d7962e29a 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -68,11 +68,12 @@ let pause () = previous_state := !glob_output; glob_output := NoGlob let continue () = glob_output := !previous_state open Decl_kinds +open Declarations let type_of_logical_kind = function | IsDefinition def -> (match def with - | Definition -> "def" + | Definition | Let -> "def" | Coercion -> "coe" | SubClass -> "subclass" | CanonicalStructure -> "canonstruc" @@ -111,14 +112,12 @@ let type_of_global_ref gr = | Globnames.IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in if mib.Declarations.mind_record <> None then - let open Decl_kinds in begin match mib.Declarations.mind_finite with | Finite -> "indrec" | BiFinite -> "rec" | CoFinite -> "corec" end else - let open Decl_kinds in begin match mib.Declarations.mind_finite with | Finite -> "ind" | BiFinite -> "variant" diff --git a/interp/impargs.ml b/interp/impargs.ml index 3105214d5..ed1cd5276 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -548,7 +548,7 @@ let discharge_implicits (_,(req,l)) = | ImplConstant (con,flags) -> (try let con' = pop_con con in - let vars,_,_ = section_segment_of_constant con in + let vars = variable_section_segment_of_reference (ConstRef con) in let extra_impls = impls_of_context vars in let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in let l' = [ConstRef con',newimpls] in diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 519f2480b..a838d7106 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -93,8 +93,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = in let rec aux bdvars l c = match CAst.(c.v) with | CRef (Ident (loc,id),_) -> found loc id bdvars l - | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [])) when not (Id.Set.mem id bdvars) -> - Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c + | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [], [])) when not (Id.Set.mem id bdvars) -> + Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index f7c36c4e5..bfe73160b 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -38,10 +38,10 @@ val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> + Id.Set.t -> global_reference option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t val implicit_application : Id.Set.t -> ?allow_partial:bool -> - (Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> + (Id.Set.t -> global_reference option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t) -> constr_expr -> constr_expr * Id.Set.t diff --git a/interp/modintern.ml b/interp/modintern.ml index 3eb91d8cd..e631b3ea4 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -59,33 +59,42 @@ let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> - WithMod (fqid,lookup_module qid) + WithMod (fqid,lookup_module qid), Univ.ContextSet.empty | CWith_Definition ((_,fqid),c) -> let c, ectx = interp_constr env (Evd.from_env env) c in - let ctx = UState.context ectx in - WithDef (fqid,(c,ctx)) + if Flags.is_universe_polymorphism () then + let ctx = UState.context ectx in + let inst, ctx = Univ.abstract_universes ctx in + let c = Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in + WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty + else + WithDef (fqid,(c, None)), UState.context_set ectx let loc_of_module l = l.CAst.loc (* Invariant : the returned kind is never ModAny, and it is equal to the input kind when this one isn't ModAny. *) -let rec interp_module_ast env kind m = match m.CAst.v with +let rec interp_module_ast env kind m cst = match m.CAst.v with | CMident qid -> let (mp,kind) = lookup_module_or_modtype kind (m.CAst.loc,qid) in - (MEident mp, kind) + (MEident mp, kind, cst) | CMapply (me1,me2) -> - let me1',kind1 = interp_module_ast env kind me1 in - let me2',kind2 = interp_module_ast env ModAny me2 in + let me1',kind1, cst = interp_module_ast env kind me1 cst in + let me2',kind2, cst = interp_module_ast env ModAny me2 cst in let mp2 = match me2' with | MEident mp -> mp | _ -> error_application_to_not_path (loc_of_module me2) me2' in if kind2 == ModType then error_application_to_module_type (loc_of_module me2); - (MEapply (me1',mp2), kind1) + (MEapply (me1',mp2), kind1, cst) | CMwith (me,decl) -> - let me,kind = interp_module_ast env kind me in + let me,kind,cst = interp_module_ast env kind me cst in if kind == Module then error_incorrect_with_in_module m.CAst.loc; - let decl = transl_with_decl env decl in - (MEwith(me,decl), kind) + let decl, cst' = transl_with_decl env decl in + let cst = Univ.ContextSet.union cst cst' in + (MEwith(me,decl), kind, cst) + +let interp_module_ast env kind m = + interp_module_ast env kind m Univ.ContextSet.empty diff --git a/interp/modintern.mli b/interp/modintern.mli index a21b6e231..8d6100667 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -28,4 +28,4 @@ exception ModuleInternalizationError of module_internalization_error isn't ModAny. *) val interp_module_ast : - env -> module_kind -> module_ast -> module_struct_entry * module_kind + env -> module_kind -> module_ast -> module_struct_entry * module_kind * Univ.ContextSet.t diff --git a/interp/notation.ml b/interp/notation.ml index f36294f73..ea7ef21b1 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -82,18 +82,35 @@ let parenRelation_eq t1 t2 = match t1, t2 with | Prec l1, Prec l2 -> Int.equal l1 l2 | _ -> false -let notation_var_internalization_type_eq v1 v2 = match v1, v2 with -| NtnInternTypeConstr, NtnInternTypeConstr -> true -| NtnInternTypeBinder, NtnInternTypeBinder -> true -| NtnInternTypeIdent, NtnInternTypeIdent -> true -| (NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent), _ -> false - -let level_eq (l1, t1, u1) (l2, t2, u2) = - let tolerability_eq (i1, r1) (i2, r2) = - Int.equal i1 i2 && parenRelation_eq r1 r2 - in +open Extend + +let production_level_eq l1 l2 = true (* (l1 = l2) *) + +let production_position_eq pp1 pp2 = true (* pp1 = pp2 *) (* match pp1, pp2 with +| NextLevel, NextLevel -> true +| NumLevel n1, NumLevel n2 -> Int.equal n1 n2 +| (NextLevel | NumLevel _), _ -> false *) + +let constr_entry_key_eq eq v1 v2 = match v1, v2 with +| ETName, ETName -> true +| ETReference, ETReference -> true +| ETBigint, ETBigint -> true +| ETBinder b1, ETBinder b2 -> b1 == b2 +| ETConstr lev1, ETConstr lev2 -> eq lev1 lev2 +| ETConstrAsBinder (bk1,lev1), ETConstrAsBinder (bk2,lev2) -> eq lev1 lev2 && bk1 = bk2 +| ETPattern (b1,n1), ETPattern (b2,n2) -> b1 = b2 && Option.equal Int.equal n1 n2 +| ETOther (s1,s1'), ETOther (s2,s2') -> String.equal s1 s2 && String.equal s1' s2' +| (ETName | ETReference | ETBigint | ETBinder _ | ETConstr _ | ETPattern _ | ETOther _ | ETConstrAsBinder _), _ -> false + +let level_eq_gen strict (l1, t1, u1) (l2, t2, u2) = + let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in + let prod_eq (l1,pp1) (l2,pp2) = + if strict then production_level_eq l1 l2 && production_position_eq pp1 pp2 + else production_level_eq l1 l2 in Int.equal l1 l2 && List.equal tolerability_eq t1 t2 - && List.equal notation_var_internalization_type_eq u1 u2 + && List.equal (constr_entry_key_eq prod_eq) u1 u2 + +let level_eq = level_eq_gen false let declare_scope scope = try let _ = String.Map.find scope !scope_map in () @@ -292,7 +309,7 @@ let cases_pattern_key c = match DAst.get c with let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_) -> + | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) | NRef ref -> RefKey(canonical_gr ref), None | NApp (_,args) -> Oth, Some (List.length args) @@ -526,15 +543,38 @@ let interp_notation ?loc ntn local_scopes = user_err ?loc (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") -let uninterp_notations c = - List.map_append (fun key -> keymap_find key !notations_key_table) - (glob_constr_keys c) - -let uninterp_cases_pattern_notations c = - keymap_find (cases_pattern_key c) !notations_key_table - -let uninterp_ind_pattern_notations ind = - keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table +let sort_notations scopes l = + let extract_scope l = function + | Scope sc -> List.partitioni (fun _i x -> + match x with + | NotationRule (Some sc',_),_,_ -> String.equal sc sc' + | _ -> false) l + | SingleNotation ntn -> List.partitioni (fun _i x -> + match x with + | NotationRule (None,ntn'),_,_ -> String.equal ntn ntn' + | _ -> false) l in + let rec aux l scopes = + if l == [] then [] (* shortcut *) else + match scopes with + | sc :: scopes -> let ntn_in_sc,l = extract_scope l sc in ntn_in_sc @ aux l scopes + | [] -> l in + aux l scopes + +let uninterp_notations scopes c = + let scopes = make_current_scopes scopes in + let keys = glob_constr_keys c in + let maps = List.map_append (fun key -> keymap_find key !notations_key_table) keys in + sort_notations scopes maps + +let uninterp_cases_pattern_notations scopes c = + let scopes = make_current_scopes scopes in + let maps = keymap_find (cases_pattern_key c) !notations_key_table in + sort_notations scopes maps + +let uninterp_ind_pattern_notations scopes ind = + let scopes = make_current_scopes scopes in + let maps = keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table in + sort_notations scopes maps let availability_of_notation (ntn_scope,ntn) scopes = let f scope = @@ -586,12 +626,18 @@ let availability_of_prim_token n printer_scope local_scopes = let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 +let notation_binder_source_eq s1 s2 = match s1, s2 with +| NtnParsedAsIdent, NtnParsedAsIdent -> true +| NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 +| NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 +| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _), _ -> false + let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeConstr, NtnTypeConstr -> true -| NtnTypeOnlyBinder, NtnTypeOnlyBinder -> true +| NtnTypeBinder s1, NtnTypeBinder s2 -> notation_binder_source_eq s1 s2 | NtnTypeConstrList, NtnTypeConstrList -> true | NtnTypeBinderList, NtnTypeBinderList -> true -| (NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList), _ -> false +| (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false let var_attributes_eq (_, (sc1, tp1)) (_, (sc2, tp2)) = pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && @@ -903,8 +949,63 @@ let factorize_entries = function (ntn,[c],[]) l in (ntn,l_of_ntn)::rest +type symbol_token = WhiteSpace of int | String of string + +let split_notation_string str = + let push_token beg i l = + if Int.equal beg i then l else + let s = String.sub str beg (i - beg) in + String s :: l + in + let push_whitespace beg i l = + if Int.equal beg i then l else WhiteSpace (i-beg) :: l + in + let rec loop beg i = + if i < String.length str then + if str.[i] == ' ' then + push_token beg i (loop_on_whitespace (i+1) (i+1)) + else + loop beg (i+1) + else + push_token beg i [] + and loop_on_whitespace beg i = + if i < String.length str then + if str.[i] != ' ' then + push_whitespace beg i (loop i (i+1)) + else + loop_on_whitespace beg (i+1) + else + push_whitespace beg i [] + in + loop 0 0 + +let rec raw_analyze_notation_tokens = function + | [] -> [] + | String ".." :: sl -> NonTerminal Notation_ops.ldots_var :: raw_analyze_notation_tokens sl + | String "_" :: _ -> user_err Pp.(str "_ must be quoted.") + | String x :: sl when Id.is_valid x -> + NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl + | String s :: sl -> + Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl + | WhiteSpace n :: sl -> + Break n :: raw_analyze_notation_tokens sl + +let decompose_raw_notation ntn = raw_analyze_notation_tokens (split_notation_string ntn) + +let possible_notations ntn = + (* We collect the possible interpretations of a notation string depending on whether it is + in "x 'U' y" or "_ U _" format *) + let toks = split_notation_string ntn in + if List.exists (function String "_" -> true | _ -> false) toks then + (* Only "_ U _" format *) + [ntn] + else + let ntn' = make_notation_key (raw_analyze_notation_tokens toks) in + if String.equal ntn ntn' then (* Only symbols *) [ntn] else [ntn;ntn'] + let browse_notation strict ntn map = - let find ntn' = + let ntns = possible_notations ntn in + let find ntn' ntn = if String.contains ntn ' ' then String.equal ntn ntn' else let toks = decompose_notation_key ntn' in @@ -917,7 +1018,7 @@ let browse_notation strict ntn map = String.Map.fold (fun scope_name sc -> String.Map.fold (fun ntn { not_interp = (_, r); not_location = df } l -> - if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations) + if List.exists (find ntn) ntns then (ntn,(scope_name,r,df))::l else l) sc.notations) map [] in List.sort (fun x y -> String.compare (fst x) (fst y)) l diff --git a/interp/notation.mli b/interp/notation.mli index 2066d346f..a4c79d6d3 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -124,9 +124,9 @@ val interp_notation : ?loc:Loc.t -> notation -> local_scopes -> type notation_rule = interp_rule * interpretation * int option (** Return the possible notations for a given term *) -val uninterp_notations : 'a glob_constr_g -> notation_rule list -val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list -val uninterp_ind_pattern_notations : inductive -> notation_rule list +val uninterp_notations : local_scopes -> 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : local_scopes -> 'a cases_pattern_g -> notation_rule list +val uninterp_ind_pattern_notations : local_scopes -> inductive -> notation_rule list (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first @@ -176,16 +176,20 @@ val scope_class_of_class : Classops.cl_typ -> scope_class (** Building notation key *) type symbol = - | Terminal of string - | NonTerminal of Id.t - | SProdList of Id.t * symbol list - | Break of int + | Terminal of string (* an expression including symbols or a simply-quoted ident, e.g. "'U'" or "!" *) + | NonTerminal of Id.t (* an identifier "x" *) + | SProdList of Id.t * symbol list (* an expression "x sep .. sep y", remembering x (or y) and sep *) + | Break of int (* a sequence of blanks > 1, e.g. " " *) val symbol_eq : symbol -> symbol -> bool +(** Make/decompose a notation of the form "_ U _" *) val make_notation_key : symbol list -> notation val decompose_notation_key : notation -> symbol list +(** Decompose a notation of the form "a 'U' b" *) +val decompose_raw_notation : string -> symbol list + (** Prints scopes (expects a pure aconstr printer) *) val pr_scope_class : scope_class -> Pp.t val pr_scope : (glob_constr -> Pp.t) -> scope_name -> Pp.t diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 20492e38c..c65f4785e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -42,9 +42,9 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 | NProd (na1, t1, u1), NProd (na2, t2, u2) -> Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) -> +| NBinderList (i1, j1, t1, u1, b1), NBinderList (i2, j2, t2, u2, b2) -> Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && - (eq_notation_constr vars) u1 u2 + (eq_notation_constr vars) u1 u2 && b1 == b2 | NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> Name.equal na1 na2 && eq_notation_constr vars b1 b2 && Option.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 @@ -86,9 +86,11 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Miscops.glob_sort_eq s1 s2 | NCast (t1, c1), NCast (t2, c2) -> (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 +| NProj (p1, c1), NProj (p2, c2) -> + Projection.equal p1 p2 && eq_notation_constr vars c1 c2 | (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _), _ -> false + | NRec _ | NSort _ | NCast _ | NProj _), _ -> false (**********************************************************************) (* Re-interpret a notation as a glob_constr, taking care of binders *) @@ -99,13 +101,24 @@ let name_to_ident = function let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na +let product_of_cases_patterns patl = + List.fold_right (fun patl restl -> + List.flatten (List.map (fun p -> List.map (fun rest -> p::rest) restl) patl)) + patl [[]] + let rec cases_pattern_fold_map ?loc g e = DAst.with_val (function | PatVar na -> - let e',na' = g e na in e', DAst.make ?loc @@ PatVar na' + let e',disjpat,na' = g e na in + e', (match disjpat with + | None -> [DAst.make ?loc @@ PatVar na'] + | Some ((_,disjpat),_) -> disjpat) | PatCstr (cstr,patl,na) -> - let e',na' = g e na in + let e',disjpat,na' = g e na in + if disjpat <> None then user_err (Pp.str "Unable to instantiate an \"as\" clause with a pattern."); let e',patl' = List.fold_left_map (cases_pattern_fold_map ?loc g) e patl in - e', DAst.make ?loc @@ PatCstr (cstr,patl',na') + (* Distribute outwards the inner disjunctive patterns *) + let disjpatl' = product_of_cases_patterns patl' in + e', List.map (fun patl' -> DAst.make ?loc @@ PatCstr (cstr,patl',na')) disjpatl' ) let subst_binder_type_vars l = function @@ -134,6 +147,16 @@ let rec subst_glob_vars l gc = DAst.map (function let ldots_var = Id.of_string ".." +let protect g e na = + let e',disjpat,na = g e na in + if disjpat <> None then user_err (Pp.str "Unsupported substitution of an arbitrary pattern."); + e',na + +let apply_cases_pattern ?loc ((ids,disjpat),id) c = + let tm = DAst.make ?loc (GVar id) in + let eqns = List.map (fun pat -> (loc,(ids,[pat],c))) disjpat in + DAst.make ?loc @@ GCases (LetPatternStyle, None, [tm,(Anonymous,None)], eqns) + let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let lt x = DAst.make ?loc x in lt @@ match nc with | NVar id -> GVar id @@ -144,61 +167,73 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in DAst.get (subst_glob_vars outerl it) - | NBinderList (x,y,iter,tail) -> + | NBinderList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in - let innerl = [(ldots_var,t);(x, lt @@ GVar y)] in + let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in - let outerl = [(ldots_var,inner)] in + let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> - let e',na = g e na in GLambda (na,Explicit,f e ty,f e' c) + let e',disjpat,na = g e na in GLambda (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NProd (na,ty,c) -> - let e',na = g e na in GProd (na,Explicit,f e ty,f e' c) + let e',disjpat,na = g e na in GProd (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NLetIn (na,b,t,c) -> - let e',na = g e na in GLetIn (na,f e b,Option.map (f e) t,f e' c) + let e',disjpat,na = g e na in + (match disjpat with + | None -> GLetIn (na,f e b,Option.map (f e) t,f e' c) + | Some disjpat -> DAst.get (apply_cases_pattern ?loc disjpat (f e' c))) | NCases (sty,rtntypopt,tml,eqnl) -> let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> let e',t' = match t with | None -> e',None | Some (ind,nal) -> let e',nal' = List.fold_right (fun na (e',nal) -> - let e',na' = g e' na in e',na'::nal) nal (e',[]) in - e',Some (Loc.tag ?loc (ind,nal')) in - let e',na' = g e' na in - (e',(f e tm,(na',t'))::tml')) tml (e,[]) in - let fold (idl,e) na = let (e,na) = g e na in ((Name.cons na idl,e),na) in + let e',na' = protect g e' na in + e',na'::nal) nal (e',[]) in + e',Some (Loc.tag ?loc (ind,nal')) in + let e',na' = protect g e' na in + (e',(f e tm,(na',t'))::tml')) tml (e,[]) in + let fold (idl,e) na = let (e,disjpat,na) = g e na in ((Name.cons na idl,e),disjpat,na) in let eqnl' = List.map (fun (patl,rhs) -> - let ((idl,e),patl) = - List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in - Loc.tag (idl,patl,f e rhs)) eqnl in - GCases (sty,Option.map (f e') rtntypopt,tml',eqnl') + let ((idl,e),patl) = + List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in + let disjpatl = product_of_cases_patterns patl in + List.map (fun patl -> Loc.tag (idl,patl,f e rhs)) disjpatl) eqnl in + GCases (sty,Option.map (f e') rtntypopt,tml',List.flatten eqnl') | NLetTuple (nal,(na,po),b,c) -> - let e',nal = List.fold_left_map g e nal in - let e'',na = g e na in + let e',nal = List.fold_left_map (protect g) e nal in + let e'',na = protect g e na in GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) | NIf (c,(na,po),b1,b2) -> - let e',na = g e na in + let e',na = protect g e na in GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> - let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> - let e,na = g e na in + let e,dll = Array.fold_left_map (List.fold_map (fun e (na,oc,b) -> + let e,na = protect g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in - let e',idl = Array.fold_left_map (to_id g) e idl in + let e',idl = Array.fold_left_map (to_id (protect g)) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) | NCast (c,k) -> GCast (f e c,Miscops.map_cast_type (f e) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) | NRef x -> GRef (x,None) + | NProj (p,c) -> GProj (p, f e c) let glob_constr_of_notation_constr ?loc x = let rec aux () x = - glob_constr_of_notation_constr_with_binders ?loc (fun () id -> ((),id)) aux () x + glob_constr_of_notation_constr_with_binders ?loc (fun () id -> ((),None,id)) aux () x in aux () x (******************************************************************************) (* Translating a glob_constr into a notation, interpreting recursive patterns *) -let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) +type found_variables = { + vars : Id.t list; + recursive_term_vars : (Id.t * Id.t) list; + recursive_binders_vars : (Id.t * Id.t) list; + } + +let add_id r id = r := { !r with vars = id :: (!r).vars } let add_name r = function Anonymous -> () | Name id -> add_id r id let is_gvar id c = match DAst.get c with @@ -242,13 +277,25 @@ let check_is_hole id t = match DAst.get t with GHole _ -> () | _ -> (strbrk "In recursive notation with binders, " ++ Id.print id ++ strbrk " is expected to come without type.") +let check_pair_matching ?loc x y x' y' revert revert' = + if not (Id.equal x x' && Id.equal y y' && revert = revert') then + let x,y = if revert then y,x else x,y in + let x',y' = if revert' then y',x' else x',y' in + (* This is a case where one would like to highlight two locations! *) + user_err ?loc + (strbrk "Found " ++ Id.print x ++ strbrk " matching " ++ Id.print y ++ + strbrk " while " ++ Id.print x' ++ strbrk " matching " ++ Id.print y' ++ + strbrk " was first found.") + let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' +let mem_recursive_pair (x,y) l = List.mem_f (pair_equal Id.equal Id.equal) (x,y) l + type recursive_pattern_kind = -| RecursiveTerms of bool (* associativity *) -| RecursiveBinders of glob_constr * glob_constr +| RecursiveTerms of bool (* in reverse order *) +| RecursiveBinders of bool (* in reverse order *) -let compare_recursive_parts found f f' (iterator,subc) = +let compare_recursive_parts recvars found f f' (iterator,subc) = let diff = ref None in let terminator = ref None in let rec aux c1 c2 = match DAst.get c1, DAst.get c2 with @@ -267,24 +314,41 @@ let compare_recursive_parts found f f' (iterator,subc) = List.for_all2eq aux l1 l2 | _ -> mk_glob_constr_eq aux c1 c2 end - | GVar x, GVar y when not (Id.equal x y) -> + | GVar x, GVar y + when mem_recursive_pair (x,y) recvars || mem_recursive_pair (y,x) recvars -> (* We found the position where it differs *) - let lassoc = match !terminator with None -> false | Some _ -> true in - let x,y = if lassoc then y,x else x,y in + let revert = mem_recursive_pair (y,x) recvars in + let x,y = if revert then y,x else x,y in begin match !diff with | None -> - let () = diff := Some (x, y, RecursiveTerms lassoc) in + let () = diff := Some (x, y, RecursiveTerms revert) in + true + | Some (x', y', RecursiveTerms revert') + | Some (x', y', RecursiveBinders revert') -> + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; true - | Some _ -> false end | GLambda (Name x,_,t_x,c), GLambda (Name y,_,t_y,term) - | GProd (Name x,_,t_x,c), GProd (Name y,_,t_y,term) when not (Id.equal x y) -> + | GProd (Name x,_,t_x,c), GProd (Name y,_,t_y,term) + when mem_recursive_pair (x,y) recvars || mem_recursive_pair (y,x) recvars -> (* We found a binding position where it differs *) + check_is_hole x t_x; + check_is_hole y t_y; + let revert = mem_recursive_pair (y,x) recvars in + let x,y = if revert then y,x else x,y in begin match !diff with | None -> - let () = diff := Some (x, y, RecursiveBinders (t_x,t_y)) in + let () = diff := Some (x, y, RecursiveBinders revert) in aux c term - | Some _ -> false + | Some (x', y', RecursiveBinders revert') -> + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; + true + | Some (x', y', RecursiveTerms revert') -> + (* Recursive binders have precedence: they can be coerced to + terms but not reciprocally *) + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; + let () = diff := Some (x, y, RecursiveBinders revert) in + true end | _ -> mk_glob_constr_eq aux c1 c2 in @@ -293,46 +357,36 @@ let compare_recursive_parts found f f' (iterator,subc) = | None -> let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in - (* Here, we would need a loc made of several parts ... *) - user_err ?loc:(subtract_loc loc1 loc2) + (* Here, we would need a loc made of several parts ... *) + user_err ?loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") - | Some (x,y,RecursiveTerms lassoc) -> - let toadd,x,y,lassoc = - if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || - List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) - then - None,x,y,lassoc - else if List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi2 !found) || - List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi3 !found) - then - None,y,x,not lassoc - else - Some (x,y),x,y,lassoc in - let iterator = - f' (if lassoc then iterator - else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in - (* found variables have been collected by compare_constr *) - found := (List.remove Id.equal y (pi1 !found), - Option.fold_right (fun a l -> a::l) toadd (pi2 !found), - pi3 !found); - NList (x,y,iterator,f (Option.get !terminator),lassoc) - | Some (x,y,RecursiveBinders (t_x,t_y)) -> - let iterator = f' (subst_glob_vars [x, DAst.make @@ GVar y] iterator) in - (* found have been collected by compare_constr *) - found := (List.remove Id.equal y (pi1 !found), pi2 !found, (x,y) :: pi3 !found); - check_is_hole x t_x; - check_is_hole y t_y; - NBinderList (x,y,iterator,f (Option.get !terminator)) + | Some (x,y,RecursiveTerms revert) -> + (* By arbitrary convention, we use the second variable of the pair + as the place-holder for the iterator *) + let iterator = + f' (if revert then iterator else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in + (* found variables have been collected by compare_constr *) + found := { !found with vars = List.remove Id.equal y (!found).vars; + recursive_term_vars = List.add_set (pair_equal Id.equal Id.equal) (x,y) (!found).recursive_term_vars }; + NList (x,y,iterator,f (Option.get !terminator),revert) + | Some (x,y,RecursiveBinders revert) -> + let iterator = + f' (if revert then iterator else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in + (* found have been collected by compare_constr *) + found := { !found with vars = List.remove Id.equal y (!found).vars; + recursive_binders_vars = List.add_set (pair_equal Id.equal Id.equal) (x,y) (!found).recursive_binders_vars }; + NBinderList (x,y,iterator,f (Option.get !terminator),revert) else raise Not_found -let notation_constr_and_vars_of_glob_constr a = - let found = ref ([],[],[]) in +let notation_constr_and_vars_of_glob_constr recvars a = + let found = ref { vars = []; recursive_term_vars = []; recursive_binders_vars = [] } in let has_ltac = ref false in + (* Turn a glob_constr into a notation_constr by first trying to find a recursive pattern *) let rec aux c = let keepfound = !found in (* n^2 complexity but small and done only once per notation *) - try compare_recursive_parts found aux aux' (split_at_recursive_part c) + try compare_recursive_parts recvars found aux aux' (split_at_recursive_part c) with Not_found -> found := keepfound; match DAst.get c with @@ -383,6 +437,7 @@ let notation_constr_and_vars_of_glob_constr a = if arg != None then has_ltac := true; NHole (w, naming, arg) | GRef (r,_) -> NRef r + | GProj (p, c) -> NProj (p, aux c) | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") ) x @@ -391,8 +446,9 @@ let notation_constr_and_vars_of_glob_constr a = (* Side effect *) t, !found, !has_ltac -let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = - let injective = ref true in +let check_variables_and_reversibility nenv + { vars = found; recursive_term_vars = foundrec; recursive_binders_vars = foundrecbinding } = + let injective = ref [] in let recvars = nenv.ninterp_rec_vars in let fold _ y accu = Id.Set.add y accu in let useless_vars = Id.Map.fold fold recvars Id.Set.empty in @@ -415,33 +471,36 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = user_err Pp.(str (Id.to_string x ^ " should not be bound in a recursive pattern of the right-hand side.")) - else injective := false + else injective := x :: !injective in let check_pair s x y where = - if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then + if not (mem_recursive_pair (x,y) where) then user_err (strbrk "in the right-hand side, " ++ Id.print x ++ str " and " ++ Id.print y ++ strbrk " should appear in " ++ str s ++ str " position as part of a recursive pattern.") in let check_type x typ = match typ with - | NtnInternTypeConstr -> + | NtnInternTypeAny -> begin try check_pair "term" x (Id.Map.find x recvars) foundrec with Not_found -> check_bound x end - | NtnInternTypeBinder -> + | NtnInternTypeOnlyBinder -> begin try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding with Not_found -> check_bound x - end - | NtnInternTypeIdent -> check_bound x in + end in Id.Map.iter check_type vars; - !injective + List.rev !injective let notation_constr_of_glob_constr nenv a = - let a, found, has_ltac = notation_constr_and_vars_of_glob_constr a in + let recvars = Id.Map.bindings nenv.ninterp_rec_vars in + let a, found, has_ltac = notation_constr_and_vars_of_glob_constr recvars a in let injective = check_variables_and_reversibility nenv found in - a, not has_ltac && injective + let status = if has_ltac then HasLtac else match injective with + | [] -> APrioriReversible + | l -> NonInjective l in + a, status (**********************************************************************) (* Substitution of kernel names, avoiding a list of bound identifiers *) @@ -497,11 +556,11 @@ let rec subst_notation_constr subst bound raw = if r1' == r1 && r2' == r2 then raw else NProd (n,r1',r2') - | NBinderList (id1,id2,r1,r2) -> + | NBinderList (id1,id2,r1,r2,b) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in if r1' == r1 && r2' == r2 then raw else - NBinderList (id1,id2,r1',r2') + NBinderList (id1,id2,r1',r2',b) | NLetIn (n,r1,t,r2) -> let r1' = subst_notation_constr subst bound r1 in @@ -576,6 +635,14 @@ let rec subst_notation_constr subst bound raw = let k' = Miscops.smartmap_cast_type (subst_notation_constr subst bound) k in if r1' == r1 && k' == k then raw else NCast(r1',k') + | NProj (p, c) -> + let kn = Projection.constant p in + let b = Projection.unfolded p in + let kn' = subst_constant subst kn in + let c' = subst_notation_constr subst bound c in + if kn' == kn && c' == c then raw else NProj(Projection.make kn' b, c') + + let subst_interpretation subst (metas,pat) = let bound = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty metas in (metas,subst_notation_constr subst bound pat) @@ -604,8 +671,20 @@ let is_term_meta id metas = try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false with Not_found -> false +let is_onlybinding_strict_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinder (NtnParsedAsPattern true) -> true | _ -> false + with Not_found -> false + let is_onlybinding_meta id metas = - try match Id.List.assoc id metas with _,NtnTypeOnlyBinder -> true | _ -> false + try match Id.List.assoc id metas with _,NtnTypeBinder _ -> true | _ -> false + with Not_found -> false + +let is_onlybinding_pattern_like_meta isvar id metas = + try match Id.List.assoc id metas with + | _,NtnTypeBinder (NtnBinderParsedAsConstr + (Extend.AsIdentOrPattern | Extend.AsStrictPattern)) -> true + | _,NtnTypeBinder (NtnParsedAsPattern strict) -> not (strict && isvar) + | _ -> false with Not_found -> false let is_bindinglist_meta id metas = @@ -624,7 +703,7 @@ let alpha_rename alpmetas v = if alpmetas == [] then v else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match -let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = +let add_env (alp,alpmetas) (terms,termlists,binders,binderlists) var v = (* Check that no capture of binding variables occur *) (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." with an actual term "fun z => ... z ..." when "x" is not bound in the @@ -652,19 +731,49 @@ let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = refinement *) let v = alpha_rename alpmetas v in (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::terms,onlybinders,termlists,binderlists) + ((var,v)::terms,termlists,binders,binderlists) -let add_termlist_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var vl = +let add_termlist_env (alp,alpmetas) (terms,termlists,binders,binderlists) var vl = if List.exists (fun (id,_) -> List.exists (occur_glob_constr id) vl) alp then raise No_match; let vl = List.map (alpha_rename alpmetas) vl in - (terms,onlybinders,(var,vl)::termlists,binderlists) + (terms,(var,vl)::termlists,binders,binderlists) -let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = +let add_binding_env alp (terms,termlists,binders,binderlists) var v = (* TODO: handle the case of multiple occs in different scopes *) - (terms,(var,v)::onlybinders,termlists,binderlists) + (terms,termlists,(var,v)::binders,binderlists) + +let add_bindinglist_env (terms,termlists,binders,binderlists) x bl = + (terms,termlists,binders,(x,bl)::binderlists) + +let rec map_cases_pattern_name_left f = DAst.map (function + | PatVar na -> PatVar (f na) + | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) + ) + +let rec fold_cases_pattern_eq f x p p' = + let loc = p.CAst.loc in + match DAst.get p, DAst.get p' with + | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na + | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> + let x,l = fold_cases_pattern_list_eq f x l l' in + let x,na = f x na na' in + x, DAst.make ?loc @@ PatCstr (c,l,na) + | _ -> failwith "Not equal" + +and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with + | [], [] -> x, [] + | p::pl, p'::pl' -> + let x, p = fold_cases_pattern_eq f x p p' in + let x, pl = fold_cases_pattern_list_eq f x pl pl' in + x, p :: pl + | _ -> assert false -let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = - (terms,onlybinders,termlists,(x,bl)::binderlists) +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with +| PatVar na1, PatVar na2 -> Name.equal na1 na2 +| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 +| _ -> false let rec pat_binder_of_term t = DAst.map (function | GVar id -> PatVar (Name id) @@ -679,39 +788,111 @@ let rec pat_binder_of_term t = DAst.map (function | _ -> raise No_match ) t -let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = +let unify_name_upto alp na na' = + match na, na' with + | Anonymous, na' -> alp, na' + | na, Anonymous -> alp, na + | Name id, Name id' -> + if Id.equal id id' then alp, na' + else (fst alp,(id,id')::snd alp), na' + +let unify_pat_upto alp p p' = + try fold_cases_pattern_eq unify_name_upto alp p p' with Failure _ -> raise No_match + +let unify_term alp v v' = + match DAst.get v, DAst.get v' with + | GHole _, _ -> v' + | _, GHole _ -> v + | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match + +let unify_opt_term alp v v' = + match v, v' with + | Some t, Some t' -> Some (unify_term alp t t') + | (Some _ as x), None | None, (Some _ as x) -> x + | None, None -> None + +let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match + +let unify_binder_upto alp b b' = + let loc, loc' = CAst.(b.loc, b'.loc) in + match DAst.get b, DAst.get b' with + | 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') -> + 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') + | 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') + | _ -> raise No_match + +let rec unify_terms alp vl vl' = + match vl, vl' with + | [], [] -> [] + | v :: vl, v' :: vl' -> unify_term alp v v' :: unify_terms alp vl vl' + | _ -> raise No_match + +let rec unify_binders_upto alp bl bl' = + match bl, bl' with + | [], [] -> alp, [] + | b :: bl, b' :: bl' -> + let alp,b = unify_binder_upto alp b b' in + let alp,bl = unify_binders_upto alp bl bl' in + alp, b :: bl + | _ -> raise No_match + +let unify_id alp id na' = + match na' with + | Anonymous -> Name (rename_var (snd alp) id) + | Name id' -> + if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match + +let unify_pat alp p p' = + if cases_pattern_eq (map_cases_pattern_name_left (Name.map (rename_var (snd alp))) p) p' then p' + else raise No_match + +let unify_term_binder alp c = DAst.(map (fun b' -> + match DAst.get c, b' with + | GVar id, GLocalAssum (na', bk', t') -> + GLocalAssum (unify_id alp id na', bk', t') + | _, GLocalPattern (([p'],ids), id, bk', t') -> + let p = pat_binder_of_term c in + GLocalPattern (([unify_pat alp p p'],ids), id, bk', t') + | _ -> raise No_match)) + +let rec unify_terms_binders alp cl bl' = + match cl, bl' with + | [], [] -> [] + | c :: cl, b' :: bl' -> + begin match DAst.get b' with + | GLocalDef ( _, _, _, t) -> unify_terms_binders alp cl bl' + | _ -> unify_term_binder alp c b' :: unify_terms_binders alp cl bl' + end + | _ -> raise No_match + +let bind_term_env alp (terms,termlists,binders,binderlists as sigma) var v = try + (* If already bound to a term, unify with the new term *) let v' = Id.List.assoc var terms in - match DAst.get v, DAst.get v' with - | GHole _, _ -> sigma - | _, GHole _ -> - let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in - add_env alp sigma var v - | _, _ -> - if glob_constr_eq (alpha_rename (snd alp) v) v' then sigma - else raise No_match + let v'' = unify_term alp v v' in + if v'' == v' then sigma else + let sigma = (Id.List.remove_assoc var terms,termlists,binders,binderlists) in + add_env alp sigma var v with Not_found -> add_env alp sigma var v -let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var vl = +let bind_termlist_env alp (terms,termlists,binders,binderlists as sigma) var vl = try + (* If already bound to a list of term, unify with the new terms *) let vl' = Id.List.assoc var termlists in - let unify_term v v' = - match DAst.get v, DAst.get v' with - | GHole _, _ -> v' - | _, GHole _ -> v - | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in - let rec unify vl vl' = - match vl, vl' with - | [], [] -> [] - | v :: vl, v' :: vl' -> unify_term v v' :: unify vl vl' - | _ -> raise No_match in - let vl = unify vl vl' in - let sigma = (terms,onlybinders,Id.List.remove_assoc var termlists,binderlists) in + let vl = unify_terms alp vl vl' in + let sigma = (terms,Id.List.remove_assoc var termlists,binders,binderlists) in add_termlist_env alp sigma var vl with Not_found -> add_termlist_env alp sigma var vl -let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = +let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) var id = try + (* If already bound to a term, unify the binder and the term *) match DAst.get (Id.List.assoc var terms) with | GVar id' -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), @@ -723,142 +904,49 @@ let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sig (* TODO: look at the consequences for alp *) alp, add_env alp sigma var (DAst.make @@ GVar id) -let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = +let force_cases_pattern c = + DAst.make ?loc:c.CAst.loc (DAst.get c) + +let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) var c = + let pat = try force_cases_pattern (cases_pattern_of_glob_constr Anonymous c) with Not_found -> raise No_match in try - let v' = Id.List.assoc var onlybinders in - match v' with - | Anonymous -> - (* Should not occur, since the term has to be bound upwards *) - let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in - add_binding_env alp sigma var (Name id) - | Name id' -> - if Id.equal (rename_var (snd alp) id) id' then sigma else raise No_match - with Not_found -> add_binding_env alp sigma var (Name id) - -let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = + (* If already bound to a binder, unify the term and the binder *) + let patl' = Id.List.assoc var binders in + let patl'' = List.map2 (unify_pat alp) [pat] patl' in + if patl' == patl'' then sigma + else + let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in + add_binding_env alp sigma var patl'' + with Not_found -> add_binding_env alp sigma var [pat] + +let bind_binding_env alp (terms,termlists,binders,binderlists as sigma) var disjpat = try - let v' = Id.List.assoc var onlybinders in - match v, v' with - | Anonymous, _ -> alp, sigma - | _, Anonymous -> - let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in - alp, add_binding_env alp sigma var v - | Name id1, Name id2 -> - if Id.equal id1 id2 then alp,sigma - else (fst alp,(id1,id2)::snd alp),sigma - with Not_found -> alp, add_binding_env alp sigma var v - -let rec map_cases_pattern_name_left f = DAst.map (function - | PatVar na -> PatVar (f na) - | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) - ) - -let rec fold_cases_pattern_eq f x p p' = - let loc = p.CAst.loc in - match DAst.get p, DAst.get p' with - | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na - | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> - let x,l = fold_cases_pattern_list_eq f x l l' in - let x,na = f x na na' in - x, DAst.make ?loc @@ PatCstr (c,l,na) - | _ -> failwith "Not equal" - -and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with - | [], [] -> x, [] - | p::pl, p'::pl' -> - let x, p = fold_cases_pattern_eq f x p p' in - let x, pl = fold_cases_pattern_list_eq f x pl pl' in - x, p :: pl - | _ -> assert false - -let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with -| PatVar na1, PatVar na2 -> Name.equal na1 na2 -| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && - Name.equal na1 na2 -| _ -> false - -let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) var bl = + (* If already bound to a binder possibly *) + (* generating an alpha-renaming from unifying the new binder *) + let disjpat' = Id.List.assoc var binders in + let alp, disjpat = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in + let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in + alp, add_binding_env alp sigma var disjpat + with Not_found -> alp, add_binding_env alp sigma var disjpat + +let bind_bindinglist_env alp (terms,termlists,binders,binderlists as sigma) var bl = let bl = List.rev bl in try + (* If already bound to a list of binders possibly *) + (* generating an alpha-renaming from unifying the new binders *) let bl' = Id.List.assoc var binderlists in - let unify_name alp na na' = - match na, na' with - | Anonymous, na' -> alp, na' - | na, Anonymous -> alp, na - | Name id, Name id' -> - if Id.equal id id' then alp, na' - else (fst alp,(id,id')::snd alp), na' in - let unify_pat alp p p' = - try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in - let unify_term alp v v' = - match DAst.get v, DAst.get v' with - | GHole _, _ -> v' - | _, GHole _ -> v - | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in - let unify_opt_term alp v v' = - match v, v' with - | Some t, Some t' -> Some (unify_term alp t t') - | (Some _ as x), None | None, (Some _ as x) -> x - | None, None -> None in - let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in - let unify_binder alp b b' = - let loc, loc' = CAst.(b.loc, b'.loc) in - match DAst.get b, DAst.get b' with - | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> - let alp, na = unify_name 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') -> - let alp, na = unify_name 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') - | GLocalPattern ((p,ids),id,bk,t), GLocalPattern ((p',_),_,bk',t') -> - let alp, p = unify_pat alp p p' in - alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') - | _ -> raise No_match in - let rec unify alp bl bl' = - match bl, bl' with - | [], [] -> alp, [] - | b :: bl, b' :: bl' -> - let alp,b = unify_binder alp b b' in - let alp,bl = unify alp bl bl' in - alp, b :: bl - | _ -> raise No_match in - let alp, bl = unify alp bl bl' in - let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in + let alp, bl = unify_binders_upto alp bl bl' in + let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in alp, add_bindinglist_env sigma var bl with Not_found -> alp, add_bindinglist_env sigma var bl -let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) var cl = +let bind_bindinglist_as_termlist_env alp (terms,termlists,binders,binderlists) var cl = try + (* If already bound to a list of binders, unify the terms and binders *) let bl' = Id.List.assoc var binderlists in - let unify_id id na' = - match na' with - | Anonymous -> Name (rename_var (snd alp) id) - | Name id' -> - if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match in - let unify_pat p p' = - if cases_pattern_eq (map_cases_pattern_name_left (Name.map (rename_var (snd alp))) p) p' then p' - else raise No_match in - let unify_term_binder c = DAst.(map (fun b' -> - match DAst.get c, b' with - | GVar id, GLocalAssum (na', bk', t') -> - GLocalAssum (unify_id id na', bk', t') - | _, GLocalPattern ((p',ids), id, bk', t') -> - let p = pat_binder_of_term c in - GLocalPattern ((unify_pat p p',ids), id, bk', t') - | _ -> raise No_match )) in - let rec unify cl bl' = - match cl, bl' with - | [], [] -> [] - | c :: cl, b' :: bl' -> - begin match DAst.get b' with - | GLocalDef ( _, _, _, t) -> unify cl bl' - | _ -> unify_term_binder c b' :: unify cl bl' - end - | _ -> raise No_match in - let bl = unify cl bl' in - let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in + let bl = unify_terms_binders alp cl bl' in + let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in add_bindinglist_env sigma var bl with Not_found -> anomaly (str "There should be a binder list bindings this list of terms.") @@ -882,8 +970,10 @@ let match_opt f sigma t1 t2 = match (t1,t2) with | _ -> raise No_match let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with + | (na1,Name id2) when is_onlybinding_strict_meta id2 metas -> + raise No_match | (na1,Name id2) when is_onlybinding_meta id2 metas -> - bind_binding_env alp sigma id2 na1 + bind_binding_env alp sigma id2 [DAst.make (PatVar na1)] | (Name id1,Name id2) when is_term_meta id2 metas -> (* We let the non-binding occurrence define the rhs and hence reason up to *) (* alpha-conversion for the given occurrence of the name (see #4592)) *) @@ -895,54 +985,42 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match -let rec match_cases_pattern_binders metas acc pat1 pat2 = +let rec match_cases_pattern_binders allow_catchall metas (alp,sigma as acc) pat1 pat2 = match DAst.get pat1, DAst.get pat2 with + | PatVar _, PatVar (Name id2) when is_onlybinding_pattern_like_meta true id2 metas -> + bind_binding_env alp sigma id2 [pat1] + | _, PatVar (Name id2) when is_onlybinding_pattern_like_meta false id2 metas -> + bind_binding_env alp sigma id2 [pat1] | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 + | _, PatVar Anonymous when allow_catchall -> acc | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> - List.fold_left2 (match_cases_pattern_binders metas) - (match_names metas acc na1 na2) patl1 patl2 + List.fold_left2 (match_cases_pattern_binders false metas) + (match_names metas acc na1 na2) patl1 patl2 | _ -> raise No_match -let glue_letin_with_decls = true - -let rec match_iterated_binders islambda decls bi = DAst.(with_loc_val (fun ?loc -> function - | GLambda (na,bk,t,b) as b0 -> - begin match na, DAst.get b with - | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) - when islambda && is_gvar p e && not (occur_glob_constr p b) -> - match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | _, _ when islambda -> - match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b - | _ -> (decls, DAst.make ?loc b0) - end - | GProd (na,bk,t,b) as b0 -> - begin match na, DAst.get b with - | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) - when not islambda && is_gvar p e && not (occur_glob_constr p b) -> - match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | Name _, _ when not islambda -> - match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b - | _ -> (decls, DAst.make ?loc b0) - end - | GLetIn (na,c,t,b) when glue_letin_with_decls -> - match_iterated_binders islambda - ((DAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b - | b -> (decls, DAst.make ?loc b) - )) bi - -let remove_sigma x (terms,onlybinders,termlists,binderlists) = - (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists) +let remove_sigma x (terms,termlists,binders,binderlists) = + (Id.List.remove_assoc x terms,termlists,binders,binderlists) -let remove_bindinglist_sigma x (terms,onlybinders,termlists,binderlists) = - (terms,onlybinders,termlists,Id.List.remove_assoc x binderlists) +let remove_bindinglist_sigma x (terms,termlists,binders,binderlists) = + (terms,termlists,binders,Id.List.remove_assoc x binderlists) let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas let add_meta_bindinglist x metas = (x,((None,[]),NtnTypeBinderList))::metas -let match_binderlist_with_app match_fun alp metas sigma rest x y iter termin = - let rec aux sigma bl rest = +(* This tells if letins in the middle of binders should be included in + the sequence of binders *) +let glue_inner_letin_with_decls = true + +(* This tells if trailing letins (with no further proper binders) + should be included in sequence of binders *) +let glue_trailing_letin_with_decls = false + +exception OnlyTrailingLetIns + +let match_binderlist match_fun alp metas sigma rest x y iter termin revert = + let rec aux trailing_letins sigma bl rest = try let metas = add_ldots_var (add_meta_bindinglist y metas) in let (terms,_,_,binderlists as sigma) = match_fun alp metas sigma rest iter in @@ -951,16 +1029,32 @@ let match_binderlist_with_app match_fun alp metas sigma rest x y iter termin = match Id.List.assoc y binderlists with [b] -> b | _ ->assert false in let sigma = remove_bindinglist_sigma y (remove_sigma ldots_var sigma) in - aux sigma (b::bl) rest - with No_match when not (List.is_empty bl) -> - bl, rest, sigma in - let bl,rest,sigma = aux sigma [] rest in + (* In case y is bound not only to a binder but also to a term *) + let sigma = remove_sigma y sigma in + aux false sigma (b::bl) rest + 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 + (* collect let-in *) + (try aux true sigma (b::bl) rest' + with OnlyTrailingLetIns + when not (trailing_letins && not glue_trailing_letin_with_decls) -> + (* renounce to take into account trailing let-ins *) + if not (List.is_empty bl) then bl, rest, sigma else raise No_match) + | _ -> + if trailing_letins && not glue_trailing_letin_with_decls then + (* Backtrack to when we tried to glue letins *) + raise OnlyTrailingLetIns; + if not (List.is_empty bl) then bl, rest, sigma else raise No_match in + let bl,rest,sigma = aux false sigma [] rest in + let bl = if revert then List.rev bl else bl in let alp,sigma = bind_bindinglist_env alp sigma x bl in match_fun alp metas sigma rest termin let add_meta_term x metas = (x,((None,[]),NtnTypeConstr))::metas -let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = +let match_termlist match_fun alp metas sigma rest x y iter termin revert = let rec aux sigma acc rest = try let metas = add_ldots_var (add_meta_term y metas) in @@ -971,12 +1065,12 @@ let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = aux sigma (t::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in - let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in - let l = if lassoc then l else List.rev l in + let l,(terms,termlists,binders,binderlists as sigma) = aux sigma [] rest in + let l = if revert then l else List.rev l in if is_bindinglist_meta x metas then (* This is a recursive pattern for both bindings and terms; it is *) (* registered for binders *) - bind_bindinglist_as_term_env alp sigma x l + bind_bindinglist_as_termlist_env alp sigma x l else bind_termlist_env alp sigma x l @@ -1011,72 +1105,19 @@ let rec match_ inner u alp metas sigma a1 a2 = match DAst.get a1, a2 with (* Matching notation variable *) | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 - | GVar id1, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 + | GVar _, NVar id2 when is_onlybinding_pattern_like_meta true id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | r1, NVar id2 when is_onlybinding_pattern_like_meta false id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | GVar _, NVar id2 when is_onlybinding_strict_meta id2 metas -> raise No_match + | GVar _, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 a1 | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 a1 (* Matching recursive notations for terms *) - | r1, NList (x,y,iter,termin,lassoc) -> - match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin lassoc - - | GLambda (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> - begin match na1, DAst.get b1, iter with - (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), NLambda (Name _, _, _) - when is_gvar p e && not (occur_glob_constr p b1) -> - let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in - let alp,sigma = bind_bindinglist_env alp sigma x decls in - match_in u alp metas sigma b termin - (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | _, _, NLambda (Name _,_,_) -> - let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in - (* TODO: address the possibility that termin is a Lambda itself *) - let alp,sigma = bind_bindinglist_env alp sigma x decls in - match_in u alp metas sigma b termin - (* Matching recursive notations for binders: general case *) - | _, _, _ -> - match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin - end - - | GProd (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> - (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) - begin match na1, DAst.get b1, iter, termin with - | Name p, GCases (LetPatternStyle,None,[(e, _)],[(_,(ids,[cp],b1))]), NProd (Name _,_,_), NVar _ - when is_gvar p e && not (occur_glob_constr p b1) -> - let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in - let alp,sigma = bind_bindinglist_env alp sigma x decls in - match_in u alp metas sigma b termin - | _, _, NProd (Name _,_,_), _ when na1 != Anonymous -> - let (decls,b) = match_iterated_binders false [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in - (* TODO: address the possibility that termin is a Prod itself *) - let alp,sigma = bind_bindinglist_env alp sigma x decls in - match_in u alp metas sigma b termin - (* Matching recursive notations for binders: general case *) - | _, _, _, _ -> - match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin - end + | r1, NList (x,y,iter,termin,revert) -> + match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin revert (* Matching recursive notations for binders: general case *) - | _r, NBinderList (x,y,iter,termin) -> - match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin - - (* Matching individual binders as part of a recursive pattern *) - | GLambda (na1, bk, t1, b1), NLambda (na2, t2, b2) -> - begin match na1, DAst.get b1, na2 with - | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), Name id - when is_gvar p e && is_bindinglist_meta id metas && not (occur_glob_constr p b1) -> - let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] in - match_in u alp metas sigma b1 b2 - | _, _, Name id when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] in - match_in u alp metas sigma b1 b2 - | _ -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - end - - | GProd (na,bk,t,b1), NProd (Name id,_,b2) - when is_bindinglist_meta id metas && na != Anonymous -> - let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na,bk,t)] in - match_in u alp metas sigma b1 b2 + | _r, NBinderList (x,y,iter,termin,revert) -> + match_binderlist (match_hd u) alp metas sigma a1 x y iter termin revert (* Matching compositionally *) | GVar id1, NVar id2 when alpha_var id1 id2 (fst alp) -> sigma @@ -1092,8 +1133,10 @@ let rec match_ inner u alp metas sigma a1 a2 = let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_in u alp metas sigma f1 f2) l1 l2 - | GProd (na1,_,t1,b1), NProd (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + | GLambda (na1,bk1,t1,b1), NLambda (na2,t2,b2) -> + match_extended_binders false u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 + | GProd (na1,bk1,t1,b1), NProd (na2,t2,b2) -> + match_extended_binders true u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) | GLetIn (na1,b1,None,c1), NLetIn (na2,b2,_,c2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma b1 b2) c1 c2 @@ -1101,9 +1144,7 @@ let rec match_ inner u alp metas sigma a1 a2 = match_binders u alp metas na1 na2 (match_in u alp metas (match_in u alp metas sigma b1 b2) t1 t2) c1 c2 | GCases (sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2) - when sty1 == sty2 - && Int.equal (List.length tml1) (List.length tml2) - && Int.equal (List.length eqnl1) (List.length eqnl2) -> + when sty1 == sty2 && Int.equal (List.length tml1) (List.length tml2) -> let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in let rtno2' = abstract_return_type_context_notation_constr tml2 rtno2 in let sigma = @@ -1113,7 +1154,14 @@ let rec match_ inner u alp metas sigma a1 a2 = let sigma = List.fold_left2 (fun s (tm1,_) (tm2,_) -> match_in u alp metas s tm1 tm2) sigma tml1 tml2 in - List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2 + (* Try two different strategies for matching clauses *) + (try + List.fold_left2_set No_match (match_equations u alp metas) sigma eqnl1 eqnl2 + with + No_match -> + List.fold_left2_set No_match (match_disjunctive_equations u alp metas) sigma + (Detyping.factorize_eqns eqnl1) + (List.map (fun (patl,rhs) -> ([patl],rhs)) eqnl2)) | GLetTuple (nal1,(na1,to1),b1,c1), NLetTuple (nal2,(na2,to2),b2,c2) when Int.equal (List.length nal1) (List.length nal2) -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in @@ -1167,53 +1215,95 @@ let rec match_ inner u alp metas sigma a1 a2 = match_names metas (alp,sigma) (Name id') na in match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 + | GProj(p1, t1), NProj(p2, t2) when Projection.equal p1 p2 -> + match_in u alp metas sigma t1 t2 + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ - | GCast _), _ -> raise No_match + | GCast _ | GProj _ ), _ -> raise No_match and match_in u = match_ true u and match_hd u = match_ false u and match_binders u alp metas na1 na2 sigma b1 b2 = + (* Match binders which cannot be substituted by a pattern *) let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in match_in u alp metas sigma b1 b2 -and match_equations u alp metas sigma (_,(_,patl1,rhs1)) (patl2,rhs2) = +and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = + (* Match binders which can be substituted by a pattern *) + let store, get = set_temporary_memory () in + match na1, DAst.get b1, na2 with + (* Matching individual binders as part of a recursive pattern *) + | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id + when is_gvar p e && is_bindinglist_meta id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> + (match get () with + | [(_,(ids,disj_of_patl,b1))] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((disjpat,ids),p,bk,t)] in + match_in u alp metas sigma b1 b2 + | _ -> assert false) + | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id + when is_gvar p e && is_onlybinding_pattern_like_meta false id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> + (match get () with + | [(_,(ids,disj_of_patl,b1))] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in + let alp,sigma = bind_binding_env alp sigma id disjpat in + match_in u alp metas sigma b1 b2 + | _ -> assert false) + | _, _, Name id when is_bindinglist_meta id metas && (not isprod || na1 != Anonymous)-> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na1,bk,t)] in + match_in u alp metas sigma b1 b2 + | _, _, _ -> + let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in + match_in u alp metas sigma b1 b2 + +and match_equations u alp metas sigma (_,(ids,patl1,rhs1)) (patl2,rhs2) rest1 rest2 = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) + let allow_catchall = (rest2 = [] && ids = []) in let (alp,sigma) = - List.fold_left2 (match_cases_pattern_binders metas) + List.fold_left2 (match_cases_pattern_binders allow_catchall metas) (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 -let term_of_binder bi = DAst.make @@ match bi with - | Name id -> GVar id - | Anonymous -> GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) +and match_disjunctive_equations u alp metas sigma (_,(ids,disjpatl1,rhs1)) (disjpatl2,rhs2) _ _ = + (* patl1 and patl2 have the same length because they respectively + correspond to some tml1 and tml2 that have the same length *) + let (alp,sigma) = + List.fold_left2_set No_match + (fun alp_sigma patl1 patl2 _ _ -> + List.fold_left2 (match_cases_pattern_binders false metas) alp_sigma patl1 patl2) + (alp,sigma) disjpatl1 disjpatl2 in + match_in u alp metas sigma rhs1 rhs2 let match_notation_constr u c (metas,pat) = - let terms,binders,termlists,binderlists = + let terms,termlists,binders,binderlists = match_ false u ([],[]) metas ([],[],[],[]) c pat in - (* Reorder canonically the substitution *) - let find_binder x = - try term_of_binder (Id.List.assoc x binders) - with Not_found -> - (* Happens for binders bound to Anonymous *) - (* Find a better way to propagate Anonymous... *) - DAst.make @@GVar x in - List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> + (* Turning substitution based on binding/constr distinction into a + substitution based on entry productions *) + List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders',binderlists') -> match typ with | NtnTypeConstr -> let term = try Id.List.assoc x terms with Not_found -> raise No_match in - ((term, scl)::terms',termlists',binders') - | NtnTypeOnlyBinder -> - ((find_binder x, scl)::terms',termlists',binders') + ((term, scl)::terms',termlists',binders',binderlists') + | NtnTypeBinder (NtnBinderParsedAsConstr _) -> + (match Id.List.assoc x binders with + | [pat] -> + let v = glob_constr_of_cases_pattern pat in + ((v,scl)::terms',termlists',binders',binderlists') + | _ -> raise No_match) + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _) -> + (terms',termlists',(Id.List.assoc x binders,scl)::binders',binderlists') | NtnTypeConstrList -> - (terms',(Id.List.assoc x termlists,scl)::termlists',binders') + (terms',(Id.List.assoc x termlists,scl)::termlists',binders',binderlists') | NtnTypeBinderList -> let bl = try Id.List.assoc x binderlists with Not_found -> raise No_match in - (terms',termlists',(bl, scl)::binders')) - metas ([],[],[]) + (terms',termlists',binders',(bl, scl)::binderlists')) + metas ([],[],[],[]) (* Matching cases pattern *) @@ -1225,7 +1315,7 @@ let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = (* TODO: handle the case of multiple occs in different scopes *) (var,v)::terms,x,termlists,y -let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = +let match_cases_pattern_list match_fun metas sigma rest x y iter termin revert = let rec aux sigma acc rest = try let metas = add_ldots_var (add_meta_term y metas) in @@ -1236,10 +1326,10 @@ let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = aux sigma (t::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in - let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in - (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) + let l,(terms,termlists,binders,binderlists as sigma) = aux sigma [] rest in + (terms,(x,if revert then l else List.rev l)::termlists,binders,binderlists) -let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = +let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) @@ -1255,10 +1345,10 @@ let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = raise No_match else let l1',more_args = Util.List.chop le2 l1 in - (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) - | r1, NList (x,y,iter,termin,lassoc) -> + (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) + | r1, NList (x,y,iter,termin,revert) -> (match_cases_pattern_list (match_cases_pattern_no_more_args) - metas (terms,(),termlists,()) a1 x y iter termin lassoc),(0,[]) + metas (terms,termlists,(),()) a1 x y iter termin revert),(0,[]) | _ -> raise No_match and match_cases_pattern_no_more_args metas sigma a1 a2 = @@ -1285,15 +1375,15 @@ let reorder_canonically_substitution terms termlists metas = List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> match typ with | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists') - | NtnTypeOnlyBinder -> assert false + | NtnTypeBinder _ -> assert false | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') | NtnTypeBinderList -> assert false) metas ([],[]) let match_notation_constr_cases_pattern c (metas,pat) = - let (terms,(),termlists,()),more_args = match_cases_pattern metas ([],(),[],()) c pat in + let (terms,termlists,(),()),more_args = match_cases_pattern metas ([],[],(),()) c pat in reorder_canonically_substitution terms termlists metas, more_args let match_notation_constr_ind_pattern ind args (metas,pat) = - let (terms,(),termlists,()),more_args = match_ind_pattern metas ([],(),[],()) ind args pat in + let (terms,termlists,(),()),more_args = match_ind_pattern metas ([],[],(),()) ind args pat in reorder_canonically_substitution terms termlists metas, more_args diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 0904a4ea3..746f52e48 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -29,12 +29,15 @@ val ldots_var : Id.t bound by the notation; also interpret recursive patterns *) val notation_constr_of_glob_constr : notation_interp_env -> - glob_constr -> notation_constr * reversibility_flag + glob_constr -> notation_constr * reversibility_status (** Re-interpret a notation as a [glob_constr], taking care of binders *) +val apply_cases_pattern : ?loc:Loc.t -> + (Id.t list * cases_pattern_disjunction) * Id.t -> glob_constr -> glob_constr + val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> - ('a -> Name.t -> 'a * Name.t) -> + ('a -> Name.t -> 'a * ((Id.t list * cases_pattern_disjunction) * Id.t) option * Name.t) -> ('a -> notation_constr -> glob_constr) -> 'a -> notation_constr -> glob_constr @@ -49,6 +52,7 @@ exception No_match val match_notation_constr : bool -> 'a glob_constr_g -> interpretation -> ('a glob_constr_g * subscopes) list * ('a glob_constr_g list * subscopes) list * + ('a cases_pattern_disjunction_g * subscopes) list * ('a extended_glob_local_binder_g list * subscopes) list val match_notation_constr_cases_pattern : diff --git a/interp/ppextend.ml b/interp/ppextend.ml index ce19dd8a9..606196fcd 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -33,6 +33,7 @@ let ppcmd_of_cut = function type unparsing = | UnpMetaVar of int * parenRelation + | UnpBinderMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 7b62a2074..77823e32a 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -26,6 +26,7 @@ val ppcmd_of_cut : ppcut -> Pp.t type unparsing = | UnpMetaVar of int * parenRelation + | UnpBinderMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string diff --git a/interp/reserve.ml b/interp/reserve.ml index 22c5a2f5e..04710282f 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -71,7 +71,7 @@ let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev" let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) + | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) | NRef ref -> RefKey(canonical_gr ref), None | _ -> Oth, None diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml index e0d2d7bf4..c59828794 100644 --- a/intf/constrexpr.ml +++ b/intf/constrexpr.ml @@ -46,7 +46,7 @@ type prim_token = type instance_expr = Misctypes.glob_level list type cases_pattern_expr_r = - | CPatAlias of cases_pattern_expr * Id.t + | CPatAlias of cases_pattern_expr * Name.t Loc.located | CPatCstr of reference * cases_pattern_expr list option * cases_pattern_expr list (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) @@ -70,8 +70,8 @@ and constr_expr_r = | CRef of reference * instance_expr option | CFix of Id.t Loc.located * fix_expr list | CCoFix of Id.t Loc.located * cofix_expr list - | CProdN of binder_expr list * constr_expr - | CLambdaN of binder_expr list * constr_expr + | CProdN of local_binder_expr list * constr_expr + | CLambdaN of local_binder_expr list * constr_expr | CLetIn of Name.t Loc.located * constr_expr * constr_expr option * constr_expr | CAppExpl of (proj_flag * reference * instance_expr option) * constr_expr list | CApp of (proj_flag * constr_expr) * @@ -97,6 +97,7 @@ and constr_expr_r = | CGeneralization of binding_kind * abstraction_kind option * constr_expr | CPrim of prim_token | CDelimiters of string * constr_expr + | CProj of reference * constr_expr and constr_expr = constr_expr_r CAst.t and case_expr = constr_expr (* expression that is being matched *) @@ -104,10 +105,7 @@ and case_expr = constr_expr (* expression that is being matched * cases_pattern_expr option (* in-clause *) and branch_expr = - (cases_pattern_expr list Loc.located list * constr_expr) Loc.located - -and binder_expr = - Name.t Loc.located list * binder_kind * constr_expr + (cases_pattern_expr list list * constr_expr) Loc.located and fix_expr = Id.t Loc.located * (Id.t Loc.located option * recursion_order_expr) * @@ -130,7 +128,8 @@ and local_binder_expr = and constr_notation_substitution = constr_expr list * (** for constr subterms *) constr_expr list list * (** for recursive notations *) - local_binder_expr list list (** for binders subexpressions *) + cases_pattern_expr list * (** for binders *) + local_binder_expr list list (** for binder lists (recursive notations) *) type constr_pattern_expr = constr_expr diff --git a/intf/decl_kinds.ml b/intf/decl_kinds.ml index a97758833..b9a3f0c21 100644 --- a/intf/decl_kinds.ml +++ b/intf/decl_kinds.ml @@ -8,6 +8,8 @@ (** Informal mathematical status of declarations *) +type discharge = DoDischarge | NoDischarge + type locality = Discharge | Local | Global type binding_kind = Explicit | Implicit @@ -40,6 +42,7 @@ type definition_object_kind = | IdentityCoercion | Instance | Method + | Let type assumption_object_kind = Definitional | Logical | Conjectural @@ -72,7 +75,11 @@ type logical_kind = (** Recursive power of type declarations *) -type recursivity_kind = +type recursivity_kind = Declarations.recursivity_kind = | Finite (** = inductive *) + [@ocaml.deprecated "Please use [Declarations.Finite"] | CoFinite (** = coinductive *) + [@ocaml.deprecated "Please use [Declarations.CoFinite"] | BiFinite (** = non-recursive, like in "Record" definitions *) + [@ocaml.deprecated "Please use [Declarations.BiFinite"] +[@@ocaml.deprecated "Please use [Declarations.recursivity_kind"] diff --git a/intf/extend.ml b/intf/extend.ml index 5552bed55..78f0aa117 100644 --- a/intf/extend.ml +++ b/intf/extend.ml @@ -29,29 +29,48 @@ type production_level = | NextLevel | NumLevel of int -type ('lev,'pos) constr_entry_key_gen = - | ETName | ETReference | ETBigint - | ETBinder of bool - | ETConstr of ('lev * 'pos) - | ETPattern +type constr_as_binder_kind = + | AsIdent + | AsIdentOrPattern + | AsStrictPattern + +(** User-level types used to tell how to parse or interpret of the non-terminal *) + +type 'a constr_entry_key_gen = + | ETName + | ETReference + | ETBigint + | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) + | ETConstr of 'a + | ETConstrAsBinder of constr_as_binder_kind * 'a + | ETPattern of bool * int option (* true = strict pattern, i.e. not a single variable *) | ETOther of string * string - | ETConstrList of ('lev * 'pos) * Tok.t list - | ETBinderList of bool * Tok.t list -(** Entries level (left-hand-side of grammar rules) *) +(** Entries level (left-hand side of grammar rules) *) type constr_entry_key = - (int,unit) constr_entry_key_gen - -(** Entries used in productions (in right-hand-side of grammar rules) *) - -type constr_prod_entry_key = - (production_level,production_position) constr_entry_key_gen + (production_level * production_position) constr_entry_key_gen (** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) type simple_constr_prod_entry_key = - (production_level,unit) constr_entry_key_gen + production_level option constr_entry_key_gen + +(** Entries used in productions (in right-hand-side of grammar rules), to parse non-terminals *) + +type binder_entry_kind = ETBinderOpen | ETBinderClosed of Tok.t list + +type binder_target = ForBinder | ForTerm + +type constr_prod_entry_key = + | ETProdName (* Parsed as a name (ident or _) *) + | ETProdReference (* Parsed as a global reference *) + | ETProdBigint (* Parsed as an (unbounded) integer *) + | ETProdConstr of (production_level * production_position) (* Parsed as constr or pattern *) + | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) + | ETProdOther of string * string (* Intended for embedding custom entries in constr or pattern *) + | ETProdConstrList of (production_level * production_position) * Tok.t list (* Parsed as non-empty list of constr *) + | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) (** {5 AST for user-provided entries} *) diff --git a/intf/glob_term.ml b/intf/glob_term.ml index 72c91db6a..3f48fa547 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -55,6 +55,7 @@ type 'a glob_constr_r = | GSort of glob_sort | GHole of Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type + | GProj of Projection.t * 'a glob_constr_g and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g @@ -93,10 +94,18 @@ type fix_recursion_order = [ `any ] fix_recursion_order_g type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr +type 'a disjunctive_cases_clause_g = (Id.t list * 'a cases_pattern_g list list * 'a glob_constr_g) Loc.located +type 'a disjunctive_cases_clauses_g = 'a disjunctive_cases_clause_g list +type 'a cases_pattern_disjunction_g = 'a cases_pattern_g list + +type disjunctive_cases_clause = [ `any ] disjunctive_cases_clause_g +type disjunctive_cases_clauses = [ `any ] disjunctive_cases_clauses_g +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 - | GLocalPattern of ('a cases_pattern_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g + | 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 type extended_glob_local_binder = [ `any ] extended_glob_local_binder_g diff --git a/intf/intf.mllib b/intf/intf.mllib index 38a2a71cc..2b8960d3f 100644 --- a/intf/intf.mllib +++ b/intf/intf.mllib @@ -2,9 +2,9 @@ Constrexpr Evar_kinds Genredexpr Locus +Extend Notation_term Decl_kinds -Extend Glob_term Misctypes Pattern diff --git a/intf/misctypes.ml b/intf/misctypes.ml index 87484ccd5..33e961419 100644 --- a/intf/misctypes.ml +++ b/intf/misctypes.ml @@ -48,13 +48,19 @@ type 'a glob_sort_gen = | GProp (** representation of [Prop] literal *) | GSet (** representation of [Set] literal *) | GType of 'a (** representation of [Type] literal *) -type sort_info = Name.t Loc.located list -type level_info = Name.t Loc.located option -type glob_sort = sort_info glob_sort_gen +type 'a universe_kind = + | UAnonymous + | UUnknown + | UNamed of 'a + +type level_info = Libnames.reference universe_kind type glob_level = level_info glob_sort_gen type glob_constraint = glob_level * Univ.constraint_type * glob_level +type sort_info = (Libnames.reference * int) option list +type glob_sort = sort_info glob_sort_gen + (** A synonym of [Evar.t], also defined in Term *) type existential_key = Evar.t diff --git a/intf/notation_term.ml b/intf/notation_term.ml index 7823d3feb..86f5adbd7 100644 --- a/intf/notation_term.ml +++ b/intf/notation_term.ml @@ -25,11 +25,11 @@ type notation_constr = | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | NList of Id.t * Id.t * notation_constr * notation_constr * bool + | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool (** Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr | NProd of Name.t * notation_constr * notation_constr - | NBinderList of Id.t * Id.t * notation_constr * notation_constr + | NBinderList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool | NLetIn of Name.t * notation_constr * notation_constr option * notation_constr | NCases of Constr.case_style * notation_constr option * (notation_constr * (Name.t * (inductive * Name.t list) option)) list * @@ -43,6 +43,7 @@ type notation_constr = notation_constr array * notation_constr array | NSort of glob_sort | NCast of notation_constr * notation_constr cast_type + | NProj of Projection.t * notation_constr (** Note concerning NList: first constr is iterator, second is terminator; first id is where each argument of the list has to be substituted @@ -59,21 +60,31 @@ type subscopes = tmp_scope_name option * scope_name list (** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, x carries the sequence of objects bound to the list x..y *) + +type notation_binder_source = + (* This accepts only pattern *) + (* NtnParsedAsPattern true means only strict pattern (no single variable) at printing *) + | NtnParsedAsPattern of bool + (* This accepts only ident *) + | NtnParsedAsIdent + (* This accepts ident, or pattern, or both *) + | NtnBinderParsedAsConstr of Extend.constr_as_binder_kind + type notation_var_instance_type = - | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList + | NtnTypeConstr | NtnTypeBinder of notation_binder_source | NtnTypeConstrList | NtnTypeBinderList -(** Type of variables when interpreting a constr_expr as an notation_constr: +(** Type of variables when interpreting a constr_expr as a notation_constr: in a recursive pattern x..y, both x and y carry the individual type of each element of the list x..y *) type notation_var_internalization_type = - | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent + | NtnInternTypeAny | NtnInternTypeOnlyBinder (** This characterizes to what a notation is interpreted to *) type interpretation = (Id.t * (subscopes * notation_var_instance_type)) list * notation_constr -type reversibility_flag = bool +type reversibility_status = APrioriReversible | HasLtac | NonInjective of Id.t list type notation_interp_env = { ninterp_var_type : notation_var_internalization_type Id.Map.t; @@ -94,7 +105,7 @@ type precedence = int type parenRelation = L | E | Any | Prec of precedence type tolerability = precedence * parenRelation -type level = precedence * tolerability list * notation_var_internalization_type list +type level = precedence * tolerability list * Extend.constr_entry_key list (** Grammar rules for a notation *) diff --git a/intf/pattern.ml b/intf/pattern.ml index 20636accf..64873a039 100644 --- a/intf/pattern.ml +++ b/intf/pattern.ml @@ -26,7 +26,7 @@ type constr_pattern = | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list - | PProj of projection * constr_pattern + | PProj of Projection.t * constr_pattern | PLambda of Name.t * constr_pattern * constr_pattern | PProd of Name.t * constr_pattern * constr_pattern | PLetIn of Name.t * constr_pattern * constr_pattern option * constr_pattern diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 96bcba5e8..d16c9bb80 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -145,16 +145,12 @@ type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) -type inductive_flag = Decl_kinds.recursivity_kind +type inductive_flag = Declarations.recursivity_kind type onlyparsing_flag = Flags.compat_version option (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version which this notation is trying to be compatible with *) type locality_flag = bool (* true = Local *) -type obsolete_locality = bool -(* Some grammar entries use obsolete_locality. This bool is to be backward - * compatible. If the grammar is fixed removing deprecated syntax, this - * bool should go away too *) type option_value = Goptions.option_value = | BoolValue of bool @@ -171,6 +167,7 @@ type option_ref_value = type universe_decl_expr = (Id.t Loc.located list, glob_constraint list) gen_universe_decl type ident_decl = lident * universe_decl_expr option +type name_decl = lname * universe_decl_expr option type sort_expr = Sorts.family @@ -208,15 +205,16 @@ type inductive_expr = type one_inductive_expr = ident_decl * local_binder_expr list * constr_expr option * constructor_expr list -type typeclass_constraint = (Name.t Loc.located * universe_decl_expr option) * binding_kind * constr_expr +type typeclass_constraint = name_decl * binding_kind * constr_expr and typeclass_context = typeclass_constraint list type proof_expr = - ident_decl option * (local_binder_expr list * constr_expr) + ident_decl * (local_binder_expr list * constr_expr) type syntax_modifier = | SetItemLevel of string list * Extend.production_level + | SetItemLevelAsBinder of string list * Extend.constr_as_binder_kind * Extend.production_level option | SetLevel of int | SetAssoc of Extend.gram_assoc | SetEntryType of string * Extend.simple_constr_prod_entry_key @@ -318,40 +316,40 @@ type cumulative_inductive_parsing_flag = (** {6 The type of vernacular expressions} *) -type vernac_expr = - (* Control *) - | VernacLoad of verbose_flag * string - | VernacTime of vernac_expr located - | VernacRedirect of string * vernac_expr located - | VernacTimeout of int * vernac_expr - | VernacFail of vernac_expr +type vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit +type vernac_argument_status = { + name : Name.t; + recarg_like : bool; + notation_scope : string Loc.located option; + implicit_status : vernac_implicit_status; +} + +type nonrec vernac_expr = + + | VernacLoad of verbose_flag * string (* Syntax *) - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) + | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) + | VernacOpenCloseScope of bool * scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * + | VernacInfix of (lstring * syntax_modifier list) * constr_expr * scope_name option | VernacNotation of - obsolete_locality * constr_expr * (lstring * syntax_modifier list) * + constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string (* Gallina *) - | VernacDefinition of - (locality option * definition_object_kind) * ident_decl * definition_expr + | VernacDefinition of (discharge * definition_object_kind) * name_decl * definition_expr | VernacStartTheoremProof of theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr - | VernacAssumption of (locality option * assumption_object_kind) * + | VernacAssumption of (discharge * assumption_object_kind) * inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list - | VernacFixpoint of - locality option * (fixpoint_expr * decl_notation list) list - | VernacCoFixpoint of - locality option * (cofixpoint_expr * decl_notation list) list + | VernacFixpoint of discharge * (fixpoint_expr * decl_notation list) list + | VernacCoFixpoint of discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -364,10 +362,9 @@ type vernac_expr = reference option * export_flag option * reference list | VernacImport of export_flag * reference list | VernacCanonical of reference or_by_notation - | VernacCoercion of obsolete_locality * reference or_by_notation * - class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * + | VernacCoercion of reference or_by_notation * class_rawexpr * class_rawexpr + | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) @@ -418,9 +415,9 @@ type vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list - | VernacHints of obsolete_locality * string list * hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of Id.t located * (Id.t list * constr_expr) * - obsolete_locality * onlyparsing_flag + onlyparsing_flag | VernacDeclareImplicits of reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of reference or_by_notation * @@ -454,7 +451,6 @@ type vernac_expr = | VernacComments of comment list (* Proof management *) - | VernacGoal of constr_expr | VernacAbort of lident option | VernacAbortAll | VernacRestart @@ -465,7 +461,7 @@ type vernac_expr = | VernacUnfocus | VernacUnfocused | VernacBullet of bullet - | VernacSubproof of int option + | VernacSubproof of goal_selector option | VernacEndSubproof | VernacShow of showable | VernacCheckGuard @@ -477,32 +473,53 @@ type vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list - (* Flags *) - | VernacProgram of vernac_expr - | VernacPolymorphic of bool * vernac_expr - | VernacLocal of bool * vernac_expr +type nonrec vernac_flag = + | VernacProgram + | VernacPolymorphic of bool + | VernacLocal of bool -and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit +type vernac_control = + | VernacExpr of vernac_flag list * vernac_expr + (* boolean is true when the `-time` batch-mode command line flag was set. + the flag is used to print differently in `-time` vs `Time foo` *) + | VernacTime of bool * vernac_control located + | VernacRedirect of string * vernac_control located + | VernacTimeout of int * vernac_control + | VernacFail of vernac_control -and vernac_argument_status = { - name : Name.t; - recarg_like : bool; - notation_scope : string Loc.located option; - implicit_status : vernac_implicit_status; -} +(* A vernac classifier provides information about the exectuion of a + command: + + - vernac_when: encodes if the vernac may alter the parser [thus + forcing immediate execution], or if indeed it is pure and parsing + can continue without its execution. -(* A vernac classifier has to tell if a command: - vernac_when: has to be executed now (alters the parser) or later - vernac_type: if it is starts, ends, continues a proof or + - vernac_type: if it is starts, ends, continues a proof or alters the global state or is a control command like BackTo or is - a query like Check *) + a query like Check. + + The classification works on the assumption that we have 3 states: + parsing, execution (global enviroment, etc...), and proof + state. For example, commands that only alter the proof state are + considered safe to delegate to a worker. + +*) type vernac_type = + (* Start of a proof *) | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) | VtSideff of vernac_sideff_type + (* End of a proof *) | VtQed of vernac_qed_type + (* A proof step *) | VtProofStep of proof_step + (* To be removed *) | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) | VtQuery of vernac_part_of_script * Feedback.route_id + (* To be removed *) | VtMeta | VtUnknown and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 31ded9129..219ea5b24 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -91,6 +91,7 @@ module type RedFlagsSig = sig val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds val red_add_transparent : reds -> transparent_state -> reds + val red_transparent : reds -> transparent_state val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool val red_projection : reds -> projection -> bool @@ -164,6 +165,8 @@ module RedFlags = (struct let (l1,l2) = red.r_const in { red with r_const = Id.Pred.remove id l1, l2 } + let red_transparent red = red.r_const + let red_add_transparent red tr = { red with r_const = tr } @@ -258,7 +261,7 @@ type 'a infos_cache = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; - i_rels : constr option array; + i_rels : (Context.Rel.Declaration.t * Pre_env.lazy_val) Range.t; i_tab : 'a KeyTable.t } and 'a infos = { @@ -282,13 +285,16 @@ let ref_value_cache ({i_cache = cache} as infos) ref = let body = match ref with | RelKey n -> - let len = Array.length cache.i_rels in - let i = n - 1 in - let () = if i < 0 || len <= i then raise Not_found in - begin match Array.unsafe_get cache.i_rels i with - | None -> raise Not_found - | Some t -> lift n t - end + let open Context.Rel.Declaration in + let i = n - 1 in + let (d, _) = + try Range.get cache.i_rels i + with Invalid_argument _ -> raise Not_found + in + begin match d with + | LocalAssum _ -> raise Not_found + | LocalDef (_, t, _) -> lift n t + end | VarKey id -> assoc_defined id cache.i_env | ConstKey cst -> constant_value_in cache.i_env cst in @@ -303,26 +309,13 @@ let ref_value_cache ({i_cache = cache} as infos) ref = let evar_value cache ev = cache.i_sigma ev -let defined_rels flags env = -(* if red_local_const (snd flags) then*) - let ctx = rel_context env in - let len = List.length ctx in - let ans = Array.make len None in - let open Context.Rel.Declaration in - let iter i = function - | LocalAssum _ -> () - | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) - in - let () = List.iteri iter ctx in - ans -(* else (0,[])*) - let create mk_cl flgs env evars = + let open Pre_env in let cache = { i_repr = mk_cl; i_env = env; i_sigma = evars; - i_rels = defined_rels flgs env; + i_rels = (Environ.pre_env env).env_rel_context.env_rel_map; i_tab = KeyTable.create 17 } in { i_flags = flgs; i_cache = cache } @@ -810,7 +803,7 @@ let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with | Some (Some (_,projs,pbs)) when - mib.Declarations.mind_finite == Decl_kinds.BiFinite -> + mib.Declarations.mind_finite == Declarations.BiFinite -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in @@ -857,6 +850,14 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) +let unfold_projection info p = + if red_projection info.i_flags p + then + let open Declarations in + let pb = lookup_projection p (info_env info) in + Some (Zproj (pb.proj_npars, pb.proj_arg, Projection.constant p)) + else None + (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, @@ -875,15 +876,9 @@ let rec knh info m stk = | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> - let unf = Projection.unfolded p in - if unf || red_set info.i_flags (fCONST (Projection.constant p)) then - (match try Some (lookup_projection p (info_env info)) with Not_found -> None with - | None -> (m, stk) - | Some pb -> - knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - Projection.constant p) - :: zupdate m stk)) - else (m,stk) + (match unfold_projection info p with + | None -> (m, stk) + | Some s -> knh info c (s :: zupdate m stk)) (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 119b70e30..c43fc4623 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -61,6 +61,9 @@ module type RedFlagsSig = sig (** Adds a reduction kind to a set *) val red_add_transparent : reds -> transparent_state -> reds + (** Retrieve the transparent state of the reduction flags *) + val red_transparent : reds -> transparent_state + (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds @@ -163,6 +166,7 @@ val stack_tail : int -> stack -> stack val stack_nth : stack -> int -> fconstr val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack +val unfold_projection : 'a infos -> Projection.t -> stack_member option (** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 9febc6449..6d91c3ec9 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -45,6 +45,55 @@ type reloc_table = (tag * int) array type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} +let rec eq_structured_constant c1 c2 = match c1, c2 with +| Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 +| Const_sorts _, _ -> false +| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind _, _ -> false +| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 +| Const_proj _, _ -> false +| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 +| Const_b0 _, _ -> false +| Const_bn (t1, a1), Const_bn (t2, a2) -> + Int.equal t1 t2 && CArray.equal eq_structured_constant a1 a2 +| Const_bn _, _ -> false +| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 +| Const_univ_level _ , _ -> false +| Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 +| Const_type _ , _ -> false + +let rec hash_structured_constant c = + let open Hashset.Combine in + match c with + | Const_sorts s -> combinesmall 1 (Sorts.hash s) + | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_proj p -> combinesmall 3 (Constant.hash p) + | Const_b0 t -> combinesmall 4 (Int.hash t) + | Const_bn (t, a) -> + let fold h c = combine h (hash_structured_constant c) in + let h = Array.fold_left fold 0 a in + combinesmall 5 (combine (Int.hash t) h) + | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) + | Const_type u -> combinesmall 7 (Univ.Universe.hash u) + +let eq_annot_switch asw1 asw2 = + let eq_ci ci1 ci2 = + eq_ind ci1.ci_ind ci2.ci_ind && + Int.equal ci1.ci_npar ci2.ci_npar && + CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls + in + let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in + eq_ci asw1.ci asw2.ci && + CArray.equal eq_rlc asw1.rtbl asw2.rtbl && + (asw1.tailcall : bool) == asw2.tailcall + +let hash_annot_switch asw = + let open Hashset.Combine in + let h1 = Constr.case_info_hash asw.ci in + let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in + let h3 = if asw.tailcall then 1 else 0 in + combine3 h1 h2 h3 + module Label = struct type t = int diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 5d37a5840..bf2e462e8 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -41,6 +41,12 @@ type reloc_table = (tag * int) array type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} +val eq_structured_constant : structured_constant -> structured_constant -> bool +val hash_structured_constant : structured_constant -> int + +val eq_annot_switch : annot_switch -> annot_switch -> bool +val hash_annot_switch : annot_switch -> int + module Label : sig type t = int diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 5dab2932d..4a34dbcff 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -628,27 +628,17 @@ let rec compile_constr reloc c sz cont = of the structured constant, while the later (if any) will be applied as arguments. *) let open Univ in begin - let levels = Universe.levels u in - let global_levels = - LSet.filter (fun x -> Level.var_index x = None) levels - in - let local_levels = - List.map_filter (fun x -> Level.var_index x) - (LSet.elements levels) - in + let u,s = Universe.compact u in (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) - let uglob = - LSet.fold (fun lvl u -> Universe.sup u (Universe.make lvl)) global_levels Universe.type0m - in - if local_levels = [] then - compile_str_cst reloc (Bstrconst (Const_sorts (Sorts.Type uglob))) sz cont + if List.is_empty s then + compile_str_cst reloc (Bstrconst (Const_sorts (Sorts.Type u))) sz cont else let compile_get_univ reloc idx sz cont = set_max_stack_size sz; compile_fv_elem reloc (FVuniv_var idx) sz cont in comp_app compile_str_cst compile_get_univ reloc - (Bstrconst (Const_type u)) (Array.of_list local_levels) sz cont + (Bstrconst (Const_type u)) (Array.of_list s) sz cont end | LetIn(_,xb,_,body) -> compile_constr reloc xb sz diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index eeea19c12..856b0b465 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -10,18 +10,51 @@ machine, Oct 2004 *) (* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *) +open Names open Term open Cbytecodes open Copcodes open Mod_subst +type emitcodes = String.t + +external tcode_of_code : Bytes.t -> int -> Vmvalues.tcode = "coq_tcode_of_code" + (* Relocation information *) type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Names.Constant.t -type patch = reloc_info * int +let eq_reloc_info r1 r2 = match r1, r2 with +| Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 +| Reloc_annot _, _ -> false +| Reloc_const c1, Reloc_const c2 -> eq_structured_constant c1 c2 +| Reloc_const _, _ -> false +| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 +| Reloc_getglobal _, _ -> false + +let hash_reloc_info r = + let open Hashset.Combine in + match r with + | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) + | Reloc_const c -> combinesmall 2 (hash_structured_constant c) + | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) + +module RelocTable = Hashtbl.Make(struct + type t = reloc_info + let equal = eq_reloc_info + let hash = hash_reloc_info +end) + +(** We use arrays for on-disk representation. On 32-bit machines, this means we + can only have a maximum amount of about 4.10^6 relocations, which seems + quite a lot, but potentially reachable if e.g. compiling big proofs. This + would prevent VM computing with these terms on 32-bit architectures. Maybe + we should use a more robust data structure? *) +type patches = { + reloc_infos : (reloc_info * int array) array; +} let patch_char4 buff pos c1 c2 c3 c4 = Bytes.unsafe_set buff pos c1; @@ -29,40 +62,48 @@ let patch_char4 buff pos c1 c2 c3 c4 = Bytes.unsafe_set buff (pos + 2) c3; Bytes.unsafe_set buff (pos + 3) c4 -let patch buff (pos, n) = +let patch1 buff pos n = patch_char4 buff pos (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) (Char.unsafe_chr (n asr 24)) -(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *) -let patch_int buff patches = +let patch_int buff reloc = (* copy code *before* patching because of nested evaluations: the code we are patching might be called (and thus "concurrently" patched) and results in wrong results. Side-effects... *) let buff = Bytes.of_string buff in - let () = List.iter (fun p -> patch buff p) patches in - (* Note: we follow the apporach suggested by Gabriel Scherer in - PR#136 here, and use unsafe as we own buff. + let iter (reloc, npos) = Array.iter (fun pos -> patch1 buff pos reloc) npos in + let () = CArray.iter iter reloc in + buff - The crux of the question that avoids defining emitcodes just as a - Byte.t is the call to hcons in to_memory below. Even if disabling - this optimization has no visible time impact, test data shows - that the optimization is indeed triggered quite often so we - choose ugliness over altering the semantics. - - Handle with care. - *) - Bytes.unsafe_to_string buff +let patch buff pl f = + (** Order seems important here? *) + let reloc = CArray.map (fun (r, pos) -> (f r, pos)) pl.reloc_infos in + let buff = patch_int buff reloc in + tcode_of_code buff (Bytes.length buff) (* Buffering of bytecode *) -let out_buffer = ref(Bytes.create 1024) -and out_position = ref 0 +type label_definition = + Label_defined of int + | Label_undefined of (int * int) list -let out_word b1 b2 b3 b4 = - let p = !out_position in - if p >= Bytes.length !out_buffer then begin - let len = Bytes.length !out_buffer in +type env = { + mutable out_buffer : Bytes.t; + mutable out_position : int; + mutable label_table : label_definition array; + (* le ieme element de la table = Label_defined n signifie que l'on a + deja rencontrer le label i et qu'il est a l'offset n. + = Label_undefined l signifie que l'on a + pas encore rencontrer ce label, le premier entier indique ou est l'entier + a patcher dans la string, le deuxieme son origine *) + reloc_info : int list RelocTable.t; +} + +let out_word env b1 b2 b3 b4 = + let p = env.out_position in + if p >= Bytes.length env.out_buffer then begin + let len = Bytes.length env.out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len @@ -71,260 +112,240 @@ let out_word b1 b2 b3 b4 = then invalid_arg "String.create" (* Pas la bonne exception .... *) else Sys.max_string_length in let new_buffer = Bytes.create new_len in - Bytes.blit !out_buffer 0 new_buffer 0 len; - out_buffer := new_buffer + Bytes.blit env.out_buffer 0 new_buffer 0 len; + env.out_buffer <- new_buffer end; - patch_char4 !out_buffer p (Char.unsafe_chr b1) + patch_char4 env.out_buffer p (Char.unsafe_chr b1) (Char.unsafe_chr b2) (Char.unsafe_chr b3) (Char.unsafe_chr b4); - out_position := p + 4 + env.out_position <- p + 4 -let out opcode = - out_word opcode 0 0 0 +let out env opcode = + out_word env opcode 0 0 0 -let out_int n = - out_word n (n asr 8) (n asr 16) (n asr 24) +let out_int env n = + out_word env n (n asr 8) (n asr 16) (n asr 24) (* Handling of local labels and backpatching *) -type label_definition = - Label_defined of int - | Label_undefined of (int * int) list - -let label_table = ref ([| |] : label_definition array) -(* le ieme element de la table = Label_defined n signifie que l'on a - deja rencontrer le label i et qu'il est a l'offset n. - = Label_undefined l signifie que l'on a - pas encore rencontrer ce label, le premier entier indique ou est l'entier - a patcher dans la string, le deuxieme son origine *) - -let extend_label_table needed = - let new_size = ref(Array.length !label_table) in +let extend_label_table env needed = + let new_size = ref(Array.length env.label_table) in while needed >= !new_size do new_size := 2 * !new_size done; let new_table = Array.make !new_size (Label_undefined []) in - Array.blit !label_table 0 new_table 0 (Array.length !label_table); - label_table := new_table - -let backpatch (pos, orig) = - let displ = (!out_position - orig) asr 2 in - Bytes.set !out_buffer pos @@ Char.unsafe_chr displ; - Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); - Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); - Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) - -let define_label lbl = - if lbl >= Array.length !label_table then extend_label_table lbl; - match (!label_table).(lbl) with + Array.blit env.label_table 0 new_table 0 (Array.length env.label_table); + env.label_table <- new_table + +let backpatch env (pos, orig) = + let displ = (env.out_position - orig) asr 2 in + Bytes.set env.out_buffer pos @@ Char.unsafe_chr displ; + Bytes.set env.out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); + Bytes.set env.out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); + Bytes.set env.out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) + +let define_label env lbl = + if lbl >= Array.length env.label_table then extend_label_table env lbl; + match (env.label_table).(lbl) with Label_defined _ -> raise(Failure "CEmitcode.define_label") | Label_undefined patchlist -> - List.iter backpatch patchlist; - (!label_table).(lbl) <- Label_defined !out_position + List.iter (fun p -> backpatch env p) patchlist; + (env.label_table).(lbl) <- Label_defined env.out_position -let out_label_with_orig orig lbl = - if lbl >= Array.length !label_table then extend_label_table lbl; - match (!label_table).(lbl) with +let out_label_with_orig env orig lbl = + if lbl >= Array.length env.label_table then extend_label_table env lbl; + match (env.label_table).(lbl) with Label_defined def -> - out_int((def - orig) asr 2) + out_int env ((def - orig) asr 2) | Label_undefined patchlist -> (* spiwack: patchlist is supposed to be non-empty all the time thus I commented that out. If there is no problem I suggest removing it for next release (cur: 8.1) *) (*if patchlist = [] then *) - (!label_table).(lbl) <- - Label_undefined((!out_position, orig) :: patchlist); - out_int 0 + (env.label_table).(lbl) <- + Label_undefined((env.out_position, orig) :: patchlist); + out_int env 0 -let out_label l = out_label_with_orig !out_position l +let out_label env l = out_label_with_orig env env.out_position l (* Relocation information *) -let reloc_info = ref ([] : (reloc_info * int) list) +let enter env info = + let pos = env.out_position in + let old = try RelocTable.find env.reloc_info info with Not_found -> [] in + RelocTable.replace env.reloc_info info (pos :: old) -let enter info = - reloc_info := (info, !out_position) :: !reloc_info +let slot_for_const env c = + enter env (Reloc_const c); + out_int env 0 -let slot_for_const c = - enter (Reloc_const c); - out_int 0 +let slot_for_annot env a = + enter env (Reloc_annot a); + out_int env 0 -let slot_for_annot a = - enter (Reloc_annot a); - out_int 0 - -let slot_for_getglobal p = - enter (Reloc_getglobal p); - out_int 0 +let slot_for_getglobal env p = + enter env (Reloc_getglobal p); + out_int env 0 (* Emission of one instruction *) -let emit_instr = function - | Klabel lbl -> define_label lbl +let emit_instr env = function + | Klabel lbl -> define_label env lbl | Kacc n -> - if n < 8 then out(opACC0 + n) else (out opACC; out_int n) + if n < 8 then out env(opACC0 + n) else (out env opACC; out_int env n) | Kenvacc n -> if n >= 1 && n <= 4 - then out(opENVACC1 + n - 1) - else (out opENVACC; out_int n) + then out env(opENVACC1 + n - 1) + else (out env opENVACC; out_int env n) | Koffsetclosure ofs -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out (opOFFSETCLOSURE0 + ofs / 2) - else (out opOFFSETCLOSURE; out_int ofs) + then out env (opOFFSETCLOSURE0 + ofs / 2) + else (out env opOFFSETCLOSURE; out_int env ofs) | Kpush -> - out opPUSH + out env opPUSH | Kpop n -> - out opPOP; out_int n + out env opPOP; out_int env n | Kpush_retaddr lbl -> - out opPUSH_RETADDR; out_label lbl + out env opPUSH_RETADDR; out_label env lbl | Kapply n -> - if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) + if n < 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) | Kappterm(n, sz) -> - if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) - else (out opAPPTERM; out_int n; out_int sz) + if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) + else (out env opAPPTERM; out_int env n; out_int env sz) | Kreturn n -> - out opRETURN; out_int n + out env opRETURN; out_int env n | Kjump -> - out opRETURN; out_int 0 + out env opRETURN; out_int env 0 | Krestart -> - out opRESTART + out env opRESTART | Kgrab n -> - out opGRAB; out_int n + out env opGRAB; out_int env n | Kgrabrec(rec_arg) -> - out opGRABREC; out_int rec_arg + out env opGRABREC; out_int env rec_arg | Kclosure(lbl, n) -> - out opCLOSURE; out_int n; out_label lbl + out env opCLOSURE; out_int env n; out_label env lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> - out opCLOSUREREC;out_int (Array.length lbl_bodies); - out_int nfv; out_int init; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_types; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_bodies + out env opCLOSUREREC;out_int env (Array.length lbl_bodies); + out_int env nfv; out_int env init; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_types; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_bodies | Kclosurecofix(nfv,init,lbl_types,lbl_bodies) -> - out opCLOSURECOFIX;out_int (Array.length lbl_bodies); - out_int nfv; out_int init; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_types; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_bodies + out env opCLOSURECOFIX;out_int env (Array.length lbl_bodies); + out_int env nfv; out_int env init; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_types; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_bodies | Kgetglobal q -> - out opGETGLOBAL; slot_for_getglobal q + out env opGETGLOBAL; slot_for_getglobal env q | Kconst (Const_b0 i) -> if i >= 0 && i <= 3 - then out (opCONST0 + i) - else (out opCONSTINT; out_int i) + then out env (opCONST0 + i) + else (out env opCONSTINT; out_int env i) | Kconst c -> - out opGETGLOBAL; slot_for_const c + out env opGETGLOBAL; slot_for_const env c | Kmakeblock(n, t) -> if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" - else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) - else (out opMAKEBLOCK; out_int n; out_int t) + else if n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) + else (out env opMAKEBLOCK; out_int env n; out_int env t) | Kmakeprod -> - out opMAKEPROD + out env opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> - out opMAKESWITCHBLOCK; - out_label typlbl; out_label swlbl; - slot_for_annot annot;out_int sz + out env opMAKESWITCHBLOCK; + out_label env typlbl; out_label env swlbl; + slot_for_annot env annot;out_int env sz | Kswitch (tbl_const, tbl_block) -> let lenb = Array.length tbl_block in let lenc = Array.length tbl_const in assert (lenb < 0x100 && lenc < 0x1000000); - out opSWITCH; - out_word lenc (lenc asr 8) (lenc asr 16) (lenb); -(* out_int (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) - let org = !out_position in - Array.iter (out_label_with_orig org) tbl_const; - Array.iter (out_label_with_orig org) tbl_block + out env opSWITCH; + out_word env lenc (lenc asr 8) (lenc asr 16) (lenb); +(* out_int env (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) + let org = env.out_position in + Array.iter (out_label_with_orig env org) tbl_const; + Array.iter (out_label_with_orig env org) tbl_block | Kpushfields n -> - out opPUSHFIELDS;out_int n + out env opPUSHFIELDS;out_int env n | Kfield n -> - if n <= 1 then out (opGETFIELD0+n) - else (out opGETFIELD;out_int n) + if n <= 1 then out env (opGETFIELD0+n) + else (out env opGETFIELD;out_int env n) | Ksetfield n -> - if n <= 1 then out (opSETFIELD0+n) - else (out opSETFIELD;out_int n) + if n <= 1 then out env (opSETFIELD0+n) + else (out env opSETFIELD;out_int env n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" - | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) - | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size + | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_const env (Const_proj p) + | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size (* spiwack *) - | Kbranch lbl -> out opBRANCH; out_label lbl - | Kaddint31 -> out opADDINT31 - | Kaddcint31 -> out opADDCINT31 - | Kaddcarrycint31 -> out opADDCARRYCINT31 - | Ksubint31 -> out opSUBINT31 - | Ksubcint31 -> out opSUBCINT31 - | Ksubcarrycint31 -> out opSUBCARRYCINT31 - | Kmulint31 -> out opMULINT31 - | Kmulcint31 -> out opMULCINT31 - | Kdiv21int31 -> out opDIV21INT31 - | Kdivint31 -> out opDIVINT31 - | Kaddmuldivint31 -> out opADDMULDIVINT31 - | Kcompareint31 -> out opCOMPAREINT31 - | Khead0int31 -> out opHEAD0INT31 - | Ktail0int31 -> out opTAIL0INT31 - | Kisconst lbl -> out opISCONST; out_label lbl - | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl - | Kcompint31 -> out opCOMPINT31 - | Kdecompint31 -> out opDECOMPINT31 - | Klorint31 -> out opORINT31 - | Klandint31 -> out opANDINT31 - | Klxorint31 -> out opXORINT31 + | Kbranch lbl -> out env opBRANCH; out_label env lbl + | Kaddint31 -> out env opADDINT31 + | Kaddcint31 -> out env opADDCINT31 + | Kaddcarrycint31 -> out env opADDCARRYCINT31 + | Ksubint31 -> out env opSUBINT31 + | Ksubcint31 -> out env opSUBCINT31 + | Ksubcarrycint31 -> out env opSUBCARRYCINT31 + | Kmulint31 -> out env opMULINT31 + | Kmulcint31 -> out env opMULCINT31 + | Kdiv21int31 -> out env opDIV21INT31 + | Kdivint31 -> out env opDIVINT31 + | Kaddmuldivint31 -> out env opADDMULDIVINT31 + | Kcompareint31 -> out env opCOMPAREINT31 + | Khead0int31 -> out env opHEAD0INT31 + | Ktail0int31 -> out env opTAIL0INT31 + | Kisconst lbl -> out env opISCONST; out_label env lbl + | Kareconst(n,lbl) -> out env opARECONST; out_int env n; out_label env lbl + | Kcompint31 -> out env opCOMPINT31 + | Kdecompint31 -> out env opDECOMPINT31 + | Klorint31 -> out env opORINT31 + | Klandint31 -> out env opANDINT31 + | Klxorint31 -> out env opXORINT31 (*/spiwack *) | Kstop -> - out opSTOP + out env opSTOP (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) -let rec emit insns remaining = match insns with +let rec emit env insns remaining = match insns with | [] -> (match remaining with [] -> () - | (first::rest) -> emit first rest) + | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> - if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); - emit c remaining + if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); + emit env c remaining | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 - then out(opPUSHENVACC1 + n - 1) - else (out opPUSHENVACC; out_int n); - emit c remaining + then out env(opPUSHENVACC1 + n - 1) + else (out env opPUSHENVACC; out_int env n); + emit env c remaining | Kpush :: Koffsetclosure ofs :: c -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out(opPUSHOFFSETCLOSURE0 + ofs / 2) - else (out opPUSHOFFSETCLOSURE; out_int ofs); - emit c remaining + then out env(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out env opPUSHOFFSETCLOSURE; out_int env ofs); + emit env c remaining | Kpush :: Kgetglobal id :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal id; emit c remaining + out env opPUSHGETGLOBAL; slot_for_getglobal env id; emit env c remaining | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 - then out (opPUSHCONST0 + i) - else (out opPUSHCONSTINT; out_int i); - emit c remaining + then out env (opPUSHCONST0 + i) + else (out env opPUSHCONSTINT; out_int env i); + emit env c remaining | Kpush :: Kconst const :: c -> - out opPUSHGETGLOBAL; slot_for_const const; - emit c remaining + out env opPUSHGETGLOBAL; slot_for_const env const; + emit env c remaining | Kpop n :: Kjump :: c -> - out opRETURN; out_int n; emit c remaining + out env opRETURN; out_int env n; emit env c remaining | Ksequence(c1,c2)::c -> - emit c1 (c2::c::remaining) + emit env c1 (c2::c::remaining) (* Default case *) | instr :: c -> - emit_instr instr; emit c remaining + emit_instr env instr; emit env c remaining (* Initialization *) -let init () = - out_position := 0; - label_table := Array.make 16 (Label_undefined []); - reloc_info := [] - -type emitcodes = String.t - -let length = String.length - -type to_patch = emitcodes * (patch list) * fv +type to_patch = emitcodes * patches * fv (* Substitution *) let rec subst_strcst s sc = @@ -334,17 +355,21 @@ let rec subst_strcst s sc = | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) -let subst_patch s (ri,pos) = +let subst_reloc s ri = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in - (Reloc_annot {a with ci = ci},pos) - | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (subst_constant s kn), pos) + Reloc_annot {a with ci = ci} + | Reloc_const sc -> Reloc_const (subst_strcst s sc) + | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) + +let subst_patches subst p = + let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in + { reloc_infos = infos; } let subst_to_patch s (code,pl,fv) = - code,List.rev_map (subst_patch s) pl,fv + code, subst_patches s pl, fv type body_code = | BCdefined of to_patch @@ -381,16 +406,23 @@ let repr_body_code = function | PBCconstant -> (None, BCconstant) let to_memory (init_code, fun_code, fv) = - init(); - emit init_code []; - emit fun_code []; + let env = { + out_buffer = Bytes.create 1024; + out_position = 0; + label_table = Array.make 16 (Label_undefined []); + reloc_info = RelocTable.create 91; + } in + emit env init_code []; + emit env fun_code []; (** Later uses of this string are all purely functional *) - let code = Bytes.sub_string !out_buffer 0 !out_position in + let code = Bytes.sub_string env.out_buffer 0 env.out_position in let code = CString.hcons code in - let reloc = List.rev !reloc_info in + let fold reloc npos accu = (reloc, Array.of_list npos) :: accu in + let reloc = RelocTable.fold fold env.reloc_info [] in + let reloc = { reloc_infos = CArray.of_list reloc } in Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true | Label_undefined patchlist -> - assert (patchlist = []))) !label_table; + assert (patchlist = []))) env.label_table; (code, reloc, fv) diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index fee45aafd..03920dc1a 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -6,20 +6,12 @@ type reloc_info = | Reloc_const of structured_constant | Reloc_getglobal of Constant.t -type patch = reloc_info * int - -(* A virer *) -val subst_patch : Mod_subst.substitution -> patch -> patch - +type patches type emitcodes -val length : emitcodes -> int - -val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes - -type to_patch = emitcodes * (patch list) * fv +val patch : emitcodes -> patches -> (reloc_info -> int) -> Vmvalues.tcode -val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch +type to_patch = emitcodes * patches * fv type body_code = | BCdefined of to_patch diff --git a/kernel/constr.ml b/kernel/constr.ml index 5930cfadc..1ff1fcc4c 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1178,8 +1178,3 @@ let hcons = Id.hcons) (* let hcons_types = hcons_constr *) - -(*******) -(* Type of abstract machine values *) -(** FIXME: nothing to do there *) -type values diff --git a/kernel/constr.mli b/kernel/constr.mli index 21c477578..19ffa8fe3 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -203,7 +203,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Cast of 'constr * cast_kind * 'types | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) + | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: @@ -459,7 +459,3 @@ val case_info_hash : case_info -> int (*********************************************************************) val hcons : constr -> constr - -(**************************************) - -type values diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 2579ac045..23a578d99 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -168,38 +168,47 @@ let on_body ml hy f = function { Opaqueproof.modlist = ml; abstract = hy } o) let expmod_constr_subst cache modlist subst c = + let subst = Univ.make_instance_subst subst in let c = expmod_constr cache modlist c in Vars.subst_univs_level_constr subst c -let cook_constr { Opaqueproof.modlist ; abstract } c = +let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c = let cache = RefTable.create 13 in - let expmod = expmod_constr_subst cache modlist (pi2 abstract) in - let hyps = Context.Named.map expmod (pi1 abstract) in + let expmod = expmod_constr_subst cache modlist subst in + let hyps = Context.Named.map expmod vars in abstract_constant_body (expmod c) hyps -let lift_univs cb subst = +let lift_univs cb subst auctx0 = match cb.const_universes with - | Monomorphic_const ctx -> subst, (Monomorphic_const ctx) - | Polymorphic_const auctx -> - if (Univ.LMap.is_empty subst) then - subst, (Polymorphic_const auctx) + | Monomorphic_const ctx -> + assert (AUContext.is_empty auctx0); + subst, (Monomorphic_const ctx) + | Polymorphic_const auctx -> + (** Given a named instance [subst := uâ‚€ ... uₙ₋â‚] together with an abstract + context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, + and another abstract context relative to the former context + [auctx := 0 ... m - 1 |= C'{uâ‚€, ..., uₙ₋â‚, 0, ..., m - 1}], + construct the lifted abstract universe context + [0 ... n - 1 n ... n + m - 1 |= + C{0, ... n - 1} ∪ + C'{0, ..., n - 1, n, ..., n + m - 1} ] + together with the instance + [uâ‚€ ... uₙ₋₠Var(0) ... Var (m - 1)]. + *) + if (Univ.Instance.is_empty subst) then + (** Still need to take the union for the constraints between globals *) + subst, (Polymorphic_const (AUContext.union auctx0 auctx)) else - let len = Univ.LMap.cardinal subst in - let rec gen_subst i acc = - if i < 0 then acc - else - let acc = Univ.LMap.add (Level.var i) (Level.var (i + len)) acc in - gen_subst (pred i) acc - in - let subst = gen_subst (Univ.AUContext.size auctx - 1) subst in - let auctx' = Univ.subst_univs_level_abstract_universe_context subst auctx in - subst, (Polymorphic_const auctx') + let ainst = Univ.make_abstract_instance auctx in + let subst = Instance.append subst ainst in + let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in + subst, (Polymorphic_const (AUContext.union auctx0 auctx')) let cook_constant ~hcons env { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in - let usubst, univs = lift_univs cb usubst in + let usubst, univs = lift_univs cb usubst abs_ctx in let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let map c = @@ -234,13 +243,6 @@ let cook_constant ~hcons env { from = cb; info } = proj_eta = etab, etat; proj_type = ty'; proj_body = c' } in - let univs = - match univs with - | Monomorphic_const ctx -> - assert (AUContext.is_empty abs_ctx); univs - | Polymorphic_const auctx -> - Polymorphic_const (AUContext.union abs_ctx auctx) - in { cook_body = body; cook_type = typ; @@ -250,7 +252,7 @@ let cook_constant ~hcons env { from = cb; info } = cook_context = Some const_hyps; } -(* let cook_constant_key = Profile.declare_profile "cook_constant" *) -(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) +(* let cook_constant_key = CProfile.declare_profile "cook_constant" *) +(* let cook_constant = CProfile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 2ffe36fcf..55430a9d8 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -14,8 +14,7 @@ open Util open Names -open Constr -open Vm +open Vmvalues open Cemitcodes open Cbytecodes open Declarations @@ -25,7 +24,6 @@ open Cbytegen module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration -external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (*******************) @@ -56,61 +54,12 @@ let set_global v = (* table pour les structured_constant et les annotations des switchs *) -let rec eq_structured_constant c1 c2 = match c1, c2 with -| Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 -| Const_sorts _, _ -> false -| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 -| Const_ind _, _ -> false -| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 -| Const_proj _, _ -> false -| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 -| Const_b0 _, _ -> false -| Const_bn (t1, a1), Const_bn (t2, a2) -> - Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 -| Const_bn _, _ -> false -| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 -| Const_univ_level _ , _ -> false -| Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 -| Const_type _ , _ -> false - -let rec hash_structured_constant c = - let open Hashset.Combine in - match c with - | Const_sorts s -> combinesmall 1 (Sorts.hash s) - | Const_ind i -> combinesmall 2 (ind_hash i) - | Const_proj p -> combinesmall 3 (Constant.hash p) - | Const_b0 t -> combinesmall 4 (Int.hash t) - | Const_bn (t, a) -> - let fold h c = combine h (hash_structured_constant c) in - let h = Array.fold_left fold 0 a in - combinesmall 5 (combine (Int.hash t) h) - | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) - | Const_type u -> combinesmall 7 (Univ.Universe.hash u) - module SConstTable = Hashtbl.Make (struct type t = structured_constant let equal = eq_structured_constant let hash = hash_structured_constant end) -let eq_annot_switch asw1 asw2 = - let eq_ci ci1 ci2 = - eq_ind ci1.ci_ind ci2.ci_ind && - Int.equal ci1.ci_npar ci2.ci_npar && - Array.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls - in - let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in - eq_ci asw1.ci asw2.ci && - Array.equal eq_rlc asw1.rtbl asw2.rtbl && - (asw1.tailcall : bool) == asw2.tailcall - -let hash_annot_switch asw = - let open Hashset.Combine in - let h1 = Constr.case_info_hash asw.ci in - let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in - let h3 = if asw.tailcall then 1 else 0 in - combine3 h1 h2 h3 - module AnnotTable = Hashtbl.Make (struct type t = annot_switch let equal = eq_annot_switch @@ -198,22 +147,20 @@ and slot_for_fv env fv = let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - env.env_rel_context |> Context.Rel.lookup i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel + env |> Pre_env.lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVuniv_var idu -> assert false and eval_to_patch env (buff,pl,fv) = - let patch = function - | Reloc_annot a, pos -> (pos, slot_for_annot a) - | Reloc_const sc, pos -> (pos, slot_for_str_cst sc) - | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn) + let slots = function + | Reloc_annot a -> slot_for_annot a + | Reloc_const sc -> slot_for_str_cst sc + | Reloc_getglobal kn -> slot_for_getglobal env kn in - let patches = List.map_left patch pl in - let buff = patch_int buff patches in + let tc = patch buff pl slots in let vm_env = Array.map (slot_for_fv env) fv in - let tc = tcode_of_code buff (length buff) in eval_tcode tc vm_env and val_of_constr env c = diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 91bb30e7e..fc935f6ee 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -12,7 +12,7 @@ open Names open Constr open Pre_env -val val_of_constr : env -> constr -> values +val val_of_constr : env -> constr -> Vmvalues.values val set_opaque_const : Constant.t -> unit val set_transparent_const : Constant.t -> unit diff --git a/kernel/declarations.ml b/kernel/declarations.ml index d5312c500..cb7f0ecef 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -74,6 +74,7 @@ type typing_flags = { check_guarded : bool; (** If [false] then fixed points and co-fixed points are assumed to be total. *) check_universes : bool; (** If [false] universe constraints are not checked *) + conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *) } (* some contraints are in constant_constraints, some other may be in @@ -172,13 +173,18 @@ type abstract_inductive_universes = | Polymorphic_ind of Univ.AUContext.t | Cumulative_ind of Univ.ACumulativityInfo.t +type recursivity_kind = + | Finite (** = inductive *) + | CoFinite (** = coinductive *) + | BiFinite (** = non-recursive, like in "Record" definitions *) + type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) mind_record : record_body option; (** The record information *) - mind_finite : Decl_kinds.recursivity_kind; (** Whether the type is inductive or coinductive *) + mind_finite : recursivity_kind; (** Whether the type is inductive or coinductive *) mind_ntypes : int; (** Number of types in the block *) @@ -213,7 +219,7 @@ type ('ty,'a) functorize = type with_declaration = | WithMod of Id.t list * ModPath.t - | WithDef of Id.t list * constr Univ.in_universe_context + | WithDef of Id.t list * (constr * Univ.AUContext.t option) type module_alg_expr = | MEident of ModPath.t diff --git a/kernel/declareops.ml b/kernel/declareops.ml index d8768a0fc..9eed9efcb 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -15,9 +15,10 @@ module RelDecl = Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) -let safe_flags = { +let safe_flags oracle = { check_guarded = true; check_universes = true; + conv_oracle = oracle; } (** {6 Arities } *) diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 198831848..0eed11f49 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -67,7 +67,7 @@ val inductive_is_cumulative : mutual_inductive_body -> bool (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) -val safe_flags : typing_flags +val safe_flags : Conv_oracle.oracle -> typing_flags (** {6 Hash-consing} *) diff --git a/kernel/entries.ml b/kernel/entries.ml index c44a17df2..36b75668b 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -51,7 +51,7 @@ type mutual_inductive_entry = { (** Some (Some id): primitive record with id the binder name of the record in projections. Some None: non-primitive record *) - mind_entry_finite : Decl_kinds.recursivity_kind; + mind_entry_finite : Declarations.recursivity_kind; mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; mind_entry_universes : inductive_universes; @@ -81,6 +81,13 @@ type 'a definition_entry = { const_entry_opaque : bool; const_entry_inline_code : bool } +type section_def_entry = { + secdef_body : constr; + secdef_secctx : Context.Named.t option; + secdef_feedback : Stateid.t option; + secdef_type : types option; +} + type inline = int option (* inlining level, None for no inlining *) type parameter_entry = diff --git a/kernel/environ.ml b/kernel/environ.ml index 1afab453a..738ecc6e1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -37,8 +37,10 @@ type env = Pre_env.env let pre_env env = env let env_of_pre_env env = env -let oracle env = env.env_conv_oracle -let set_oracle env o = { env with env_conv_oracle = o } +let oracle env = env.env_typing_flags.conv_oracle +let set_oracle env o = + let env_typing_flags = { env.env_typing_flags with conv_oracle = o } in + { env with env_typing_flags } let empty_named_context_val = empty_named_context_val @@ -58,18 +60,17 @@ let deactivated_guard env = not (typing_flags env).check_guarded let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context -let rel_context env = env.env_rel_context +let rel_context env = env.env_rel_context.env_rel_ctx let opaque_tables env = env.indirect_pterms let set_opaque_tables env indirect_pterms = { env with indirect_pterms } let empty_context env = - match env.env_rel_context, env.env_named_context.env_named_ctx with + match env.env_rel_context.env_rel_ctx, env.env_named_context.env_named_ctx with | [], [] -> true | _ -> false (* Rel context *) -let lookup_rel n env = - Context.Rel.lookup n env.env_rel_context +let lookup_rel = lookup_rel let evaluable_rel n env = is_local_def (lookup_rel n env) @@ -86,13 +87,12 @@ let push_rec_types (lna,typarray,_) env = let fold_rel_context f env ~init = let rec fold_right env = - match env.env_rel_context with - | [] -> init - | rd::rc -> + match match_rel_context_val env.env_rel_context with + | None -> init + | Some (rd, _, rc) -> let env = { env with env_rel_context = rc; - env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in f env rd (fold_right env) in fold_right env @@ -142,16 +142,21 @@ let evaluable_named id env = let reset_with_named_context ctxt env = { env with env_named_context = ctxt; - env_rel_context = Context.Rel.empty; - env_rel_val = []; + env_rel_context = empty_rel_context_val; env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val let pop_rel_context n env = + let rec skip n ctx = + if Int.equal n 0 then ctx + else match match_rel_context_val ctx with + | None -> invalid_arg "List.skipn" + | Some (_, _, ctx) -> skip (pred n) ctx + in let ctxt = env.env_rel_context in { env with - env_rel_context = List.skipn n ctxt; + env_rel_context = skip n ctxt; env_nb_rel = env.env_nb_rel - n } let fold_named_context f env ~init = @@ -249,31 +254,10 @@ let constant_context env kn = | Monomorphic_const _ -> Univ.AUContext.empty | Polymorphic_const ctx -> ctx -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result -let constant_value env (kn,u) = - let cb = lookup_constant kn env in - if cb.const_proj = None then - match cb.const_body with - | Def l_body -> - begin - match cb.const_universes with - | Monomorphic_const _ -> - (Mod_subst.force_constr l_body, Univ.Constraint.empty) - | Polymorphic_const _ -> - let csts = constraints_of cb u in - (subst_instance_constr u (Mod_subst.force_constr l_body), csts) - end - | OpaqueDef _ -> raise (NotEvaluableConst Opaque) - | Undef _ -> raise (NotEvaluableConst NoBody) - else raise (NotEvaluableConst IsProj) - -let constant_opt_value env cst = - try Some (constant_value env cst) - with NotEvaluableConst _ -> None - let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in if Declareops.constant_is_polymorphic cb then diff --git a/kernel/environ.mli b/kernel/environ.mli index 652ed0f9f..69d811a64 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -146,15 +146,13 @@ val type_in_type_constant : Constant.t -> env -> bool body and [NotEvaluableConst IsProj] if [c] is a projection and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> Constant.t puniverses -> constr constrained val constant_type : env -> Constant.t puniverses -> types constrained -val constant_opt_value : env -> Constant.t puniverses -> (constr * Univ.constraints) option val constant_value_and_type : env -> Constant.t puniverses -> - constr option * types * Univ.constraints + constr option * types * Univ.Constraint.t (** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t @@ -203,10 +201,10 @@ val lookup_modtype : ModPath.t -> env -> module_type_body (** Add universe constraints to the environment. @raises UniverseInconsistency *) -val add_constraints : Univ.constraints -> env -> env +val add_constraints : Univ.Constraint.t -> env -> env (** Check constraints are satifiable in the environment. *) -val check_constraints : Univ.constraints -> env -> bool +val check_constraints : Univ.Constraint.t -> env -> bool val push_context : ?strict:bool -> Univ.UContext.t -> env -> env val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 8e9b606a5..cfca335d3 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -234,22 +234,32 @@ let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : typ (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) let check_subtyping cumi paramsctxt env_ar inds = let numparams = Context.Rel.nhyps paramsctxt in - let sbsubst = CumulativityInfo.subtyping_susbst cumi in - let dosubst = subst_univs_level_constr sbsubst in let uctx = CumulativityInfo.univ_context cumi in - let instance_other = Univ.subst_univs_level_instance sbsubst (Univ.UContext.instance uctx) in - let constraints_other = Univ.subst_univs_level_constraints sbsubst (Univ.UContext.constraints uctx) in + let new_levels = Array.init (UContext.size uctx) (Level.make DirPath.empty) in + let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) + LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels + in + let dosubst = subst_univs_level_constr lmap in + let instance_other = Instance.of_array new_levels in + let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in let uctx_other = Univ.UContext.make (instance_other, constraints_other) in let env = Environ.push_context uctx env_ar in let env = Environ.push_context uctx_other env in - let env = push_context (CumulativityInfo.subtyp_context cumi) env in + let subtyp_constraints = + CumulativityInfo.leq_constraints cumi + (UContext.instance uctx) instance_other + Constraint.empty + in + let env = Environ.add_constraints subtyp_constraints env in (* process individual inductive types: *) Array.iter (fun (id,cn,lc,(sign,arity)) -> match arity with | RegularArity (_, full_arity, _) -> check_subtyping_arity_constructor env dosubst full_arity numparams true; Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> () + | TemplateArity _ -> + anomaly ~label:"check_subtyping" + Pp.(str "template polymorphism and cumulative polymorphism are not compatible") ) inds (* Type-check an inductive definition. Does not check positivity @@ -710,7 +720,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( best-effort fashion. *) let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in - let recursive = finite != Decl_kinds.BiFinite in + let recursive = finite != BiFinite in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let ra_env_ar = Array.rev_to_list rc in let nparamsctxt = Context.Rel.length paramsctxt in @@ -879,9 +889,13 @@ let abstract_inductive_universes iu = match iu with | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) | Polymorphic_ind_entry ctx -> - let (inst, auctx) = Univ.abstract_universes ctx in (inst, Polymorphic_ind auctx) + let (inst, auctx) = Univ.abstract_universes ctx in + let inst = Univ.make_instance_subst inst in + (inst, Polymorphic_ind auctx) | Cumulative_ind_entry cumi -> - let (inst, acumi) = Univ.abstract_cumulativity_info cumi in (inst, Cumulative_ind acumi) + let (inst, acumi) = Univ.abstract_cumulativity_info cumi in + let inst = Univ.make_instance_subst inst in + (inst, Cumulative_ind acumi) let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 62aa9a2d7..722705bd7 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -38,14 +38,14 @@ let find_inductive env c = let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind - when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind - when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == CoFinite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams @@ -796,18 +796,18 @@ let rec subterm_specif renv stack t = | Proj (p, c) -> let subt = subterm_specif renv stack c in - (match subt with - | Subterm (s, wf) -> - (* We take the subterm specs of the constructor of the record *) - let wf_args = (dest_subterms wf).(0) in - (* We extract the tree of the projected argument *) - let kn = Projection.constant p in - let cb = lookup_constant kn renv.env in - let pb = Option.get cb.const_proj in - let n = pb.proj_arg in - Subterm (Strict, List.nth wf_args n) - | Dead_code -> Dead_code - | Not_subterm -> Not_subterm) + (match subt with + | Subterm (s, wf) -> + (* We take the subterm specs of the constructor of the record *) + let wf_args = (dest_subterms wf).(0) in + (* We extract the tree of the projected argument *) + let kn = Projection.constant p in + let cb = lookup_constant kn renv.env in + let pb = Option.get cb.const_proj in + let n = pb.proj_arg in + spec_of_tree (List.nth wf_args n) + | Dead_code -> Dead_code + | Not_subterm -> Not_subterm) | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ | Construct _ | CoFix _ -> Not_subterm @@ -1098,8 +1098,8 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = () (* -let cfkey = Profile.declare_profile "check_fix";; -let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; +let cfkey = CProfile.declare_profile "check_fix";; +let check_fix env fix = CProfile.profile3 cfkey check_fix env fix;; *) (************************************************************************) diff --git a/kernel/inductive.mli b/kernel/inductive.mli index a19f87b05..8aaeee831 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -37,7 +37,7 @@ val ind_subst : MutInd.t -> mutual_inductive_body -> Instance.t -> constr list val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t val instantiate_inductive_constraints : - mutual_inductive_body -> Instance.t -> constraints + mutual_inductive_body -> Instance.t -> Constraint.t val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained val constrained_type_of_inductive_knowing_parameters : diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 917e4f6f1..749854b8c 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -16,6 +16,7 @@ Cemitcodes Opaqueproof Declarations Entries +Vmvalues Nativevalues CPrimitives Declareops diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index f7e755f00..6b89a1da0 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -73,13 +73,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = any implementations of parameters and opaques terms, as long as they have the right type *) let c', univs, ctx' = - match cb.const_universes with - | Monomorphic_const _ -> - (** We do not add the deferred constraints of the body in the - environment, because they do not appear in the type of the - definition. Any inconsistency will be raised at a later stage - when joining the environment. *) - let env' = Environ.push_context ~strict:true ctx env' in + match cb.const_universes, ctx with + | Monomorphic_const _, None -> let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in @@ -91,11 +86,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' in - let ctx = Univ.ContextSet.of_context ctx in - c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst ctx - | Polymorphic_const uctx -> - let subst, ctx = Univ.abstract_universes ctx in - let c = Vars.subst_univs_level_constr subst c in + c', Monomorphic_const Univ.ContextSet.empty, cst + | Polymorphic_const uctx, Some ctx -> let () = if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then error_incorrect_with_constraint lab @@ -116,7 +108,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = in if not (Univ.Constraint.is_empty cst) then error_incorrect_with_constraint lab; - c, Polymorphic_const ctx, Univ.ContextSet.empty + c, Polymorphic_const ctx, Univ.Constraint.empty + | _ -> error_incorrect_with_constraint lab in let def = Def (Mod_subst.from_val c') in (* let ctx' = Univ.UContext.make (newus, cst) in *) @@ -225,11 +218,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Reduction.NotConvertible -> error_incorrect_with_constraint lab let check_with env mp (sign,alg,reso,cst) = function - |WithDef(idl,c) -> + |WithDef(idl, (c, ctx)) -> let struc = destr_nofunctor sign in - let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in - NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' + let struc', c', cst' = check_with_def env struc (idl, (c, ctx)) mp reso in + let wd' = WithDef (idl, (c', ctx)) in + NoFunctor struc', MEwith (alg,wd'), reso, Univ.ContextSet.add_constraints cst' cst |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in diff --git a/kernel/names.mli b/kernel/names.mli index 709ebeb7f..b1e8efd8d 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -40,19 +40,16 @@ sig (** Hash over identifiers. *) val is_valid : string -> bool - (** Check that a string may be converted to an identifier. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + (** Check that a string may be converted to an identifier. *) val of_bytes : bytes -> t val of_string : string -> t (** Converts a string into an identifier. - @raise UserError if the string is invalid as an identifier. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + @raise UserError if the string is invalid as an identifier. *) val of_string_soft : string -> t (** Same as {!of_string} except that any string made of supported UTF-8 characters is accepted. - @raise UserError if the string is invalid as an UTF-8 string. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + @raise UserError if the string is invalid as an UTF-8 string. *) val to_string : t -> string (** Converts a identifier into an string. *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index c558e9ed0..8fa254053 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -148,7 +148,7 @@ type symbol = | SymbMatch of annot_sw | SymbInd of inductive | SymbMeta of metavariable - | SymbEvar of existential + | SymbEvar of Evar.t | SymbLevel of Univ.Level.t let dummy_symb = SymbValue (dummy_value ()) @@ -162,8 +162,7 @@ let eq_symbol sy1 sy2 = | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2 | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2 | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 - | SymbEvar (evk1,args1), SymbEvar (evk2,args2) -> - Evar.equal evk1 evk2 && Array.for_all2 Constr.equal args1 args2 + | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 | _, _ -> false @@ -176,10 +175,7 @@ let hash_symbol symb = | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw) | SymbInd ind -> combinesmall 6 (ind_hash ind) | SymbMeta m -> combinesmall 7 m - | SymbEvar (evk,args) -> - let evh = Evar.hash evk in - let hl = Array.fold_left (fun h t -> combine h (Constr.hash t)) evh args in - combinesmall 8 hl + | SymbEvar evk -> combinesmall 8 (Evar.hash evk) | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) module HashedTypeSymbol = struct @@ -1047,11 +1043,12 @@ let ml_of_instance instance u = let tyn = fresh_lname Anonymous in let i = push_symbol (SymbMeta mv) in MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|]) - | Levar(ev,ty) -> + | Levar(evk,ty,args) -> let tyn = fresh_lname Anonymous in - let i = push_symbol (SymbEvar ev) in + let i = push_symbol (SymbEvar evk) in + let args = MLarray(Array.map (ml_of_lam env l) args) in MLlet(tyn, ml_of_lam env l ty, - MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn|])) + MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn; args|])) | Lprod(dom,codom) -> let dom = ml_of_lam env l dom in let codom = ml_of_lam env l codom in @@ -1830,7 +1827,7 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in - let lvl = Context.Rel.length env.env_rel_context in + let lvl = Context.Rel.length env.env_rel_context.env_rel_ctx in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in @@ -1838,8 +1835,8 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = and compile_rel env sigma univ auxdefs n = let open Context.Rel.Declaration in - let decl = Context.Rel.lookup n env.env_rel_context in - let n = Context.Rel.length env.env_rel_context - n in + let decl = Pre_env.lookup_rel n env in + let n = List.length env.env_rel_context.env_rel_ctx - n in match decl with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in @@ -1919,15 +1916,17 @@ let compile_constant env sigma prefix ~interactive con cb = let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; asw_reloc = tbl; asw_finite = true } in let c_uid = fresh_lname Anonymous in + let cf_uid = fresh_lname Anonymous in let _, arity = tbl.(0) in let ci_uid = fresh_lname Anonymous in let cargs = Array.init arity (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) in let i = push_symbol (SymbConst con) in - let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in - let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in let gn = Gproj ("",con) in let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in let arg = fargs.(pb.proj_npars) in diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index d08f49095..7d20054f7 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -44,7 +44,7 @@ val get_ind : symbols -> int -> inductive val get_meta : symbols -> int -> metavariable -val get_evar : symbols -> int -> existential +val get_evar : symbols -> int -> Evar.t val get_level : symbols -> int -> Univ.Level.t diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index a62a079da..bfa982136 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -54,13 +54,18 @@ and conv_accu env pb lvl k1 k2 cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in - List.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu + Array.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu and conv_atom env pb lvl a1 a2 cu = if a1 == a2 then cu else match a1, a2 with - | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false + | Ameta (m1,_), Ameta (m2,_) -> + if Int.equal m1 m2 then cu else raise NotConvertible + | Aevar (ev1,_,args1), Aevar (ev2,_,args2) -> + if Evar.equal ev1 ev2 then + Array.fold_right2 (conv_val env CONV lvl) args1 args2 cu + else raise NotConvertible | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Aind (ind1,u1), Aind (ind2,u2) -> @@ -112,7 +117,7 @@ and conv_atom env pb lvl a1 a2 cu = else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ - | Aproj _, _ -> raise NotConvertible + | Aproj _, _ | Ameta _, _ | Aevar _, _ -> raise NotConvertible (* Precondition length t1 = length f1 = length f2 = length t2 *) and conv_fix env lvl t1 f1 t2 f2 cu = @@ -154,7 +159,7 @@ let warn_no_native_compiler = (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if Coq_config.no_native_compiler then begin + if not Coq_config.native_compiler then begin warn_no_native_compiler (); vm_conv cv_pb env t1 t2 end diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 928283a4d..48ad88444 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -23,7 +23,7 @@ and lambda = | Lrel of Name.t * int | Lvar of Id.t | Lmeta of metavariable * lambda (* type *) - | Levar of existential * lambda (* type *) + | Levar of Evar.t * lambda (* type *) * lambda array (* arguments *) | Lprod of lambda * lambda | Llam of Name.t array * lambda | Llet of Name.t * lambda * lambda diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index de4dc2107..29b3e59da 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -453,11 +453,12 @@ let rec lambda_of_constr env sigma c = let ty = meta_type sigma mv in Lmeta (mv, lambda_of_constr env sigma ty) - | Evar ev -> + | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> let ty = evar_type sigma ev in - Levar(ev, lambda_of_constr env sigma ty) + let args = Array.map (lambda_of_constr env sigma) args in + Levar(evk, lambda_of_constr env sigma ty, args) | Some t -> lambda_of_constr env sigma t) | Cast (c, _, _) -> lambda_of_constr env sigma c @@ -515,7 +516,7 @@ let rec lambda_of_constr env sigma c = { asw_ind = ind; asw_ci = ci; asw_reloc = tbl; - asw_finite = mib.mind_finite <> Decl_kinds.CoFinite; + asw_finite = mib.mind_finite <> CoFinite; asw_prefix = prefix} in (* translation of the argument *) @@ -639,7 +640,7 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context in + let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context.env_rel_ctx in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index e9c0e171a..1e35f6c03 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -87,7 +87,7 @@ let call_compiler ?profile:(profile=false) ml_filename = [] in let flambda_args = - if Coq_config.caml_version_nums >= [4;3;0] then + if Coq_config.caml_version_nums >= [4;3;0] && Dynlink.is_native then (* We play safe for now, and use the native compiler with -Oclassic, however it is likely that `native_compute` users can benefit from tweaking here. @@ -157,9 +157,8 @@ let call_linker ?(fatal=true) prefix f upds = register_native_file prefix with Dynlink.Error e as exn -> let exn = CErrors.push exn in - let msg = "Dynlink error, " ^ Dynlink.error_message e in - if fatal then (Feedback.msg_error (Pp.str msg); iraise exn) - else if !Flags.debug then Feedback.msg_debug (Pp.str msg)); + if fatal then iraise exn + else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index ae66362ca..3d47b1672 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -61,7 +61,7 @@ type atom = | Acofixe of t array * t array * int * t | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t - | Aevar of existential * t + | Aevar of Evar.t * t * t array | Aproj of Constant.t * accumulator let accumulate_tag = 0 @@ -132,8 +132,8 @@ let mk_prod_accu s dom codom = let mk_meta_accu mv ty = mk_accu (Ameta (mv,ty)) -let mk_evar_accu ev ty = - mk_accu (Aevar (ev,ty)) +let mk_evar_accu ev ty args = + mk_accu (Aevar (ev,ty,args)) let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) @@ -153,8 +153,7 @@ let accu_nargs (k:accumulator) = let args_of_accu (k:accumulator) = let nargs = accu_nargs k in let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in - let t = Array.init nargs f in - Array.to_list t + Array.init nargs f let is_accu x = let o = Obj.repr x in @@ -179,11 +178,10 @@ let force_cofix (cofix : t) = let atom = atom_of_accu accu in match atom with | Acofix(typ,norm,pos,f) -> - let f = ref f in - let args = List.rev (args_of_accu accu) in - List.iter (fun x -> f := !f x) args; - let v = !f (Obj.magic ()) in - set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); + let args = args_of_accu accu in + let f = Array.fold_right (fun arg f -> f arg) args f in + let v = f (Obj.magic ()) in + set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); v | Acofixe(_,_,_,v) -> v | _ -> cofix diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 18b877745..993842740 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -51,7 +51,7 @@ type atom = | Acofixe of t array * t array * int * t | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t - | Aevar of existential * t + | Aevar of Evar.t * t (* type *) * t array (* arguments *) | Aproj of Constant.t * accumulator (* Constructors *) @@ -68,7 +68,7 @@ val mk_prod_accu : Name.t -> t -> t -> t val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t -val mk_evar_accu : existential -> t -> t +val mk_evar_accu : Evar.t -> t -> t array -> t val mk_proj_accu : Constant.t -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t @@ -84,7 +84,7 @@ val napply : t -> t array -> t val dummy_value : unit -> t val atom_of_accu : accumulator -> atom -val args_of_accu : accumulator -> t list +val args_of_accu : accumulator -> t array val accu_nargs : accumulator -> int val cast_accu : t -> accumulator diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 45a62d55a..c2fcfbfd6 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } + abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t } type proofterm = (constr * Univ.ContextSet.t) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 20d76ce23..c8339e6eb 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -49,7 +49,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } + abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index c5254b453..6c5e1cde5 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -15,7 +15,6 @@ open Util open Names -open Constr open Declarations module NamedDecl = Context.Named.Declaration @@ -50,7 +49,7 @@ type stratification = { } type val_kind = - | VKvalue of (values * Id.Set.t) CEphemeron.key + | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key | VKnone type lazy_val = val_kind ref @@ -67,15 +66,18 @@ type named_context_val = { env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; } +type rel_context_val = { + env_rel_ctx : Context.Rel.t; + env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; +} + type env = { env_globals : globals; (* globals = constants + inductive types + modules + module-types *) env_named_context : named_context_val; (* section variables *) - env_rel_context : Context.Rel.t; - env_rel_val : lazy_val list; + env_rel_context : rel_context_val; env_nb_rel : int; env_stratification : stratification; env_typing_flags : typing_flags; - env_conv_oracle : Conv_oracle.oracle; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; } @@ -85,6 +87,11 @@ let empty_named_context_val = { env_named_map = Id.Map.empty; } +let empty_rel_context_val = { + env_rel_ctx = []; + env_rel_map = Range.empty; +} + let empty_env = { env_globals = { env_constants = Cmap_env.empty; @@ -92,14 +99,12 @@ let empty_env = { env_modules = MPmap.empty; env_modtypes = MPmap.empty}; env_named_context = empty_named_context_val; - env_rel_context = Context.Rel.empty; - env_rel_val = []; + env_rel_context = empty_rel_context_val; env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; env_engagement = PredicativeSet }; - env_typing_flags = Declareops.safe_flags; - env_conv_oracle = Conv_oracle.empty; + env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.initial_retroknowledge; indirect_pterms = Opaqueproof.empty_opaquetab } @@ -108,21 +113,39 @@ let empty_env = { let nb_rel env = env.env_nb_rel +let push_rel_context_val d ctx = { + env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx; + env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map; +} + +let match_rel_context_val ctx = match ctx.env_rel_ctx with +| [] -> None +| decl :: rem -> + let (_, lval) = Range.hd ctx.env_rel_map in + let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in + Some (decl, lval, ctx) + let push_rel d env = - let rval = ref VKnone in { env with - env_rel_context = Context.Rel.add d env.env_rel_context; - env_rel_val = rval :: env.env_rel_val; + env_rel_context = push_rel_context_val d env.env_rel_context; env_nb_rel = env.env_nb_rel + 1 } +let lookup_rel n env = + try fst (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + let lookup_rel_val n env = - try List.nth env.env_rel_val (n - 1) - with Failure _ -> raise Not_found + try snd (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + +let rel_skipn n ctx = { + env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx; + env_rel_map = Range.skipn n ctx.env_rel_map; +} let env_of_rel n env = { env with - env_rel_context = Util.List.skipn n env.env_rel_context; - env_rel_val = Util.List.skipn n env.env_rel_val; + env_rel_context = rel_skipn n env.env_rel_context; env_nb_rel = env.env_nb_rel - n } diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 054ae1743..a6b57bd1b 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -36,24 +36,27 @@ type stratification = { type lazy_val -val force_lazy_val : lazy_val -> (values * Id.Set.t) option +val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option val dummy_lazy_val : unit -> lazy_val -val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit +val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit type named_context_val = private { env_named_ctx : Context.Named.t; env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; } +type rel_context_val = private { + env_rel_ctx : Context.Rel.t; + env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; +} + type env = { env_globals : globals; env_named_context : named_context_val; - env_rel_context : Context.Rel.t; - env_rel_val : lazy_val list; + env_rel_context : rel_context_val; env_nb_rel : int; env_stratification : stratification; env_typing_flags : typing_flags; - env_conv_oracle : Conv_oracle.oracle; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; } @@ -64,8 +67,15 @@ val empty_env : env (** Rel context *) +val empty_rel_context_val : rel_context_val +val push_rel_context_val : + Context.Rel.Declaration.t -> rel_context_val -> rel_context_val +val match_rel_context_val : + rel_context_val -> (Context.Rel.Declaration.t * lazy_val * rel_context_val) option + val nb_rel : env -> int val push_rel : Context.Rel.Declaration.t -> env -> env +val lookup_rel : int -> env -> Context.Rel.Declaration.t val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 41d6c05eb..da7042713 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -200,33 +200,79 @@ let is_cumul = function CUMUL -> true | CONV -> false type 'a universe_compare = { (* Might raise NotConvertible *) - compare : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> - Univ.Instance.t -> int -> 'a -> 'a; - conv_constructors : (Declarations.mutual_inductive_body * int * int) -> - Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; - } + compare_cumul_instances : Univ.Constraint.t -> 'a -> 'a } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t let sort_cmp_universes env pb s0 s1 (u, check) = - (check.compare env pb s0 s1 u, check) + (check.compare_sorts env pb s0 s1 u, check) (* [flex] should be true for constants, false for inductive types and constructors. *) let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' s, check) - -let convert_inductives cv_pb ind u1 sv1 u2 sv2 (s, check) = - (check.conv_inductives cv_pb ind u1 sv1 u2 sv2 s, check) -let convert_constructors cons u1 sv1 u2 sv2 (s, check) = - (check.conv_constructors cons u1 sv1 u2 sv2 s, check) +let get_cumulativity_constraints cv_pb cumi u u' = + match cv_pb with + | CONV -> + Univ.ACumulativityInfo.eq_constraints cumi u u' Univ.Constraint.empty + | CUMUL -> + Univ.ACumulativityInfo.leq_constraints cumi u u' Univ.Constraint.empty + +let inductive_cumulativity_arguments (mind,ind) = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + +let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 s = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); + s + | Declarations.Polymorphic_ind _ -> + cmp_instances u1 u2 s + | Declarations.Cumulative_ind cumi -> + let num_param_arity = inductive_cumulativity_arguments (mind,ind) in + if not (Int.equal num_param_arity nargs) then + cmp_instances u1 u2 s + else + let csts = get_cumulativity_constraints cv_pb cumi u1 u2 in + cmp_cumul csts s + +let convert_inductives cv_pb ind nargs u1 u2 (s, check) = + convert_inductives_gen (check.compare_instances ~flex:false) check.compare_cumul_instances + cv_pb ind nargs u1 u2 s, check + +let constructor_cumulativity_arguments (mind, ind, ctor) = + let nparamsctxt = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + (* Context.Rel.length mind.Declarations.mind_params_ctxt *) in + nparamsctxt + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(ctor - 1) + +let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u2 s = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); + s + | Declarations.Polymorphic_ind _ -> + cmp_instances u1 u2 s + | Declarations.Cumulative_ind cumi -> + let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in + if not (Int.equal num_cnstr_args nargs) then + cmp_instances u1 u2 s + else + let csts = get_cumulativity_constraints CONV cumi u1 u2 in + cmp_cumul csts s + +let convert_constructors ctor nargs u1 u2 (s, check) = + convert_constructors_gen (check.compare_instances ~flex:false) check.compare_cumul_instances + ctor nargs u1 u2 s, check let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else @@ -308,17 +354,6 @@ let in_whnf (t,stk) = | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false -let unfold_projection infos p c = - let unf = Projection.unfolded p in - if unf || RedFlags.red_set infos.i_flags (RedFlags.fCONST (Projection.constant p)) then - (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with - | Some pb -> - let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - Projection.constant p) in - Some (c, s) - | None -> None) - else None - (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -336,9 +371,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if in_whnf st1' then (st1',st2') else whd_both st1' st2' in let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in - (* compute the lifts that apply to the head of the term (hd1 and hd2) *) - let el1 = el_stack lft1 v1 in - let el2 = el_stack lft2 v2 in + (** We delay the computation of the lifts that apply to the head of the term + with [el_stack] inside the branches where they are actually used. *) match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> @@ -354,6 +388,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) @@ -362,6 +398,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in if Int.equal (reloc_rel n el1) (reloc_rel m el2) then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible @@ -396,25 +434,27 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Projections: prefer unfolding to first-order unification, which will happen naturally if the terms c1, c2 are not in constructor form *) - (match unfold_projection infos p1 c1 with - | Some (def1,s1) -> - eqappr cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv + (match unfold_projection infos p1 with + | Some s1 -> + eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv | None -> - match unfold_projection infos p2 c2 with - | Some (def2,s2) -> - eqappr cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv + match unfold_projection infos p2 with + | Some s2 -> + eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> if Constant.equal (Projection.constant p1) (Projection.constant p2) && compare_stack_shape v1 v2 then + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> - (match unfold_projection infos p1 c1 with - | Some (def1,s1) -> - eqappr cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv + (match unfold_projection infos p1 with + | Some s1 -> + eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv | None -> (match t2 with | FFlex fl2 -> @@ -425,9 +465,9 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> raise NotConvertible)) | (t1, FProj (p2,c2)) -> - (match unfold_projection infos p2 c2 with - | Some (def2,s2) -> - eqappr cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv + (match unfold_projection infos p2 with + | Some s2 -> + eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> (match t1 with | FFlex fl1 -> @@ -445,6 +485,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv @@ -452,6 +494,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv @@ -479,7 +523,13 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv + (** By virtue of the previous case analyses, we know [c2] is rigid. + Conversion check to rigid terms eventually implies full weak-head + reduction, so instead of repeatedly performing small-step + unfoldings, we perform reduction with all flags on. *) + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos)) in + let r1 = whd_stack (infos_with_reds infos all) def1 v1 in + eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv | None -> match c2 with | FConstruct ((ind2,j2),u2) -> @@ -493,7 +543,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv + (** Symmetrical case of above. *) + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos)) in + let r2 = whd_stack (infos_with_reds infos all) def2 v2 in + eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv | None -> match c1 with | FConstruct ((ind1,j1),u1) -> @@ -511,15 +564,12 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else let mind = Environ.lookup_mind (fst ind1) (info_env infos) in - let cuniv = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - convert_instances ~flex:false u1 u2 cuniv - | Declarations.Cumulative_ind cumi -> - convert_inductives cv_pb (mind, snd ind1) u1 (CClosure.stack_args_size v1) - u2 (CClosure.stack_args_size v2) cuniv - in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + let nargs = CClosure.stack_args_size v1 in + if not (Int.equal nargs (CClosure.stack_args_size v2)) + then raise NotConvertible + else + let cuniv = convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> @@ -529,16 +579,12 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else let mind = Environ.lookup_mind (fst ind1) (info_env infos) in - let cuniv = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - convert_instances ~flex:false u1 u2 cuniv - | Declarations.Cumulative_ind _ -> - convert_constructors - (mind, snd ind1, j1) u1 (CClosure.stack_args_size v1) - u2 (CClosure.stack_args_size v2) cuniv - in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + let nargs = CClosure.stack_args_size v1 in + if not (Int.equal nargs (CClosure.stack_args_size v2)) + then raise NotConvertible + else + let cuniv = convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Eta expansion of records *) @@ -564,6 +610,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = convert_vect l2r infos @@ -579,6 +627,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = convert_vect l2r infos @@ -655,84 +705,14 @@ let check_convert_instances ~flex u u' univs = else raise NotConvertible (* general conversion and inference functions *) -let infer_check_conv_inductives - infer_check_convert_instances - infer_check_inductive_instances - cv_pb (mind, ind) u1 sv1 u2 sv2 univs = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - infer_check_convert_instances ~flex:false u1 u2 univs - | Declarations.Cumulative_ind cumi -> - let num_param_arity = - mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - in - if not (num_param_arity = sv1 && num_param_arity = sv2) then - infer_check_convert_instances ~flex:false u1 u2 univs - else - infer_check_inductive_instances cv_pb cumi u1 u2 univs - -let infer_check_conv_constructors - infer_check_convert_instances - infer_check_inductive_instances - (mind, ind, cns) u1 sv1 u2 sv2 univs = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - infer_check_convert_instances ~flex:false u1 u2 univs - | Declarations.Cumulative_ind cumi -> - let num_cnstr_args = - let nparamsctxt = - mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - (* Context.Rel.length mind.Declarations.mind_params_ctxt *) in - nparamsctxt + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(cns - 1) - in - if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then - infer_check_convert_instances ~flex:false u1 u2 univs - else - infer_check_inductive_instances CONV cumi u1 u2 univs - -let check_inductive_instances cv_pb cumi u u' univs = - let length_ind_instance = - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) - in - let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((length_ind_instance = Univ.Instance.length u) && - (length_ind_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in - let comp_cst = - match cv_pb with - CONV -> - let comp_cst' = - let comp_subst = (Univ.Instance.append u' u) in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in - Univ.Constraint.union comp_cst comp_cst' - | CUMUL -> comp_cst - in - if (UGraph.check_constraints comp_cst univs) then univs - else raise NotConvertible - -let check_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = - infer_check_conv_inductives - check_convert_instances - check_inductive_instances - cv_pb ind u1 sv1 u2 sv2 univs - -let check_conv_constructors cns u1 sv1 u2 sv2 univs = - infer_check_conv_constructors - check_convert_instances - check_inductive_instances - cns u1 sv1 u2 sv2 univs +let check_inductive_instances csts univs = + if (UGraph.check_constraints csts univs) then univs + else raise NotConvertible let checked_universes = - { compare = checked_sort_cmp_universes; + { compare_sorts = checked_sort_cmp_universes; compare_instances = check_convert_instances; - conv_inductives = check_conv_inductives; - conv_constructors = check_conv_constructors} + compare_cumul_instances = check_inductive_instances; } let infer_eq (univs, cstrs as cuniv) u u' = if UGraph.check_eq univs u u' then cuniv @@ -775,49 +755,13 @@ let infer_convert_instances ~flex u u' (univs,cstrs) = else Univ.enforce_eq_instances u u' cstrs in (univs, cstrs') -let infer_inductive_instances cv_pb cumi u u' (univs, cstrs) = - let length_ind_instance = - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) - in - let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((length_ind_instance = Univ.Instance.length u) && - (length_ind_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in - let comp_cst = - match cv_pb with - CONV -> - let comp_cst' = - let comp_subst = (Univ.Instance.append u' u) in - Univ.AUContext.instantiate comp_subst ind_subtypctx - in - Univ.Constraint.union comp_cst comp_cst' - | CUMUL -> comp_cst - in - (univs, Univ.Constraint.union cstrs comp_cst) - - -let infer_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = - infer_check_conv_inductives - infer_convert_instances - infer_inductive_instances - cv_pb ind u1 sv1 u2 sv2 univs - -let infer_conv_constructors cns u1 sv1 u2 sv2 univs = - infer_check_conv_constructors - infer_convert_instances - infer_inductive_instances - cns u1 sv1 u2 sv2 univs - -let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = - { compare = infer_cmp_universes; +let infer_inductive_instances csts (univs,csts') = + (univs, Univ.Constraint.union csts csts') + +let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = + { compare_sorts = infer_cmp_universes; compare_instances = infer_convert_instances; - conv_inductives = infer_conv_inductives; - conv_constructors = infer_conv_constructors} + compare_cumul_instances = infer_inductive_instances; } let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = @@ -833,8 +777,8 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then - let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs + let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in + CProfile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs else gen_conv cv_pb l2r reds env evars univs let conv = gen_conv CONV @@ -860,8 +804,8 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = (* Profiling *) let infer_conv_universes = if Flags.profile then - let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" in - Profile.profile8 infer_conv_universes_key infer_conv_universes + let infer_conv_universes_key = CProfile.declare_profile "infer_conv_universes" in + CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) @@ -895,13 +839,13 @@ let default_conv cv_pb ?(l2r=false) env t1 t2 = let default_conv_leq = default_conv CUMUL (* -let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; +let convleqkey = CProfile.declare_profile "Kernel_reduction.conv_leq";; let conv_leq env t1 t2 = - Profile.profile4 convleqkey conv_leq env t1 t2;; + CProfile.profile4 convleqkey conv_leq env t1 t2;; -let convkey = Profile.declare_profile "Kernel_reduction.conv";; +let convkey = CProfile.declare_profile "Kernel_reduction.conv";; let conv env t1 t2 = - Profile.profile4 convleqkey conv env t1 t2;; + CProfile.profile4 convleqkey conv env t1 t2;; *) (* Application with on-the-fly reduction *) @@ -938,6 +882,18 @@ let hnf_prod_app env t n = let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl +let hnf_prod_applist_assum env n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Too many arguments.") + else match kind (whd_allnolet env t), l with + | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") + | _ -> anomaly (Pp.str "Not enough prod/let's.") in + app n [] c l + (* Dealing with arities *) let dest_prod env = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 05a906e28..6f7e3f8f8 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -35,21 +35,23 @@ type 'a extended_conversion_function = type conv_pb = CONV | CUMUL -type 'a universe_compare = +type 'a universe_compare = { (* Might raise NotConvertible *) - compare : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> - Univ.Instance.t -> int -> 'a -> 'a; - conv_constructors : (Declarations.mutual_inductive_body * int * int) -> - Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; - } + compare_cumul_instances : Univ.Constraint.t -> 'a -> 'a } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t + +val get_cumulativity_constraints : conv_pb -> Univ.ACumulativityInfo.t -> + Univ.Instance.t -> Univ.Instance.t -> Univ.Constraint.t + +val inductive_cumulativity_arguments : (Declarations.mutual_inductive_body * int) -> int +val constructor_cumulativity_arguments : (Declarations.mutual_inductive_body * int * int) -> int val sort_cmp_universes : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a * 'a universe_compare -> 'a * 'a universe_compare @@ -103,6 +105,12 @@ val beta_app : constr -> constr -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types +(** In [hnf_prod_applist_assum n c args], [c] is supposed to (whd-)reduce to + the form [∀Γ.t] with [Γ] of length [n] and possibly with let-ins; it + returns [t] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val hnf_prod_applist_assum : env -> int -> types -> constr list -> types + (** Compatibility alias for Term.lambda_appvect_assum *) val betazeta_appvect : int -> constr -> constr array -> constr diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 0e41bfc3c..93b8e278f 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -382,23 +382,9 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let open Entries in - let trust = Term_typing.SideEffects senv.revstruct in - let c,typ,univs = Term_typing.translate_local_def trust senv.env id de in - let poly = match de.Entries.const_entry_universes with - | Monomorphic_const_entry _ -> false - | Polymorphic_const_entry _ -> true - in - let c, univs = match c with - | Def c -> Mod_subst.force_constr c, univs - | OpaqueDef o -> - Opaqueproof.force_proof (Environ.opaque_tables senv.env) o, - Univ.ContextSet.union univs - (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) - | _ -> assert false in - let senv' = push_context_set poly univs senv in - let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in - univs, {senv' with env=env''} + let c, typ = Term_typing.translate_local_def senv.env id de in + let env'' = safe_push_named (LocalDef (id, c, typ)) senv.env in + { senv with env = env'' } let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in @@ -858,7 +844,7 @@ let export ?except senv dir = } in let ast, symbols = - if !Flags.native_compiler then + if !Flags.output_native_objects then Nativelibrary.dump_library mp dir senv.env str else [], Nativecode.empty_symbols in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 0bfe07486..757b803a3 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -90,7 +90,7 @@ val push_named_assum : (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : - Id.t * private_constants Entries.definition_entry -> Univ.ContextSet.t safe_transformer + Id.t * Entries.section_def_entry -> safe_transformer0 (** Insertion of global axioms or definitions *) @@ -106,8 +106,8 @@ type exported_private_constant = Constant.t * private_constant_role val export_private_constants : in_section:bool -> - private_constants Entries.constant_entry -> - (unit Entries.constant_entry * exported_private_constant list) safe_transformer + private_constants Entries.definition_entry -> + (unit Entries.definition_entry * exported_private_constant list) safe_transformer (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) @@ -139,7 +139,7 @@ val push_context : bool -> Univ.UContext.t -> safe_transformer0 val add_constraints : - Univ.constraints -> safe_transformer0 + Univ.Constraint.t -> safe_transformer0 (* (\** Generator of universes *\) *) (* val next_universe : int safe_transformer *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 2913c6dfa..e95d5d2b5 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -118,6 +118,15 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let env = check_polymorphic_instance error env auctx auctx' in env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> + (** Currently there is no way to control variance of inductive types, but + just in case we require that they are in a subtyping relation. *) + let () = + let v = ACumulativityInfo.variance cumi in + let v' = ACumulativityInfo.variance cumi' in + if not (Array.for_all2 Variance.check_subtype v' v) then + CErrors.anomaly Pp.(str "Variance of " ++ KerName.print kn1 ++ + str " is not compatible with the one of " ++ KerName.print kn2) + in let auctx = Univ.ACumulativityInfo.univ_context cumi in let auctx' = Univ.ACumulativityInfo.univ_context cumi' in let env = check_polymorphic_instance error env auctx auctx' in @@ -193,7 +202,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (arities_of_specif (mind, inst) (mib2, p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in - check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); + check (fun mib -> mib.mind_finite<>CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x); assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps); assert (Array.length mib1.mind_packets >= 1 diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index b24c20aa0..67df3759e 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -10,4 +10,4 @@ open Univ open Declarations open Environ -val check_subtypes : env -> module_type_body -> module_type_body -> constraints +val check_subtypes : env -> module_type_body -> module_type_body -> Constraint.t diff --git a/kernel/term.ml b/kernel/term.ml index aa8805952..a4c92bd33 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -92,7 +92,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | CoFix of ('constr, 'types) pcofixpoint | Proj of projection * 'constr -type values = Constr.values +type values = Vmvalues.values (**********************************************************************) (** Redeclaration of functions from module Constr *) @@ -352,10 +352,11 @@ let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments.") + else anomaly (Pp.str "Too many arguments.") else match kind_of_term t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") | _ -> anomaly (Pp.str "Not enough lambda/let's.") in app n [] c l @@ -377,10 +378,11 @@ let prod_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments.") + else anomaly (Pp.str "Too many arguments.") else match kind_of_term t, l with | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l diff --git a/kernel/term.mli b/kernel/term.mli index f5cb72f4e..b4597676a 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -242,7 +242,7 @@ val lambda_applist : constr -> constr list -> constr val lambda_appvect : constr -> constr array -> constr (** In [lambda_applist_assum n c args], [c] is supposed to have the - form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it + form [λΓ.c] with [Γ] of length [n] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) val lambda_applist_assum : int -> constr -> constr list -> constr @@ -251,15 +251,15 @@ val lambda_appvect_assum : int -> constr -> constr array -> constr (** pseudo-reduction rule *) (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) -val prod_appvect : constr -> constr array -> constr -val prod_applist : constr -> constr list -> constr +val prod_appvect : types -> constr array -> types +val prod_applist : types -> constr list -> types (** In [prod_appvect_assum n c args], [c] is supposed to have the - form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it + form [∀Γ.c] with [Γ] of length [n] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) -val prod_appvect_assum : int -> constr -> constr array -> constr -val prod_applist_assum : int -> constr -> constr list -> constr +val prod_appvect_assum : int -> types -> constr array -> types +val prod_applist_assum : int -> types -> constr list -> types (** {5 Other term destructors. } *) @@ -572,8 +572,8 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Proj of projection * 'constr [@@ocaml.deprecated "Alias for Constr.kind_of_term"] -type values = Constr.values -[@@ocaml.deprecated "Alias for Constr.values"] +type values = Vmvalues.values +[@@ocaml.deprecated "Alias for Vmvalues.values"] val hash_constr : Constr.constr -> int [@@ocaml.deprecated "Alias for Constr.hash"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 70dd6438d..9b864440d 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -223,21 +223,18 @@ let rec unzip ctx j = unzip ctx { j with uj_val = mkApp (mkLambda (n,ty,j.uj_val),arg) } let feedback_completion_typecheck = - let open Feedback in Option.iter (fun state_id -> - feedback ~id:state_id Feedback.Complete) + Feedback.feedback ~id:state_id Feedback.Complete) -let abstract_constant_universes abstract = function +let abstract_constant_universes = function | Monomorphic_const_entry uctx -> Univ.empty_level_subst, Monomorphic_const uctx | Polymorphic_const_entry uctx -> - if not abstract then - Univ.empty_level_subst, Monomorphic_const (Univ.ContextSet.of_context uctx) - else - let sbst, auctx = Univ.abstract_universes uctx in - sbst, Polymorphic_const auctx + let sbst, auctx = Univ.abstract_universes uctx in + let sbst = Univ.make_instance_subst sbst in + sbst, Polymorphic_const auctx -let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry) = +let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = match dcl with | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with @@ -245,10 +242,7 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env in let j = infer env t in - let abstract = not (Option.is_empty kn) in - let usubst, univs = - abstract_constant_universes abstract uctx - in + let usubst, univs = abstract_constant_universes uctx in let c = Typeops.assumption_of_judgment env j in let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in { @@ -306,22 +300,29 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - let poly, univsctx = match c.const_entry_universes with - | Monomorphic_const_entry univs -> false, univs - | Polymorphic_const_entry univs -> true, Univ.ContextSet.of_context univs - in - let ctx = Univ.ContextSet.union univsctx ctx in let body, ctx, _ = match trust with | Pure -> body, ctx, [] | SideEffects _ -> inline_side_effects env body ctx side_eff in - let env = push_context_set ~strict:(not poly) ctx env in - let abstract = not (Option.is_empty kn) in - let ctx = if poly - then Polymorphic_const_entry (Univ.ContextSet.to_context ctx) - else Monomorphic_const_entry ctx + let env, usubst, univs = match c.const_entry_universes with + | Monomorphic_const_entry univs -> + let ctx = Univ.ContextSet.union univs ctx in + let env = push_context_set ~strict:true ctx env in + env, Univ.empty_level_subst, Monomorphic_const ctx + | Polymorphic_const_entry uctx -> + (** Ensure not to generate internal constraints in polymorphic mode. + The only way for this to happen would be that either the body + contained deferred universes, or that it contains monomorphic + side-effects. The first property is ruled out by upper layers, + and the second one is ensured by the fact we currently + unconditionally export side-effects from polymorphic definitions, + i.e. [trust] is always [Pure]. *) + let () = assert (Univ.ContextSet.is_empty ctx) in + let env = push_context ~strict:false uctx env in + let sbst, auctx = Univ.abstract_universes uctx in + let sbst = Univ.make_instance_subst sbst in + env, sbst, Polymorphic_const auctx in - let usubst, univs = abstract_constant_universes abstract ctx in let j = infer env body in let typ = match typ with | None -> @@ -493,7 +494,7 @@ let build_constant_declaration kn env result = let translate_constant mb env kn ce = build_constant_declaration kn env - (infer_declaration ~trust:mb env (Some kn) ce) + (infer_declaration ~trust:mb env ce) let constant_entry_of_side_effect cb u = let univs = @@ -533,14 +534,10 @@ type side_effect_role = type exported_side_effect = Constant.t * constant_body * side_effect_role -let export_side_effects mb env ce = - match ce with - | ParameterEntry e -> [], ParameterEntry e - | ProjectionEntry e -> [], ProjectionEntry e - | DefinitionEntry c -> +let export_side_effects mb env c = let { const_entry_body = body } = c in let _, eff = Future.force body in - let ce = DefinitionEntry { c with + let ce = { c with const_entry_body = Future.chain body (fun (b_ctx, _) -> b_ctx, ()) } in let not_exists (c,_,_,_) = @@ -609,9 +606,19 @@ let translate_recipe env kn r = let hcons = DirPath.is_empty dir in build_constant_declaration kn env (Cooking.cook_constant ~hcons env r) -let translate_local_def mb env id centry = +let translate_local_def env id centry = let open Cooking in - let decl = infer_declaration ~trust:mb env None (DefinitionEntry centry) in + let body = Future.from_val ((centry.secdef_body, Univ.ContextSet.empty), ()) in + let centry = { + const_entry_body = body; + const_entry_secctx = centry.secdef_secctx; + const_entry_feedback = centry.secdef_feedback; + const_entry_type = centry.secdef_type; + const_entry_universes = Monomorphic_const_entry Univ.ContextSet.empty; + const_entry_opaque = false; + const_entry_inline_code = false; + } in + let decl = infer_declaration ~trust:Pure env (DefinitionEntry centry) in let typ = decl.cook_type in if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with @@ -623,11 +630,22 @@ let translate_local_def mb env id centry = (Opaqueproof.force_proof (opaque_tables env) lc) in record_aux env ids_typ ids_def end; - let univs = match decl.cook_universes with - | Monomorphic_const ctx -> ctx + let () = match decl.cook_universes with + | Monomorphic_const ctx -> assert (Univ.ContextSet.is_empty ctx) | Polymorphic_const _ -> assert false in - decl.cook_body, typ, univs + let c = match decl.cook_body with + | Def c -> Mod_subst.force_constr c + | OpaqueDef o -> + let p = Opaqueproof.force_proof (Environ.opaque_tables env) o in + let cst = Opaqueproof.force_constraints (Environ.opaque_tables env) o in + (** Let definitions are ensured to have no extra constraints coming from + the body by virtue of the typing of [Entries.section_def_entry]. *) + let () = assert (Univ.ContextSet.is_empty cst) in + p + | Undef _ -> assert false + in + c, typ (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 55da4197e..7bc029010 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -18,8 +18,8 @@ type _ trust = | Pure : unit trust | SideEffects : structure_body -> side_effects trust -val translate_local_def : 'a trust -> env -> Id.t -> 'a definition_entry -> - constant_def * types * Univ.ContextSet.t +val translate_local_def : env -> Id.t -> section_def_entry -> + constr * types val translate_local_assum : env -> types -> types @@ -62,8 +62,8 @@ type exported_side_effect = * be pushed in the safe_env by safe typing. The main constant entry * needs to be translated as usual after this step. *) val export_side_effects : - structure_body -> env -> side_effects constant_entry -> - exported_side_effect list * unit constant_entry + structure_body -> env -> side_effects definition_entry -> + exported_side_effect list * unit definition_entry val translate_mind : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body @@ -72,7 +72,7 @@ val translate_recipe : env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : trust:'a trust -> env -> Constant.t option -> +val infer_declaration : trust:'a trust -> env -> 'a constant_entry -> Cooking.result val build_constant_declaration : diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 3a1f2ae00..781c6bfbc 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -59,7 +59,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index e4fa65686..72861f6e4 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -60,7 +60,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error @@ -105,4 +105,4 @@ val error_ill_typed_rec_body : val error_elim_explain : Sorts.family -> Sorts.family -> arity_error -val error_unsatisfied_constraints : env -> Univ.constraints -> 'a +val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 4ccef5c38..4a935f581 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -435,8 +435,8 @@ let infer env constr = let infer = if Flags.profile then - let infer_key = Profile.declare_profile "Fast_infer" in - Profile.profile2 infer_key (fun b c -> infer b c) + let infer_key = CProfile.declare_profile "Fast_infer" in + CProfile.profile2 infer_key (fun b c -> infer b c) else (fun b c -> infer b c) let assumption_of_judgment env {uj_val=c; uj_type=t} = diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 00c0ea70d..f1e8d1031 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -890,24 +890,24 @@ let dump_universes output g = let merge_constraints = if Flags.profile then - let key = Profile.declare_profile "merge_constraints" in - Profile.profile2 key merge_constraints + let key = CProfile.declare_profile "merge_constraints" in + CProfile.profile2 key merge_constraints else merge_constraints let check_constraints = if Flags.profile then - let key = Profile.declare_profile "check_constraints" in - Profile.profile2 key check_constraints + let key = CProfile.declare_profile "check_constraints" in + CProfile.profile2 key check_constraints else check_constraints let check_eq = if Flags.profile then - let check_eq_key = Profile.declare_profile "check_eq" in - Profile.profile3 check_eq_key check_eq + let check_eq_key = CProfile.declare_profile "check_eq" in + CProfile.profile3 check_eq_key check_eq else check_eq let check_leq = if Flags.profile then - let check_leq_key = Profile.declare_profile "check_leq" in - Profile.profile3 check_leq_key check_leq + let check_leq_key = CProfile.declare_profile "check_leq" in + CProfile.profile3 check_leq_key check_leq else check_leq diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index b95388ed0..f71d83d85 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -35,10 +35,10 @@ val check_eq_instances : Instance.t check_function constraints are not satisfiable. *) val enforce_constraint : univ_constraint -> t -> t -val merge_constraints : constraints -> t -> t +val merge_constraints : Constraint.t -> t -> t val check_constraint : t -> univ_constraint -> bool -val check_constraints : constraints -> t -> bool +val check_constraints : Constraint.t -> t -> bool (** Adds a universe to the graph, ensuring it is >= or > Set. @raises AlreadyDeclared if the level is already declared in the graph. *) @@ -57,7 +57,7 @@ val empty_universes : t val sort_universes : t -> t -val constraints_of_universes : t -> constraints +val constraints_of_universes : t -> Constraint.t val check_subtype : AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of diff --git a/kernel/univ.ml b/kernel/univ.ml index 64afb95d5..c42b66749 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -192,6 +192,10 @@ module Level = struct let make m n = make (Level (n, Names.DirPath.hcons m)) + let name u = + match data u with + | Level (n, d) -> Some (d, n) + | _ -> None end (** Level maps *) @@ -262,7 +266,7 @@ struct module Expr = struct type t = Level.t * int - + (* Hashing of expressions *) module ExprHash = struct @@ -337,19 +341,16 @@ struct returning [SuperSame] if they refer to the same level at potentially different increments or [SuperDiff] if they are different. The booleans indicate if the left expression is "smaller" than the right one in both cases. *) - let super (u,n as x) (v,n' as y) = + let super (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then SuperSame (n < n') else - match x, y with - | (l,0), (l',0) -> - let open RawLevel in - (match Level.data l, Level.data l' with - | Prop, Prop -> SuperSame false - | Prop, _ -> SuperSame true - | _, Prop -> SuperSame false - | _, _ -> SuperDiff cmp) - | _, _ -> SuperDiff cmp + let open RawLevel in + match Level.data u, n, Level.data v, n' with + | Prop, _, Prop, _ -> SuperSame (n < n') + | Prop, 0, _, _ -> SuperSame true + | _, _, Prop, 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v @@ -486,7 +487,40 @@ struct | [] -> cons a l in List.fold_right (fun a acc -> aux a acc) u [] - + + (** [max_var_pred p u] returns the maximum variable level in [u] satisfying + [p], -1 if not found *) + let rec max_var_pred p u = + let open Level in + match u with + | [] -> -1 + | (v, _) :: u -> + match var_index v with + | Some i when p i -> max i (max_var_pred p u) + | _ -> max_var_pred p u + + let rec remap_var u i j = + let open Level in + match u with + | [] -> [] + | (v, incr) :: u when var_index v = Some i -> + (Level.var j, incr) :: remap_var u i j + | _ :: u -> remap_var u i j + + let rec compact u max_var i = + if i >= max_var then (u,[]) else + let j = max_var_pred (fun j -> j < i) u in + if Int.equal i (j+1) then + let (u,s) = compact u max_var (i+1) in + (u, i :: s) + else + let (u,s) = compact (remap_var u i j) max_var (i+1) in + (u, j+1 :: s) + + let compact u = + let max_var = max_var_pred (fun _ -> true) u in + compact u max_var 0 + (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y @@ -499,6 +533,7 @@ struct let smartmap = List.smartmap + let map = List.map end type universe = Universe.t @@ -684,12 +719,6 @@ let enforce_leq u v c = let enforce_leq_level u v c = if Level.equal u v then c else Constraint.add (u,Le,v) c -let enforce_univ_constraint (u,d,v) = - match d with - | Eq -> enforce_eq u v - | Le -> enforce_leq u v - | Lt -> enforce_leq (super u) v - (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) @@ -716,15 +745,55 @@ type universe_level_subst = universe_level universe_map (** A full substitution might involve algebraic universes *) type universe_subst = universe universe_map -let level_subst_of f = - fun l -> - try let u = f l in - match Universe.level u with - | None -> l - | Some l -> l - with Not_found -> l - -module Instance : sig +module Variance = +struct + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + + let sup x y = + match x, y with + | Irrelevant, s | s, Irrelevant -> s + | Invariant, _ | _, Invariant -> Invariant + | Covariant, Covariant -> Covariant + + let check_subtype x y = match x, y with + | (Irrelevant | Covariant | Invariant), Irrelevant -> true + | Irrelevant, Covariant -> false + | (Covariant | Invariant), Covariant -> true + | (Irrelevant | Covariant), Invariant -> false + | Invariant, Invariant -> true + + let pr = function + | Irrelevant -> str "*" + | Covariant -> str "+" + | Invariant -> str "=" + + let leq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant -> enforce_leq_level u u' csts + | Invariant -> enforce_eq_level u u' csts + + let eq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant | Invariant -> enforce_eq_level u u' csts + + let leq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 leq_constraint csts variance u u' + + let eq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 eq_constraint csts variance u u' +end + +module Instance : sig type t = Level.t array val empty : t @@ -744,7 +813,7 @@ module Instance : sig val subst_fn : universe_level_subst_fn -> t -> t - val pr : (Level.t -> Pp.t) -> t -> Pp.t + val pr : (Level.t -> Pp.t) -> ?variance:Variance.t array -> t -> Pp.t val levels : t -> LSet.t end = struct @@ -820,8 +889,12 @@ struct let levels x = LSet.of_array x - let pr = - prvect_with_sep spc + let pr prl ?variance = + let ppu i u = + let v = Option.map (fun v -> v.(i)) variance in + pr_opt_no_spc Variance.pr v ++ prl u + in + prvecti_with_sep spc ppu let equal t u = t == u || @@ -885,9 +958,9 @@ struct let empty = (Instance.empty, Constraint.empty) let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst - let pr prl (univs, cst as ctx) = + let pr prl ?variance (univs, cst as ctx) = if is_empty ctx then mt() else - h 0 (Instance.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) + h 0 (Instance.pr prl ?variance univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) @@ -923,66 +996,42 @@ end type abstract_universe_context = AUContext.t let hcons_abstract_universe_context = AUContext.hcons -(** Universe info for cumulative inductive types: - A context of universe levels - with universe constraints, representing local universe variables - and constraints, together with a context of universe levels with - universe constraints, representing conditions for subtyping used - for inductive types. +(** Universe info for cumulative inductive types: A context of + universe levels with universe constraints, representing local + universe variables and constraints, together with an array of + Variance.t. - This data structure maintains the invariant that the context for - subtyping constraints is exactly twice as big as the context for - universe constraints. *) + This data structure maintains the invariant that the variance + array has the same length as the universe instance. *) module CumulativityInfo = struct - type t = universe_context * universe_context + type t = universe_context * Variance.t array let make x = - if (Instance.length (UContext.instance (snd x))) = - (Instance.length (UContext.instance (fst x))) * 2 then x + if (Instance.length (UContext.instance (fst x))) = + (Array.length (snd x)) then x else anomaly (Pp.str "Invalid subtyping information encountered!") - let empty = (UContext.empty, UContext.empty) - let is_empty (univcst, subtypcst) = UContext.is_empty univcst && UContext.is_empty subtypcst - - let halve_context ctx = - let len = Array.length (Instance.to_array ctx) in - let halflen = len / 2 in - (Instance.of_array (Array.sub (Instance.to_array ctx) 0 halflen), - Instance.of_array (Array.sub (Instance.to_array ctx) halflen halflen)) - - let pr prl (univcst, subtypcst) = - if UContext.is_empty univcst then mt() else - let (ctx, ctx') = halve_context (UContext.instance subtypcst) in - (UContext.pr prl univcst) ++ fnl () ++ fnl () ++ - h 0 (str "~@{" ++ Instance.pr prl ctx ++ str "} <= ~@{" ++ Instance.pr prl ctx' ++ str "} iff ") - ++ fnl () ++ h 0 (v 0 (Constraint.pr prl (UContext.constraints subtypcst))) + let empty = (UContext.empty, [||]) + let is_empty (univs, variance) = UContext.is_empty univs && Array.is_empty variance - let hcons (univcst, subtypcst) = - (UContext.hcons univcst, UContext.hcons subtypcst) + let pr prl (univs, variance) = + UContext.pr prl ~variance univs - let univ_context (univcst, subtypcst) = univcst - let subtyp_context (univcst, subtypcst) = subtypcst + let hcons (univs, variance) = (* should variance be hconsed? *) + (UContext.hcons univs, variance) - let create_trivial_subtyping ctx ctx' = - CArray.fold_left_i - (fun i cst l -> Constraint.add (l, Eq, Array.get ctx' i) cst) - Constraint.empty (Instance.to_array ctx) + let univ_context (univs, subtypcst) = univs + let variance (univs, variance) = variance (** This function takes a universe context representing constraints - of an inductive and a Instance.t of fresh universe names for the - subtyping (with the same length as the context in the given - universe context) and produces a UInfoInd.t that with the - trivial subtyping relation. *) - let from_universe_context univcst freshunivs = - let inst = (UContext.instance univcst) in - assert (Instance.length freshunivs = Instance.length inst); - (univcst, UContext.make (Instance.append inst freshunivs, - create_trivial_subtyping inst freshunivs)) - - let subtyping_susbst (univcst, subtypcst) = - let (ctx, ctx') = (halve_context (UContext.instance subtypcst))in - Array.fold_left2 (fun subst l1 l2 -> LMap.add l1 l2 subst) LMap.empty ctx ctx' + of an inductive and produces a CumulativityInfo.t with the + trivial subtyping relation. *) + let from_universe_context univs = + (univs, Array.init (UContext.size univs) (fun _ -> Variance.Invariant)) + + let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts + let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts end @@ -1126,24 +1175,6 @@ let subst_univs_universe fn ul = List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst -let subst_univs_level fn l = - try Some (fn l) - with Not_found -> None - -let subst_univs_constraint fn (u,d,v as c) cstrs = - let u' = subst_univs_level fn u in - let v' = subst_univs_level fn v in - match u', v' with - | None, None -> Constraint.add c cstrs - | Some u, None -> enforce_univ_constraint (u,d,make v) cstrs - | None, Some v -> enforce_univ_constraint (make u,d,v) cstrs - | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs - -let subst_univs_constraints subst csts = - Constraint.fold - (fun c cstrs -> subst_univs_constraint subst c cstrs) - csts Constraint.empty - let make_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> @@ -1166,12 +1197,11 @@ let abstract_universes ctx = (UContext.constraints ctx) in let ctx = UContext.make (instance, cstrs) in - subst, ctx + instance, ctx -let abstract_cumulativity_info (univcst, substcst) = - let instance, univcst = abstract_universes univcst in - let _, substcst = abstract_universes substcst in - (instance, (univcst, substcst)) +let abstract_cumulativity_info (univs, variance) = + let subst, univs = abstract_universes univs in + subst, (univs, variance) (** Pretty-printing *) diff --git a/kernel/univ.mli b/kernel/univ.mli index c06ce2446..74d1bfd3a 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -45,6 +45,8 @@ sig val var : int -> t val var_index : t -> int option + + val name : t -> (Names.DirPath.t * int) option end type universe_level = Level.t @@ -121,6 +123,15 @@ sig val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool + + val map : (Level.t * int -> 'a) -> t -> 'a list + + (** [compact u] remaps local variables in [u] such that their indices become + consecutive. It returns the new universe and the mapping. + Example: compact [(Var 0, i); (Prop, 0); (Var 2; j))] = + [(Var 0,i); (Prop, 0); (Var 1; j)], [0; 2] + *) + val compact : t -> t * int list end type universe = Universe.t @@ -165,20 +176,20 @@ module Constraint : sig end type constraints = Constraint.t +[@@ocaml.deprecated "Use Constraint.t"] -val empty_constraint : constraints -val union_constraint : constraints -> constraints -> constraints -val eq_constraint : constraints -> constraints -> bool +val empty_constraint : Constraint.t +val union_constraint : Constraint.t -> Constraint.t -> Constraint.t +val eq_constraint : Constraint.t -> Constraint.t -> bool -(** A value with universe constraints. *) -type 'a constrained = 'a * constraints +(** A value with universe Constraint.t. *) +type 'a constrained = 'a * Constraint.t (** Constrained *) -val constraints_of : 'a constrained -> constraints +val constraints_of : 'a constrained -> Constraint.t -(** Enforcing constraints. *) - -type 'a constraint_function = 'a -> 'a -> constraints -> constraints +(** Enforcing Constraint.t. *) +type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t val enforce_eq : Universe.t constraint_function val enforce_leq : Universe.t constraint_function @@ -195,7 +206,7 @@ val enforce_leq_level : Level.t constraint_function universes in the path are canonical. Note that each step does not necessarily correspond to an actual constraint, but reflect how the system stores the graph and may result from combination of several - constraints... + Constraint.t... *) type explanation = (constraint_type * Universe.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation option @@ -234,7 +245,22 @@ type universe_level_subst_fn = Level.t -> Level.t type universe_subst = Universe.t universe_map type universe_level_subst = Level.t universe_map -val level_subst_of : universe_subst_fn -> universe_level_subst_fn +module Variance : +sig + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + + (** [check_subtype x y] holds if variance [y] is also an instance of [x] *) + val check_subtype : t -> t -> bool + + val sup : t -> t -> t + + val pr : t -> Pp.t + +end (** {6 Universe instances} *) @@ -271,7 +297,7 @@ sig val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) - val pr : (Level.t -> Pp.t) -> t -> Pp.t + val pr : (Level.t -> Pp.t) -> ?variance:Variance.t array -> t -> Pp.t (** Pretty-printing, no comments *) val levels : t -> LSet.t @@ -290,8 +316,8 @@ val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool -(** A vector of universe levels with universe constraints, - representiong local universe variables and associated constraints *) +(** A vector of universe levels with universe Constraint.t, + representiong local universe variables and associated Constraint.t *) module UContext : sig @@ -303,9 +329,9 @@ sig val is_empty : t -> bool val instance : t -> Instance.t - val constraints : t -> constraints + val constraints : t -> Constraint.t - val dest : t -> Instance.t * constraints + val dest : t -> Instance.t * Constraint.t (** Keeps the order of the instances *) val union : t -> t -> t @@ -324,7 +350,7 @@ sig val repr : t -> UContext.t (** [repr ctx] is [(Var(0), ... Var(n-1) |= cstr] where [n] is the length of - the context and [cstr] the abstracted constraints. *) + the context and [cstr] the abstracted Constraint.t. *) val empty : t val is_empty : t -> bool @@ -338,43 +364,39 @@ sig val union : t -> t -> t val instantiate : Instance.t -> t -> Constraint.t - (** Generate the set of instantiated constraints **) + (** Generate the set of instantiated Constraint.t **) end type abstract_universe_context = AUContext.t [@@ocaml.deprecated "Use AUContext.t"] -(** Universe info for inductive types: A context of universe levels - with universe constraints, representing local universe variables - and constraints, together with a context of universe levels with - universe constraints, representing conditions for subtyping used - for inductive types. +(** Universe info for cumulative inductive types: A context of + universe levels with universe constraints, representing local + universe variables and constraints, together with an array of + Variance.t. - This data structure maintains the invariant that the context for - subtyping constraints is exactly twice as big as the context for - universe constraints. *) + This data structure maintains the invariant that the variance + array has the same length as the universe instance. *) module CumulativityInfo : sig type t - val make : UContext.t * UContext.t -> t + val make : UContext.t * Variance.t array -> t val empty : t val is_empty : t -> bool val univ_context : t -> UContext.t - val subtyp_context : t -> UContext.t + val variance : t -> Variance.t array (** This function takes a universe context representing constraints - of an inductive and a Instance.t of fresh universe names for the - subtyping (with the same length as the context in the given - universe context) and produces a UInfoInd.t that with the - trivial subtyping relation. *) - val from_universe_context : UContext.t -> Instance.t -> t - - val subtyping_susbst : t -> universe_level_subst + of an inductive and produces a CumulativityInfo.t with the + trivial subtyping relation. *) + val from_universe_context : UContext.t -> t + val leq_constraints : t -> Instance.t constraint_function + val eq_constraints : t -> Instance.t constraint_function end type cumulativity_info = CumulativityInfo.t @@ -385,7 +407,9 @@ sig type t val univ_context : t -> AUContext.t - val subtyp_context : t -> AUContext.t + val variance : t -> Variance.t array + val leq_constraints : t -> Instance.t constraint_function + val eq_constraints : t -> Instance.t constraint_function end type abstract_cumulativity_info = ACumulativityInfo.t @@ -413,7 +437,7 @@ sig val diff : t -> t -> t val add_universe : Level.t -> t -> t - val add_constraints : constraints -> t -> t + val add_constraints : Constraint.t -> t -> t val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) @@ -421,14 +445,14 @@ sig val to_context : t -> UContext.t val of_context : UContext.t -> t - val constraints : t -> constraints + val constraints : t -> Constraint.t val levels : t -> LSet.t (** the number of universes in the context *) val size : t -> int end -(** A set of universes with universe constraints. +(** A set of universes with universe Constraint.t. We linearize the set to a list after typechecking. Beware, representation could change. *) @@ -445,7 +469,7 @@ val is_empty_level_subst : universe_level_subst -> bool (** Substitution of universes. *) val subst_univs_level_level : universe_level_subst -> Level.t -> Level.t val subst_univs_level_universe : universe_level_subst -> Universe.t -> Universe.t -val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints +val subst_univs_level_constraints : universe_level_subst -> Constraint.t -> Constraint.t val subst_univs_level_abstract_universe_context : universe_level_subst -> AUContext.t -> AUContext.t val subst_univs_level_instance : universe_level_subst -> Instance.t -> Instance.t @@ -457,28 +481,33 @@ val is_empty_subst : universe_subst -> bool val make_subst : universe_subst -> universe_subst_fn val subst_univs_universe : universe_subst_fn -> Universe.t -> Universe.t -val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +(** Only user in the kernel is template polymorphism. Ideally we get rid of + this code if it goes away. *) (** Substitution of instances *) val subst_instance_instance : Instance.t -> Instance.t -> Instance.t val subst_instance_universe : Instance.t -> Universe.t -> Universe.t val make_instance_subst : Instance.t -> universe_level_subst -val make_inverse_instance_subst : Instance.t -> universe_level_subst +(** Creates [u(0) ↦ 0; ...; u(n-1) ↦ n - 1] out of [u(0); ...; u(n - 1)] *) -val abstract_universes : UContext.t -> universe_level_subst * AUContext.t +val make_inverse_instance_subst : Instance.t -> universe_level_subst -val abstract_cumulativity_info : CumulativityInfo.t -> universe_level_subst * ACumulativityInfo.t +val abstract_universes : UContext.t -> Instance.t * AUContext.t +val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t +(** TODO: move universe abstraction out of the kernel *) val make_abstract_instance : AUContext.t -> Instance.t (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.t -val pr_constraints : (Level.t -> Pp.t) -> constraints -> Pp.t -val pr_universe_context : (Level.t -> Pp.t) -> UContext.t -> Pp.t +val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t +val pr_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> + UContext.t -> Pp.t val pr_cumulativity_info : (Level.t -> Pp.t) -> CumulativityInfo.t -> Pp.t -val pr_abstract_universe_context : (Level.t -> Pp.t) -> AUContext.t -> Pp.t +val pr_abstract_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> + AUContext.t -> Pp.t val pr_abstract_cumulativity_info : (Level.t -> Pp.t) -> ACumulativityInfo.t -> Pp.t val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t val explain_universe_inconsistency : (Level.t -> Pp.t) -> @@ -490,7 +519,7 @@ val pr_universe_subst : universe_subst -> Pp.t (** {6 Hash-consing } *) val hcons_univ : Universe.t -> Universe.t -val hcons_constraints : constraints -> constraints +val hcons_constraints : Constraint.t -> Constraint.t val hcons_universe_set : LSet.t -> LSet.t val hcons_universe_context : UContext.t -> UContext.t val hcons_abstract_universe_context : AUContext.t -> AUContext.t @@ -511,6 +540,6 @@ val eq_levels : Level.t -> Level.t -> bool val equal_universes : Universe.t -> Universe.t -> bool [@@ocaml.deprecated "Use Universe.equal"] -(** Universes of constraints *) -val universes_of_constraints : constraints -> LSet.t +(** Universes of Constraint.t *) +val universes_of_constraints : Constraint.t -> LSet.t [@@ocaml.deprecated "Use Constraint.universes_of"] diff --git a/kernel/vars.ml b/kernel/vars.ml index f52d734ef..b3b3eff62 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -133,8 +133,8 @@ let substn_many lamv n c = substrec n c (* -let substkey = Profile.declare_profile "substn_many";; -let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;; +let substkey = CProfile.declare_profile "substn_many";; +let substn_many lamv n c = CProfile.profile3 substkey substn_many lamv n c;; *) let make_subst = function @@ -235,49 +235,6 @@ let subst_vars subst c = substn_vars 1 subst c (** Universe substitutions *) open Constr -let subst_univs_fn_puniverses fn = - let f = Univ.Instance.subst_fn fn in - fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') - -let subst_univs_fn_constr f c = - let changed = ref false in - let fu = Univ.subst_univs_universe f in - let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in - let rec aux t = - match kind t with - | Sort (Sorts.Type u) -> - let u' = fu u in - if u' == u then t else - (changed := true; mkSort (Sorts.sort_of_univ u')) - | Const (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstU (c, u')) - | Ind (i, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkIndU (i, u')) - | Construct (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstructU (c, u')) - | _ -> map aux t - in - let c' = aux c in - if !changed then c' else c - -let subst_univs_constr subst c = - if Univ.is_empty_subst subst then c - else - let f = Univ.make_subst subst in - subst_univs_fn_constr f c - -let subst_univs_constr = - if Flags.profile then - let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" in - Profile.profile2 subst_univs_constr_key subst_univs_constr - else subst_univs_constr - let subst_univs_level_constr subst c = if Univ.is_empty_level_subst subst then c else @@ -347,8 +304,8 @@ let subst_instance_constr subst c = in aux c -(* let substkey = Profile.declare_profile "subst_instance_constr";; *) -(* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst c;; *) +(* let substkey = CProfile.declare_profile "subst_instance_constr";; *) +(* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx diff --git a/kernel/vars.mli b/kernel/vars.mli index 964de4e95..b74d25260 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -129,12 +129,6 @@ val subst_var : Id.t -> constr -> constr open Univ -val subst_univs_fn_constr : universe_subst_fn -> constr -> constr -val subst_univs_fn_puniverses : universe_level_subst_fn -> - 'a puniverses -> 'a puniverses - -val subst_univs_constr : universe_subst -> constr -> constr - (** Level substitutions for polymorphism. *) val subst_univs_level_constr : universe_level_subst -> constr -> constr diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 578a89371..8c7658147 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -3,6 +3,7 @@ open Names open Environ open Reduction open Vm +open Vmvalues open Csymtable let val_of_constr env c = @@ -204,4 +205,4 @@ let vm_conv cv_pb env t1 t2 = let univs = (univs, checked_universes) in let _ = vm_conv_gen cv_pb env univs t1 t2 in () -let _ = Reduction.set_vm_conv vm_conv +let _ = if Coq_config.bytecode_compiler then Reduction.set_vm_conv vm_conv diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 7f727df47..c3c9636e8 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -19,4 +19,4 @@ val vm_conv : conv_pb -> types kernel_conversion_function val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function (** Precompute a VM value from a constr *) -val val_of_constr : env -> constr -> values +val val_of_constr : env -> constr -> Vmvalues.values diff --git a/kernel/vm.ml b/kernel/vm.ml index 51101f88e..352ea74a4 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -6,47 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names -open Sorts -open Constr open Cbytecodes +open Vmvalues external set_drawinstr : unit -> unit = "coq_set_drawinstr" -(******************************************) -(* Utility Functions about Obj ************) -(******************************************) - -external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" -external offset : Obj.t -> int = "coq_offset" - -(*******************************************) -(* Initalization of the abstract machine ***) -(*******************************************) - -external init_vm : unit -> unit = "init_coq_vm" - -let _ = init_vm () - -(*******************************************) -(* Machine code *** ************************) -(*******************************************) - -type tcode -let tcode_of_obj v = ((Obj.obj v):tcode) -let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) - -external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" -external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" -external int_tcode : tcode -> int -> int = "coq_int_tcode" - -external accumulate : unit -> tcode = "accumulate_code" -let accumulate = accumulate () - -external is_accumulate : tcode -> bool = "coq_is_accumulate_code" - let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = @@ -62,106 +28,6 @@ let popstop_code i = let stop = popstop_code 0 -(******************************************************) -(* Abstract data types and utility functions **********) -(******************************************************) - -(* Values of the abstract machine *) -let val_of_obj v = ((Obj.obj v):values) -let crazy_val = (val_of_obj (Obj.repr 0)) - -(* Abstract data *) -type vprod -type vfun -type vfix -type vcofix -type vblock -type arguments - -type vm_env -type vstack = values array - -type vswitch = { - sw_type_code : tcode; - sw_code : tcode; - sw_annot : annot_switch; - sw_stk : vstack; - sw_env : vm_env - } - -(* Representation of values *) -(* + Products : *) -(* - vprod = 0_[ dom | codom] *) -(* dom : values, codom : vfun *) -(* *) -(* + Functions have two representations : *) -(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) -(* C:tcode, fvi : values *) -(* Remark : a function and its environment is the same value. *) -(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) -(* *) -(* + Fixpoints : *) -(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) -(* One single block to represent all of the fixpoints, each fixpoint *) -(* is the pointer to the field holding the pointer to its code, and *) -(* the infix tag is used to know where the block starts. *) -(* - Partial application follows the scheme of partially applied *) -(* functions. Note: only fixpoints not having been applied to its *) -(* recursive argument are coded this way. When the rec. arg. is *) -(* applied, either it's a constructor and the fix reduces, or it's *) -(* and the fix is coded as an accumulator. *) -(* *) -(* + Cofixpoints : see cbytegen.ml *) -(* *) -(* + vblock's encode (non constant) constructors as in Ocaml, but *) -(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) -(* accumulators. *) -(* *) -(* + vm_env is the type of the machine environments (i.e. a function or *) -(* a fixpoint) *) -(* *) -(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) -(* - representation of [accu] : tag_[....] *) -(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) -(* -- 10_[accu|proj name] : a projection blocked by an accu *) -(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) -(* -- 12_[accu|vswitch] : a match blocked by an accu *) -(* -- 13_[fcofix] : a cofix function *) -(* -- 14_[fcofix|val] : a cofix function, val represent the value *) -(* of the function applied to arg1 ... argn *) -(* The [arguments] type, which is abstracted as an array, represents : *) -(* tag[ _ | _ |v1|... | vn] *) -(* Generally the first field is a code pointer. *) - -(* Do not edit this type without editing C code, especially "coq_values.h" *) - -type atom = - | Aid of Vars.id_key - | Aind of inductive - | Atype of Univ.Universe.t - -(* Zippers *) - -type zipper = - | Zapp of arguments - | Zfix of vfix*arguments (* Possibly empty *) - | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) - -type stack = zipper list - -type to_up = values - -type whd = - | Vsort of Sorts.t - | Vprod of vprod - | Vfun of vfun - | Vfix of vfix * arguments option - | Vcofix of vcofix * to_up * arguments option - | Vconstr_const of int - | Vconstr_block of vblock - | Vatom_stk of atom * stack - | Vuniv_level of Univ.Level.t (************************************************) (* Abstract machine *****************************) @@ -178,389 +44,72 @@ external push_vstack : vstack -> int -> unit = "coq_push_vstack" external interprete : tcode -> values -> vm_env -> int -> values = "coq_interprete_ml" - - (* Functions over arguments *) -let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then - val_of_obj (Obj.field (Obj.repr args) (i+2)) - else invalid_arg - ("Vm.arg size = "^(string_of_int (nargs args))^ - " acces "^(string_of_int i)) (* Apply a value to arguments contained in [vargs] *) let apply_arguments vf vargs = let n = nargs vargs in - if Int.equal n 0 then vf + if Int.equal n 0 then fun_val vf else begin push_ra stop; push_arguments vargs; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + interprete (fun_code vf) (fun_val vf) (fun_env vf) (n - 1) end (* Apply value [vf] to an array of argument values [varray] *) let apply_varray vf varray = let n = Array.length varray in - if Int.equal n 0 then vf + if Int.equal n 0 then fun_val vf else begin push_ra stop; (* The fun code of [vf] will make sure we have enough stack, so we put 0 here. *) push_vstack varray 0; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + interprete (fun_code vf) (fun_val vf) (fun_env vf) (n - 1) end -(*************************************************) -(* Destructors ***********************************) -(*************************************************) - -let uni_lvl_val (v : values) : Univ.Level.t = - let whd = Obj.magic v in - match whd with - | Vuniv_level lvl -> lvl - | _ -> - let pr = - let open Pp in - match whd with - | Vsort _ -> str "Vsort" - | Vprod _ -> str "Vprod" - | Vfun _ -> str "Vfun" - | Vfix _ -> str "Vfix" - | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk" - | _ -> assert false - in - CErrors.anomaly - Pp.( strbrk "Parsing virtual machine value expected universe level, got " - ++ pr ++ str ".") - -let rec whd_accu a stk = - let stk = - if Int.equal (Obj.size a) 2 then stk - else Zapp (Obj.obj a) :: stk in - let at = Obj.field a 1 in - match Obj.tag at with - | i when Int.equal i type_atom_tag -> - begin match stk with - | [Zapp args] -> - let u = ref (Obj.obj (Obj.field at 0)) in - for i = 0 to nargs args - 1 do - u := Univ.Universe.sup !u (Univ.Universe.make (uni_lvl_val (arg args i))) - done; - Vsort (Type !u) - | _ -> assert false - end - | i when i <= max_atom_tag -> - Vatom_stk(Obj.magic at, stk) - | i when Int.equal i proj_tag -> - let zproj = Zproj (Obj.obj (Obj.field at 0)) in - whd_accu (Obj.field at 1) (zproj :: stk) - | i when Int.equal i fix_app_tag -> - let fa = Obj.field at 1 in - let zfix = - Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in - whd_accu (Obj.field at 0) (zfix :: stk) - | i when Int.equal i switch_tag -> - let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in - whd_accu (Obj.field at 0) (zswitch :: stk) - | i when Int.equal i cofix_tag -> - let vcfx = Obj.obj (Obj.field at 0) in - let to_up = Obj.obj a in - begin match stk with - | [] -> Vcofix(vcfx, to_up, None) - | [Zapp args] -> Vcofix(vcfx, to_up, Some args) - | _ -> assert false - end - | i when Int.equal i cofix_evaluated_tag -> - let vcofix = Obj.obj (Obj.field at 0) in - let res = Obj.obj a in - begin match stk with - | [] -> Vcofix(vcofix, res, None) - | [Zapp args] -> Vcofix(vcofix, res, Some args) - | _ -> assert false - end - | tg -> - CErrors.anomaly - Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") - -external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" - -let whd_val : values -> whd = - fun v -> - let o = Obj.repr v in - if Obj.is_int o then Vconstr_const (Obj.obj o) - else - let tag = Obj.tag o in - if tag = accu_tag then - ( - if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) - else - if is_accumulate (fun_code o) then whd_accu o [] - else Vprod(Obj.obj o)) - else - if tag = Obj.closure_tag || tag = Obj.infix_tag then - (match kind_of_closure o with - | 0 -> Vfun(Obj.obj o) - | 1 -> Vfix(Obj.obj o, None) - | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) - | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) - else - Vconstr_block(Obj.obj o) - -(**********************************************) -(* Constructors *******************************) -(**********************************************) - -let obj_of_atom : atom -> Obj.t = - fun a -> - let res = Obj.new_block accu_tag 2 in - Obj.set_field res 0 (Obj.repr accumulate); - Obj.set_field res 1 (Obj.repr a); - res - -(* obj_of_str_const : structured_constant -> Obj.t *) -let rec obj_of_str_const str = - match str with - | Const_sorts s -> Obj.repr (Vsort s) - | Const_ind ind -> obj_of_atom (Aind ind) - | Const_proj p -> Obj.repr p - | Const_b0 tag -> Obj.repr tag - | Const_bn(tag, args) -> - let len = Array.length args in - let res = Obj.new_block tag len in - for i = 0 to len - 1 do - Obj.set_field res i (obj_of_str_const args.(i)) - done; - res - | Const_univ_level l -> Obj.repr (Vuniv_level l) - | Const_type u -> obj_of_atom (Atype u) - -let val_of_obj o = ((Obj.obj o) : values) - -let val_of_str_const str = val_of_obj (obj_of_str_const str) - -let val_of_atom a = val_of_obj (obj_of_atom a) - -let atom_of_proj kn v = - let r = Obj.new_block proj_tag 2 in - Obj.set_field r 0 (Obj.repr kn); - Obj.set_field r 1 (Obj.repr v); - ((Obj.obj r) : atom) - -let val_of_proj kn v = - val_of_atom (atom_of_proj kn v) - -module IdKeyHash = -struct - type t = Constant.t tableKey - let equal = Names.eq_table_key Constant.equal - open Hashset.Combine - let hash = function - | ConstKey c -> combinesmall 1 (Constant.hash c) - | VarKey id -> combinesmall 2 (Id.hash id) - | RelKey i -> combinesmall 3 (Int.hash i) -end - -module KeyTable = Hashtbl.Make(IdKeyHash) - -let idkey_tbl = KeyTable.create 31 - -let val_of_idkey key = - try KeyTable.find idkey_tbl key - with Not_found -> - let v = val_of_atom (Aid key) in - KeyTable.add idkey_tbl key v; - v - -let val_of_rel k = val_of_idkey (RelKey k) - -let val_of_named id = val_of_idkey (VarKey id) - -let val_of_constant c = val_of_idkey (ConstKey c) - -external val_of_annot_switch : annot_switch -> values = "%identity" - +(* Functions over vfun *) let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) - -(*************************************************) -(** Operations manipulating data types ***********) -(*************************************************) - -(* Functions over products *) - -let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) -let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) - -(* Functions over vfun *) - -external closure_arity : vfun -> int = "coq_closure_arity" - -let body_of_vfun k vf = +let reduce_fun k vf = let vargs = mkrel_vstack k 1 in - apply_varray (Obj.magic vf) vargs + apply_varray vf vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in - let v1 = apply_varray (Obj.magic vf1) vargs in - let v2 = apply_varray (Obj.magic vf2) vargs in + let v1 = apply_varray vf1 vargs in + let v2 = apply_varray vf2 vargs in arity, v1, v2 -(* Functions over fixpoint *) - -let first o = (offset_closure o (offset o)) -let last o = (Obj.field o (Obj.size o - 1)) - -let current_fix vf = - (offset (Obj.repr vf) / 2) - -let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) - -let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 - -let rec_args vf = - let fb = first (Obj.repr vf) in - let size = Obj.size (last fb) in - Array.init size (unsafe_rec_arg fb) - -exception FALSE - -let check_fix f1 f2 = - let i1, i2 = current_fix f1, current_fix f2 in - (* Checking starting point *) - if i1 = i2 then - let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in - let n = Obj.size (last fb1) in - (* Checking number of definitions *) - if n = Obj.size (last fb2) then - (* Checking recursive arguments *) - try - for i = 0 to n - 1 do - if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i - then raise FALSE - done; - true - with FALSE -> false - else false - else false - (* Functions over vfix *) -external atom_rel : unit -> atom array = "get_coq_atom_tbl" -external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" - -let relaccu_tbl = - let atom_rel = atom_rel() in - let len = Array.length atom_rel in - for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; - ref (Array.init len mkAccuCode) - -let relaccu_code i = - let len = Array.length !relaccu_tbl in - if i < len then !relaccu_tbl.(i) - else - begin - realloc_atom_rel i; - let atom_rel = atom_rel () in - let nl = Array.length atom_rel in - for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; - relaccu_tbl := - Array.init nl - (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); - !relaccu_tbl.(i) - end let reduce_fix k vf = - let fb = first (Obj.repr vf) in + let fb = first_fix vf in (* computing types *) - let fc_typ = ((Obj.obj (last fb)) : tcode array) in + let fc_typ = fix_types fb in let ndef = Array.length fc_typ in - let et = offset_closure fb (2*(ndef - 1)) in + let et = offset_closure_fix fb (2*(ndef - 1)) in let ftyp = Array.map - (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in + (fun c -> interprete c crazy_val et 0) fc_typ in (* Construction of the environment of fix bodies *) - let e = Obj.dup fb in - for i = 0 to ndef - 1 do - Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) - done; - let fix_body i = - let jump_grabrec c = offset_tcode c 2 in - let c = jump_grabrec (unsafe_fb_code fb i) in - let res = Obj.new_block Obj.closure_tag 2 in - Obj.set_field res 0 (Obj.repr c); - Obj.set_field res 1 (offset_closure e (2*i)); - ((Obj.obj res) : vfun) in - (Array.init ndef fix_body, ftyp) - -(* Functions over vcofix *) - -let get_fcofix vcf i = - match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with - | Vcofix(vcfi, _, _) -> vcfi - | _ -> assert false - -let current_cofix vcf = - let ndef = Obj.size (last (Obj.repr vcf)) in - let rec find_cofix pos = - if pos < ndef then - if get_fcofix vcf pos == vcf then pos - else find_cofix (pos+1) - else raise Not_found in - try find_cofix 0 - with Not_found -> assert false - -let check_cofix vcf1 vcf2 = - (current_cofix vcf1 = current_cofix vcf2) && - (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) + (mk_fix_body k ndef fb, ftyp) let reduce_cofix k vcf = - let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in + let fc_typ = cofix_types vcf in let ndef = Array.length fc_typ in let ftyp = (* Evaluate types *) - Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in + Array.map (fun c -> interprete c crazy_val (cofix_env vcf) 0) fc_typ in (* Construction of the environment of cofix bodies *) - let e = Obj.dup (Obj.repr vcf) in - for i = 0 to ndef - 1 do - Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) - done; - - let cofix_body i = - let vcfi = get_fcofix vcf i in - let c = Obj.field (Obj.repr vcfi) 0 in - Obj.set_field e 0 c; - let atom = Obj.new_block cofix_tag 1 in - let self = Obj.new_block accu_tag 2 in - Obj.set_field self 0 (Obj.repr accumulate); - Obj.set_field self 1 (Obj.repr atom); - apply_varray (Obj.obj e) [|Obj.obj self|] in - (Array.init ndef cofix_body, ftyp) - - -(* Functions over vblock *) - -let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) -let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) -let bfield b i = - if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) - else invalid_arg "Vm.bfield" - - -(* Functions over vswitch *) - -let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl - -let case_info sw = sw.sw_annot.ci + (mk_cofix_body apply_varray k ndef vcf, ftyp) let type_of_switch sw = (* The fun code of types will make sure we have enough stack, so we put 0 @@ -568,20 +117,6 @@ let type_of_switch sw = push_vstack sw.sw_stk 0; interprete sw.sw_type_code crazy_val sw.sw_env 0 -let branch_arg k (tag,arity) = - if Int.equal arity 0 then ((Obj.magic tag):values) - else - let b, ofs = - if tag < last_variant_tag then Obj.new_block tag arity, 0 - else - let b = Obj.new_block last_variant_tag (arity+1) in - Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); - b,1 in - for i = ofs to ofs + arity - 1 do - Obj.set_field b i (Obj.repr (val_of_rel (k+i))) - done; - val_of_obj b - let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then @@ -603,8 +138,8 @@ let branch_of_switch k sw = (* t = a stk --> t v *) let rec apply_stack a stk v = match stk with - | [] -> apply_varray a [|v|] - | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v + | [] -> apply_varray (fun_of_val a) [|v|] + | Zapp args :: stk -> apply_stack (apply_arguments (fun_of_val a) args) stk v | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> let a,stk = @@ -615,7 +150,7 @@ let rec apply_stack a stk v = push_val a; push_arguments args; let a = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fix_code f) (fix_val f) (fix_env f) (nargs args+ nargs args') in a, stk | _ -> @@ -623,7 +158,7 @@ let rec apply_stack a stk v = push_val a; push_arguments args; let a = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fix_code f) (fix_val f) (fix_env f) (nargs args) in a, stk in apply_stack a stk v @@ -634,50 +169,21 @@ let apply_whd k whd = let v = val_of_rel k in match whd with | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false - | Vfun f -> body_of_vfun k f + | Vfun f -> reduce_fun k f | Vfix(f, None) -> push_ra stop; push_val v; - interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0 + interprete (fix_code f) (fix_val f) (fix_env f) 0 | Vfix(f, Some args) -> push_ra stop; push_val v; push_arguments args; - interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) + interprete (fix_code f) (fix_val f) (fix_env f) (nargs args) | Vcofix(_,to_up,_) -> push_ra stop; push_val v; - interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 + interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0 | Vatom_stk(a,stk) -> apply_stack (val_of_atom a) stk v | Vuniv_level lvl -> assert false -let rec pr_atom a = - Pp.(match a with - | Aid c -> str "Aid(" ++ (match c with - | ConstKey c -> Constant.print c - | RelKey i -> str "#" ++ int i - | _ -> str "...") ++ str ")" - | Aind (mi,i) -> str "Aind(" ++ MutInd.print mi ++ str "#" ++ int i ++ str ")" - | Atype _ -> str "Atype(") -and pr_whd w = - Pp.(match w with - | Vsort _ -> str "Vsort" - | Vprod _ -> str "Vprod" - | Vfun _ -> str "Vfun" - | Vfix _ -> str "Vfix" - | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" - | Vuniv_level _ -> assert false) -and pr_stack stk = - Pp.(match stk with - | [] -> str "[]" - | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) -and pr_zipper z = - Pp.(match z with - | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" - | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" - | Zswitch s -> str "Zswitch(...)" - | Zproj c -> str "Zproj(" ++ Constant.print c ++ str ")") diff --git a/kernel/vm.mli b/kernel/vm.mli index bc38452d4..c6d92ba26 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -6,118 +6,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names -open Constr -open Cbytecodes +open Vmvalues (** Debug printing *) val set_drawinstr : unit -> unit -(** Machine code *) - -type tcode - -(** Values *) - -type vprod -type vfun -type vfix -type vcofix -type vblock -type vswitch -type arguments - -type atom = - | Aid of Vars.id_key - | Aind of inductive - | Atype of Univ.Universe.t - -(** Zippers *) - -type zipper = - | Zapp of arguments - | Zfix of vfix * arguments (** might be empty *) - | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) - -type stack = zipper list - -type to_up - -type whd = - | Vsort of Sorts.t - | Vprod of vprod - | Vfun of vfun - | Vfix of vfix * arguments option - | Vcofix of vcofix * to_up * arguments option - | Vconstr_const of int - | Vconstr_block of vblock - | Vatom_stk of atom * stack - | Vuniv_level of Univ.Level.t - -(** For debugging purposes only *) - -val pr_atom : atom -> Pp.t -val pr_whd : whd -> Pp.t -val pr_stack : stack -> Pp.t - -(** Constructors *) - -val val_of_str_const : structured_constant -> values -val val_of_rel : int -> values -val val_of_named : Id.t -> values -val val_of_constant : Constant.t -> values - -external val_of_annot_switch : annot_switch -> values = "%identity" - -(** Destructors *) - -val whd_val : values -> whd -val uni_lvl_val : values -> Univ.Level.t - -(** Arguments *) - -val nargs : arguments -> int -val arg : arguments -> int -> values - -(** Product *) - -val dom : vprod -> values -val codom : vprod -> vfun - -(** Function *) - -val body_of_vfun : int -> vfun -> values -val decompose_vfun2 : int -> vfun -> vfun -> int * values * values - -(** Fix *) - -val current_fix : vfix -> int -val check_fix : vfix -> vfix -> bool -val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array (** bodies , types *) -(** CoFix *) - -val current_cofix : vcofix -> int -val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (** bodies , types *) -(** Block *) +val type_of_switch : vswitch -> values -val btag : vblock -> int -val bsize : vblock -> int -val bfield : vblock -> int -> values +val branch_of_switch : int -> vswitch -> (int * values) array -(** Switch *) +val reduce_fun : int -> vfun -> values -val check_switch : vswitch -> vswitch -> bool -val case_info : vswitch -> case_info -val type_of_switch : vswitch -> values -val branch_of_switch : int -> vswitch -> (int * values) array +(** [decompose_vfun2 k f1 f2] takes two functions [f1] and [f2] at current + DeBruijn level [k], with [n] lambdas in common, returns [n] and the reduced + bodies under those lambdas. *) +val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (** Apply a value *) diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml new file mode 100644 index 000000000..2d8a1d976 --- /dev/null +++ b/kernel/vmvalues.ml @@ -0,0 +1,526 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +open Names +open Sorts +open Cbytecodes +open Univ + +(*******************************************) +(* Initalization of the abstract machine ***) +(* Necessary for [relaccu_tbl] *) +(*******************************************) + +external init_vm : unit -> unit = "init_coq_vm" + +let _ = init_vm () + +(******************************************************) +(* Abstract data types and utility functions **********) +(******************************************************) + +(* Values of the abstract machine *) +type values +let val_of_obj v = ((Obj.obj v):values) +let crazy_val = (val_of_obj (Obj.repr 0)) + +(* Abstract data *) +type vprod +type vfun +type vfix +type vcofix +type vblock +type arguments + +let fun_val v = (Obj.magic v : values) +let fix_val v = (Obj.magic v : values) +let cofix_upd_val v = (Obj.magic v : values) + +type vm_env +let fun_env v = (Obj.magic v : vm_env) +let fix_env v = (Obj.magic v : vm_env) +let cofix_env v = (Obj.magic v : vm_env) +let cofix_upd_env v = (Obj.magic v : vm_env) +type vstack = values array + +let fun_of_val v = (Obj.magic v : vfun) + +(*******************************************) +(* Machine code *** ************************) +(*******************************************) + +type tcode + +external mkAccuCode : int -> tcode = "coq_makeaccu" +external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" + +let tcode_of_obj v = ((Obj.obj v):tcode) +let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) +let fix_code v = fun_code v +let cofix_upd_code v = fun_code v + + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +(* Representation of values *) +(* + Products : *) +(* - vprod = 0_[ dom | codom] *) +(* dom : values, codom : vfun *) +(* *) +(* + Functions have two representations : *) +(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) +(* C:tcode, fvi : values *) +(* Remark : a function and its environment is the same value. *) +(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) +(* *) +(* + Fixpoints : *) +(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) +(* One single block to represent all of the fixpoints, each fixpoint *) +(* is the pointer to the field holding the pointer to its code, and *) +(* the infix tag is used to know where the block starts. *) +(* - Partial application follows the scheme of partially applied *) +(* functions. Note: only fixpoints not having been applied to its *) +(* recursive argument are coded this way. When the rec. arg. is *) +(* applied, either it's a constructor and the fix reduces, or it's *) +(* and the fix is coded as an accumulator. *) +(* *) +(* + Cofixpoints : see cbytegen.ml *) +(* *) +(* + vblock's encode (non constant) constructors as in Ocaml, but *) +(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) +(* accumulators. *) +(* *) +(* + vm_env is the type of the machine environments (i.e. a function or *) +(* a fixpoint) *) +(* *) +(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) +(* - representation of [accu] : tag_[....] *) +(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) +(* -- 10_[accu|proj name] : a projection blocked by an accu *) +(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) +(* -- 12_[accu|vswitch] : a match blocked by an accu *) +(* -- 13_[fcofix] : a cofix function *) +(* -- 14_[fcofix|val] : a cofix function, val represent the value *) +(* of the function applied to arg1 ... argn *) +(* The [arguments] type, which is abstracted as an array, represents : *) +(* tag[ _ | _ |v1|... | vn] *) +(* Generally the first field is a code pointer. *) + +(* Do not edit this type without editing C code, especially "coq_values.h" *) + +type atom = + | Aid of Vars.id_key + | Aind of inductive + | Atype of Univ.Universe.t + +(* Zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix*arguments (* Possibly empty *) + | Zswitch of vswitch + | Zproj of Constant.t (* name of the projection *) + +type stack = zipper list + +type to_update = values + +type whd = + | Vsort of Sorts.t + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix * arguments option + | Vcofix of vcofix * to_update * arguments option + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + | Vuniv_level of Univ.Level.t + +(* Functions over arguments *) +let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 +let arg args i = + if 0 <= i && i < (nargs args) then + val_of_obj (Obj.field (Obj.repr args) (i+2)) + else invalid_arg + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i)) + +(*************************************************) +(* Destructors ***********************************) +(*************************************************) + +let uni_lvl_val (v : values) : Univ.Level.t = + let whd = Obj.magic v in + match whd with + | Vuniv_level lvl -> lvl + | _ -> + let pr = + let open Pp in + match whd with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk" + | _ -> assert false + in + CErrors.anomaly + Pp.( strbrk "Parsing virtual machine value expected universe level, got " + ++ pr ++ str ".") + +let rec whd_accu a stk = + let stk = + if Int.equal (Obj.size a) 2 then stk + else Zapp (Obj.obj a) :: stk in + let at = Obj.field a 1 in + match Obj.tag at with + | i when Int.equal i type_atom_tag -> + begin match stk with + | [Zapp args] -> + let args = Array.init (nargs args) (arg args) in + let u = Obj.obj (Obj.field at 0) in + let inst = Instance.of_array (Array.map uni_lvl_val args) in + let u = Univ.subst_instance_universe inst u in + Vsort (Type u) + | _ -> assert false + end + | i when i <= max_atom_tag -> + Vatom_stk(Obj.magic at, stk) + | i when Int.equal i proj_tag -> + let zproj = Zproj (Obj.obj (Obj.field at 0)) in + whd_accu (Obj.field at 1) (zproj :: stk) + | i when Int.equal i fix_app_tag -> + let fa = Obj.field at 1 in + let zfix = + Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in + whd_accu (Obj.field at 0) (zfix :: stk) + | i when Int.equal i switch_tag -> + let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in + whd_accu (Obj.field at 0) (zswitch :: stk) + | i when Int.equal i cofix_tag -> + let vcfx = Obj.obj (Obj.field at 0) in + let to_up = Obj.obj a in + begin match stk with + | [] -> Vcofix(vcfx, to_up, None) + | [Zapp args] -> Vcofix(vcfx, to_up, Some args) + | _ -> assert false + end + | i when Int.equal i cofix_evaluated_tag -> + let vcofix = Obj.obj (Obj.field at 0) in + let res = Obj.obj a in + begin match stk with + | [] -> Vcofix(vcofix, res, None) + | [Zapp args] -> Vcofix(vcofix, res, Some args) + | _ -> assert false + end + | tg -> + CErrors.anomaly + Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") + +external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" +external is_accumulate : tcode -> bool = "coq_is_accumulate_code" +external int_tcode : tcode -> int -> int = "coq_int_tcode" +external accumulate : unit -> tcode = "accumulate_code" +let accumulate = accumulate () + +let whd_val : values -> whd = + fun v -> + let o = Obj.repr v in + if Obj.is_int o then Vconstr_const (Obj.obj o) + else + let tag = Obj.tag o in + if tag = accu_tag then + ( + if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) + else + if is_accumulate (fun_code o) then whd_accu o [] + else Vprod(Obj.obj o)) + else + if tag = Obj.closure_tag || tag = Obj.infix_tag then + (match kind_of_closure o with + | 0 -> Vfun(Obj.obj o) + | 1 -> Vfix(Obj.obj o, None) + | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) + | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) + | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + else + Vconstr_block(Obj.obj o) + +(**********************************************) +(* Constructors *******************************) +(**********************************************) + +let obj_of_atom : atom -> Obj.t = + fun a -> + let res = Obj.new_block accu_tag 2 in + Obj.set_field res 0 (Obj.repr accumulate); + Obj.set_field res 1 (Obj.repr a); + res + +(* obj_of_str_const : structured_constant -> Obj.t *) +let rec obj_of_str_const str = + match str with + | Const_sorts s -> Obj.repr (Vsort s) + | Const_ind ind -> obj_of_atom (Aind ind) + | Const_proj p -> Obj.repr p + | Const_b0 tag -> Obj.repr tag + | Const_bn(tag, args) -> + let len = Array.length args in + let res = Obj.new_block tag len in + for i = 0 to len - 1 do + Obj.set_field res i (obj_of_str_const args.(i)) + done; + res + | Const_univ_level l -> Obj.repr (Vuniv_level l) + | Const_type u -> obj_of_atom (Atype u) + +let val_of_obj o = ((Obj.obj o) : values) + +let val_of_str_const str = val_of_obj (obj_of_str_const str) + +let val_of_atom a = val_of_obj (obj_of_atom a) + +let atom_of_proj kn v = + let r = Obj.new_block proj_tag 2 in + Obj.set_field r 0 (Obj.repr kn); + Obj.set_field r 1 (Obj.repr v); + ((Obj.obj r) : atom) + +let val_of_proj kn v = + val_of_atom (atom_of_proj kn v) + +module IdKeyHash = +struct + type t = Constant.t tableKey + let equal = Names.eq_table_key Constant.equal + open Hashset.Combine + let hash = function + | ConstKey c -> combinesmall 1 (Constant.hash c) + | VarKey id -> combinesmall 2 (Id.hash id) + | RelKey i -> combinesmall 3 (Int.hash i) +end + +module KeyTable = Hashtbl.Make(IdKeyHash) + +let idkey_tbl = KeyTable.create 31 + +let val_of_idkey key = + try KeyTable.find idkey_tbl key + with Not_found -> + let v = val_of_atom (Aid key) in + KeyTable.add idkey_tbl key v; + v + +let val_of_rel k = val_of_idkey (RelKey k) + +let val_of_named id = val_of_idkey (VarKey id) + +let val_of_constant c = val_of_idkey (ConstKey c) + +external val_of_annot_switch : annot_switch -> values = "%identity" + +(*************************************************) +(** Operations manipulating data types ***********) +(*************************************************) + +(* Functions over products *) + +let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) +let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) + +(* Functions over vfun *) + +external closure_arity : vfun -> int = "coq_closure_arity" + +(* Functions over fixpoint *) + +external offset : Obj.t -> int = "coq_offset" +external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" +external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" + +let first o = (offset_closure o (offset o)) +let first_fix (v:vfix) = (Obj.magic (first (Obj.repr v)) : vfix) + +let last o = (Obj.field o (Obj.size o - 1)) +let fix_types (v:vfix) = (Obj.magic (last (Obj.repr v)) : tcode array) +let cofix_types (v:vcofix) = (Obj.magic (last (Obj.repr v)) : tcode array) + +let current_fix vf = - (offset (Obj.repr vf) / 2) + +let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) + +let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 + +let rec_args vf = + let fb = first (Obj.repr vf) in + let size = Obj.size (last fb) in + Array.init size (unsafe_rec_arg fb) + +exception FALSE + +let check_fix f1 f2 = + let i1, i2 = current_fix f1, current_fix f2 in + (* Checking starting point *) + if i1 = i2 then + let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in + let n = Obj.size (last fb1) in + (* Checking number of definitions *) + if n = Obj.size (last fb2) then + (* Checking recursive arguments *) + try + for i = 0 to n - 1 do + if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i + then raise FALSE + done; + true + with FALSE -> false + else false + else false + +external atom_rel : unit -> atom array = "get_coq_atom_tbl" +external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" + +let relaccu_tbl = + let atom_rel = atom_rel() in + let len = Array.length atom_rel in + for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; + ref (Array.init len mkAccuCode) + +let relaccu_code i = + let len = Array.length !relaccu_tbl in + if i < len then !relaccu_tbl.(i) + else + begin + realloc_atom_rel i; + let atom_rel = atom_rel () in + let nl = Array.length atom_rel in + for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; + relaccu_tbl := + Array.init nl + (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); + !relaccu_tbl.(i) + end + +let mk_fix_body k ndef fb = + let e = Obj.dup (Obj.repr fb) in + for i = 0 to ndef - 1 do + Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) + done; + let fix_body i = + let jump_grabrec c = offset_tcode c 2 in + let c = jump_grabrec (unsafe_fb_code fb i) in + let res = Obj.new_block Obj.closure_tag 2 in + Obj.set_field res 0 (Obj.repr c); + Obj.set_field res 1 (offset_closure e (2*i)); + ((Obj.obj res) : vfun) in + Array.init ndef fix_body + +(* Functions over vcofix *) + +let get_fcofix vcf i = + match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with + | Vcofix(vcfi, _, _) -> vcfi + | _ -> assert false + +let current_cofix vcf = + let ndef = Obj.size (last (Obj.repr vcf)) in + let rec find_cofix pos = + if pos < ndef then + if get_fcofix vcf pos == vcf then pos + else find_cofix (pos+1) + else raise Not_found in + try find_cofix 0 + with Not_found -> assert false + +let check_cofix vcf1 vcf2 = + (current_cofix vcf1 = current_cofix vcf2) && + (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) + +let mk_cofix_body apply_varray k ndef vcf = + let e = Obj.dup (Obj.repr vcf) in + for i = 0 to ndef - 1 do + Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) + done; + + let cofix_body i = + let vcfi = get_fcofix vcf i in + let c = Obj.field (Obj.repr vcfi) 0 in + Obj.set_field e 0 c; + let atom = Obj.new_block cofix_tag 1 in + let self = Obj.new_block accu_tag 2 in + Obj.set_field self 0 (Obj.repr accumulate); + Obj.set_field self 1 (Obj.repr atom); + apply_varray (Obj.obj e) [|Obj.obj self|] in + Array.init ndef cofix_body + +(* Functions over vblock *) + +let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) +let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) +let bfield b i = + if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) + else invalid_arg "Vm.bfield" + + +(* Functions over vswitch *) + +let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + +let branch_arg k (tag,arity) = + if Int.equal arity 0 then ((Obj.magic tag):values) + else + let b, ofs = + if tag < last_variant_tag then Obj.new_block tag arity, 0 + else + let b = Obj.new_block last_variant_tag (arity+1) in + Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); + b,1 in + for i = ofs to ofs + arity - 1 do + Obj.set_field b i (Obj.repr (val_of_rel (k+i))) + done; + val_of_obj b + +(* Printing *) + +let rec pr_atom a = + Pp.(match a with + | Aid c -> str "Aid(" ++ (match c with + | ConstKey c -> Constant.print c + | RelKey i -> str "#" ++ int i + | _ -> str "...") ++ str ")" + | Aind (mi,i) -> str "Aind(" ++ MutInd.print mi ++ str "#" ++ int i ++ str ")" + | Atype _ -> str "Atype(") +and pr_whd w = + Pp.(match w with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" + | Vuniv_level _ -> assert false) +and pr_stack stk = + Pp.(match stk with + | [] -> str "[]" + | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) +and pr_zipper z = + Pp.(match z with + | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" + | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" + | Zswitch s -> str "Zswitch(...)" + | Zproj c -> str "Zproj(" ++ Constant.print c ++ str ")") diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli new file mode 100644 index 000000000..350f71372 --- /dev/null +++ b/kernel/vmvalues.mli @@ -0,0 +1,144 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Cbytecodes + +(** Values *) + +type values +type vm_env +type vprod +type vfun +type vfix +type vcofix +type vblock +type arguments +type vstack = values array +type to_update + +val fun_val : vfun -> values +val fix_val : vfix -> values +val cofix_upd_val : to_update -> values + +val fun_env : vfun -> vm_env +val fix_env : vfix -> vm_env +val cofix_env : vcofix -> vm_env +val cofix_upd_env : to_update -> vm_env + +(** Cast a value known to be a function, unsafe in general *) +val fun_of_val : values -> vfun + +val crazy_val : values + +(** Machine code *) + +type tcode + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +external mkAccuCode : int -> tcode = "coq_makeaccu" + +val fun_code : vfun -> tcode +val fix_code : vfix -> tcode +val cofix_upd_code : to_update -> tcode + +type atom = + | Aid of Vars.id_key + | Aind of inductive + | Atype of Univ.Universe.t + +(** Zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix * arguments (** might be empty *) + | Zswitch of vswitch + | Zproj of Constant.t (* name of the projection *) + +type stack = zipper list + +type whd = + | Vsort of Sorts.t + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix * arguments option + | Vcofix of vcofix * to_update * arguments option + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + | Vuniv_level of Univ.Level.t + +(** For debugging purposes only *) + +val pr_atom : atom -> Pp.t +val pr_whd : whd -> Pp.t +val pr_stack : stack -> Pp.t + +(** Constructors *) + +val val_of_str_const : structured_constant -> values +val val_of_rel : int -> values +val val_of_named : Id.t -> values +val val_of_constant : Constant.t -> values +val val_of_proj : Constant.t -> values -> values +val val_of_atom : atom -> values + +external val_of_annot_switch : annot_switch -> values = "%identity" + +(** Destructors *) + +val whd_val : values -> whd +val uni_lvl_val : values -> Univ.Level.t + +(** Arguments *) + +val nargs : arguments -> int +val arg : arguments -> int -> values + +(** Product *) + +val dom : vprod -> values +val codom : vprod -> vfun + +(** Fun *) +external closure_arity : vfun -> int = "coq_closure_arity" + +(** Fix *) + +val current_fix : vfix -> int +val check_fix : vfix -> vfix -> bool +val rec_args : vfix -> int array +val first_fix : vfix -> vfix +val fix_types : vfix -> tcode array +val cofix_types : vcofix -> tcode array +external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" +val mk_fix_body : int -> int -> vfix -> vfun array + +(** CoFix *) + +val current_cofix : vcofix -> int +val check_cofix : vcofix -> vcofix -> bool +val mk_cofix_body : (vfun -> vstack -> values) -> int -> int -> vcofix -> values array + +(** Block *) + +val btag : vblock -> int +val bsize : vblock -> int +val bfield : vblock -> int -> values + +(** Switch *) + +val check_switch : vswitch -> vswitch -> bool +val branch_arg : int -> Cbytecodes.tag * int -> values diff --git a/lib/profile.ml b/lib/cProfile.ml index 0bc226a45..0bc226a45 100644 --- a/lib/profile.ml +++ b/lib/cProfile.ml diff --git a/lib/profile.mli b/lib/cProfile.mli index cae4397a1..cae4397a1 100644 --- a/lib/profile.mli +++ b/lib/cProfile.mli diff --git a/lib/control.ml b/lib/control.ml index d936d7557..c6489938e 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -12,15 +12,12 @@ let interrupt = ref false let steps = ref 0 -let are_we_threading = lazy ( - match !Flags.async_proofs_mode with - | Flags.APon -> true - | _ -> false) +let enable_thread_delay = ref false let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end; incr steps; - if !steps = 1000 && Lazy.force are_we_threading then begin + if !enable_thread_delay && !steps = 1000 then begin Thread.delay 0.001; steps := 0; end diff --git a/lib/control.mli b/lib/control.mli index f6c63ffb3..261b07693 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -8,6 +8,9 @@ (** Global control of Coq. *) +(** Will periodically call [Thread.delay] if set to true *) +val enable_thread_delay : bool ref + val interrupt : bool ref (** Coq interruption: set the following boolean reference to interrupt Coq (it eventually raises [Break], simulating a Ctrl-C) *) diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 index 970666638..e6f1d7e06 100644 --- a/lib/coqProject_file.ml4 +++ b/lib/coqProject_file.ml4 @@ -11,7 +11,6 @@ type project = { makefile : string option; install_kind : install option; use_ocamlopt : bool; - bypass_API : bool; v_files : string list; mli_files : string list; @@ -43,12 +42,11 @@ and install = | UserInstall (* TODO generate with PPX *) -let mk_project project_file makefile install_kind use_ocamlopt bypass_API = { +let mk_project project_file makefile install_kind use_ocamlopt = { project_file; makefile; install_kind; use_ocamlopt; - bypass_API; v_files = []; mli_files = []; @@ -113,9 +111,10 @@ let exists_dir dir = let process_cmd_line orig_dir proj args = + let parsing_project_file = ref (proj.project_file <> None) in let orig_dir = (* avoids turning foo.v in ./foo.v *) if orig_dir = "." then "" else orig_dir in - let error s = Feedback.msg_error (Pp.str (s^".")); exit 1 in + let error s = Format.eprintf "@[%a]@@\n%!" Pp.pp_with Pp.(str (s^".")); exit 1 in let mk_path d = let p = CUnix.correct_path d orig_dir in { path = CUnix.remove_path_dot (post_canonize p); @@ -155,16 +154,22 @@ let process_cmd_line orig_dir proj args = aux { proj with r_includes = proj.r_includes @ [mk_path d,lp] } r | "-f" :: file :: r -> + if !parsing_project_file then + raise (Parsing_error ("Invalid option -f in project file " ^ Option.get proj.project_file)); let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match proj.project_file with | None -> () | Some _ -> Feedback.msg_warning (Pp.str "Multiple project files are deprecated.") in + parsing_project_file := true; let proj = aux { proj with project_file = Some file } (parse file) in + parsing_project_file := false; aux proj r | "-o" :: file :: r -> + if !parsing_project_file then + raise (Parsing_error ("Invalid option -o in project file " ^ Option.get proj.project_file)); if String.contains file '/' then error "Output file must be in the current directory"; if proj.makefile <> None then @@ -174,8 +179,6 @@ let process_cmd_line orig_dir proj args = aux { proj with defs = proj.defs @ [v,def] } r | "-arg" :: a :: r -> aux { proj with extra_args = proj.extra_args @ [a] } r - | "-bypass-API" :: r -> - aux { proj with bypass_API = true } r | f :: r -> let f = CUnix.correct_path f orig_dir in let proj = @@ -195,11 +198,11 @@ let process_cmd_line orig_dir proj args = (******************************* API ************************************) let cmdline_args_to_project ~curdir args = - process_cmd_line curdir (mk_project None None None true false) args + process_cmd_line curdir (mk_project None None None true) args let read_project_file f = process_cmd_line (Filename.dirname f) - (mk_project (Some f) None (Some NoInstall) true false) (parse f) + (mk_project (Some f) None (Some NoInstall) true) (parse f) let rec find_project_file ~from ~projfile_name = let fname = Filename.concat from projfile_name in diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli index 23a27a54a..810189450 100644 --- a/lib/coqProject_file.mli +++ b/lib/coqProject_file.mli @@ -13,7 +13,6 @@ type project = { makefile : string option; install_kind : install option; use_ocamlopt : bool; - bypass_API : bool; v_files : string list; mli_files : string list; diff --git a/lib/envars.ml b/lib/envars.ml index 206d75033..9b66c1f71 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -153,27 +153,23 @@ let coqpath = let exe s = s ^ Coq_config.exec_extension -let ocamlfind () = - if !Flags.ocamlfind_spec then !Flags.ocamlfind else Coq_config.ocamlfind +let ocamlfind () = Coq_config.ocamlfind -(** {2 Camlp4 paths} *) +(** {2 Camlp5 paths} *) -let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4) +let guess_camlp5bin () = which (user_path ()) (exe "camlp5") -let camlp4bin () = - if !Flags.camlp4bin_spec then !Flags.camlp4bin else - if !Flags.boot then Coq_config.camlp4bin else - try guess_camlp4bin () - with Not_found -> - Coq_config.camlp4bin +let camlp5bin () = + if !Flags.boot then Coq_config.camlp5bin else + try guess_camlp5bin () + with Not_found -> + Coq_config.camlp5bin -let camlp4 () = camlp4bin () / exe Coq_config.camlp4 - -let camlp4lib () = +let camlp5lib () = if !Flags.boot then - Coq_config.camlp4lib + Coq_config.camlp5lib else - let ex, res = CUnix.run_command (ocamlfind () ^ " query " ^ Coq_config.camlp4) in + let ex, res = CUnix.run_command (ocamlfind () ^ " query camlp5") in match ex with | Unix.WEXITED 0 -> String.strip res | _ -> "/dev/null" @@ -208,11 +204,10 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); - fprintf f "%sCAMLP4=%s\n" prefix_var_name Coq_config.camlp4; - fprintf f "%sCAMLP4O=%s\n" prefix_var_name Coq_config.camlp4o; - fprintf f "%sCAMLP4BIN=%s/\n" prefix_var_name (camlp4bin ()); - fprintf f "%sCAMLP4LIB=%s\n" prefix_var_name (camlp4lib ()); - fprintf f "%sCAMLP4OPTIONS=%s\n" prefix_var_name Coq_config.camlp4compat; + fprintf f "%sCAMLP5O=%s\n" prefix_var_name Coq_config.camlp5o; + fprintf f "%sCAMLP5BIN=%s/\n" prefix_var_name (camlp5bin ()); + fprintf f "%sCAMLP5LIB=%s\n" prefix_var_name (camlp5lib ()); + fprintf f "%sCAMLP5OPTIONS=%s\n" prefix_var_name Coq_config.camlp5compat; fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); diff --git a/lib/envars.mli b/lib/envars.mli index 09f2b4ca1..1ccd1feff 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -56,14 +56,11 @@ val coqpath : string list (** [camlfind ()] is the path to the ocamlfind binary. *) val ocamlfind : unit -> string -(** [camlp4bin ()] is the path to the camlp4 binary. *) -val camlp4bin : unit -> string +(** [camlp5bin ()] is the path to the camlp5 binary. *) +val camlp5bin : unit -> string -(** [camlp4lib ()] is the path to the camlp4 library. *) -val camlp4lib : unit -> string - -(** [camlp4 ()] is the camlp4 utility. *) -val camlp4 : unit -> string +(** [camlp5lib ()] is the path to the camlp5 library. *) +val camlp5lib : unit -> string (** Coq tries to honor the XDG Base Directory Specification to access the user's configuration files. diff --git a/lib/feedback.mli b/lib/feedback.mli index 62b909516..37f38c8ff 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -94,8 +94,9 @@ val msg_warning : ?loc:Loc.t -> Pp.t -> unit consequences. *) val msg_error : ?loc:Loc.t -> Pp.t -> unit -(** Message indicating that something went really wrong, though still - recoverable; otherwise an exception would have been raised. *) +[@@ocaml.deprecated "msg_error is an internal function and should not be \ + used unless you know what you are doing. Use \ + [CErrors.user_err] instead."] val msg_debug : ?loc:Loc.t -> Pp.t -> unit (** For debugging purposes *) diff --git a/lib/flags.ml b/lib/flags.ml index ddc8f8482..415e4399a 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -6,18 +6,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let with_modified_ref r nf f x = +(* If [restore] is false, whenever [f] modifies the ref, we will + preserve the modification. *) +let with_modified_ref ?(restore=true) r nf f x = let old_ref = !r in r := nf !r; - try let res = f x in r := old_ref; res + try + let pre = !r in + let res = f x in + (* If r was modified don't restore its old value *) + if restore || pre == !r then r := old_ref; + res with reraise -> let reraise = Backtrace.add_backtrace reraise in r := old_ref; Exninfo.iraise reraise -let with_option o f x = with_modified_ref o (fun _ -> true) f x -let without_option o f x = with_modified_ref o (fun _ -> false) f x +let with_option o f x = with_modified_ref ~restore:false o (fun _ -> true) f x +let without_option o f x = with_modified_ref ~restore:false o (fun _ -> false) f x let with_extra_values o l f x = with_modified_ref o (fun ol -> ol@l) f x +(* hide the [restore] option as internal *) +let with_modified_ref r nf f x = with_modified_ref r nf f x + let with_options ol f x = let vl = List.map (!) ol in let () = List.iter (fun r -> r := true) ol in @@ -35,36 +45,10 @@ let record_aux_file = ref false let test_mode = ref false -type async_proofs = APoff | APonLazy | APon -let async_proofs_mode = ref APoff -type cache = Force -let async_proofs_cache = ref None -let async_proofs_n_workers = ref 1 -let async_proofs_n_tacworkers = ref 2 -let async_proofs_private_flags = ref None -let async_proofs_full = ref false -let async_proofs_never_reopen_branch = ref false -let async_proofs_flags_for_workers = ref [] let async_proofs_worker_id = ref "master" -type priority = Low | High -let async_proofs_worker_priority = ref Low -let string_of_priority = function Low -> "low" | High -> "high" -let priority_of_string = function - | "low" -> Low - | "high" -> High - | _ -> raise (Invalid_argument "priority_of_string") -type tac_error_filter = [ `None | `Only of string list | `All ] -let async_proofs_tac_error_resilience = ref (`Only [ "curly" ]) -let async_proofs_cmd_error_resilience = ref true - -let async_proofs_is_worker () = - !async_proofs_worker_id <> "master" -let async_proofs_is_master () = - !async_proofs_mode = APon && !async_proofs_worker_id = "master" -let async_proofs_delegation_threshold = ref 0.03 +let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let debug = ref false -let stm_debug = ref false let in_debugger = ref false let in_toplevel = ref false @@ -72,12 +56,8 @@ let in_toplevel = ref false let profile = false let ide_slave = ref false -let ideslave_coqtop_flags = ref None - -let time = ref false let raw_print = ref false - let univ_print = ref false let we_are_parsing = ref false @@ -136,14 +116,6 @@ let universe_polymorphism = ref false let make_universe_polymorphism b = universe_polymorphism := b let is_universe_polymorphism () = !universe_polymorphism -let local_polymorphic_flag = ref None -let use_polymorphic_flag () = - match !local_polymorphic_flag with - | Some p -> local_polymorphic_flag := None; p - | None -> is_universe_polymorphism () -let make_polymorphic_flag b = - local_polymorphic_flag := Some b - let polymorphic_inductive_cumulativity = ref false let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity @@ -179,14 +151,6 @@ let is_standard_doc_url url = let coqlib_spec = ref false let coqlib = ref "(not initialized yet)" -(* Options for changing ocamlfind (used by coqmktop) *) -let ocamlfind_spec = ref false -let ocamlfind = ref Coq_config.camlbin - -(* Options for changing camlp4bin (used by coqmktop) *) -let camlp4bin_spec = ref false -let camlp4bin = ref Coq_config.camlp4bin - (* Level of inlining during a functor application *) let default_inline_level = 100 @@ -195,12 +159,11 @@ let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level (* Native code compilation for conversion and normalization *) -let native_compiler = ref false +let output_native_objects = ref false (* Print the mod uid associated to a vo file by the native compiler *) let print_mod_uid = ref false -let tactic_context_compat = ref false let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 diff --git a/lib/flags.mli b/lib/flags.mli index c4afb8318..c82410f07 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -21,43 +21,18 @@ val record_aux_file : bool ref val test_mode : bool ref (** Async-related flags *) -type async_proofs = APoff | APonLazy | APon -val async_proofs_mode : async_proofs ref -type cache = Force -val async_proofs_cache : cache option ref -val async_proofs_n_workers : int ref -val async_proofs_n_tacworkers : int ref -val async_proofs_private_flags : string option ref -val async_proofs_is_worker : unit -> bool -val async_proofs_is_master : unit -> bool -val async_proofs_full : bool ref -val async_proofs_never_reopen_branch : bool ref -val async_proofs_flags_for_workers : string list ref val async_proofs_worker_id : string ref -type priority = Low | High -val async_proofs_worker_priority : priority ref -val string_of_priority : priority -> string -val priority_of_string : string -> priority -type tac_error_filter = [ `None | `Only of string list | `All ] -val async_proofs_tac_error_resilience : tac_error_filter ref -val async_proofs_cmd_error_resilience : bool ref -val async_proofs_delegation_threshold : float ref +val async_proofs_is_worker : unit -> bool +(** Debug flags *) val debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref -(** Enable STM debugging *) -val stm_debug : bool ref - val profile : bool (* -ide_slave: printing will be more verbose, will affect stm caching *) val ide_slave : bool ref -val ideslave_coqtop_flags : string option ref - -(* -time option: every command will be wrapped with `Time` *) -val time : bool ref (* development flag to detect race conditions, it should go away. *) val we_are_parsing : bool ref @@ -98,10 +73,6 @@ val is_program_mode : unit -> bool val make_universe_polymorphism : bool -> unit val is_universe_polymorphism : unit -> bool -(** Local universe polymorphism flag. *) -val make_polymorphic_flag : bool -> unit -val use_polymorphic_flag : unit -> bool - (** Global polymorphic inductive cumulativity flag. *) val make_polymorphic_inductive_cumulativity : bool -> unit val is_polymorphic_inductive_cumulativity : unit -> bool @@ -143,27 +114,17 @@ val is_standard_doc_url : string -> bool val coqlib_spec : bool ref val coqlib : string ref -(** Options for specifying where OCaml binaries reside *) -val ocamlfind_spec : bool ref -val ocamlfind : string ref -val camlp4bin_spec : bool ref -val camlp4bin : string ref - (** Level of inlining during a functor application *) val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int -(** Native code compilation for conversion and normalization *) -val native_compiler : bool ref +(** When producing vo objects, also compile the native-code version *) +val output_native_objects : bool ref (** Print the mod uid associated to a vo file by the native compiler *) val print_mod_uid : bool ref -val tactic_context_compat : bool ref -(** Set to [true] to trigger the compatibility bugged context matching (old - context vs. appcontext) is set. *) - val profile_ltac : bool ref val profile_ltac_cutoff : float ref diff --git a/lib/lib.mllib b/lib/lib.mllib index 8791f0741..b2260ba09 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,21 +1,30 @@ +Coq_config + +Hook +Flags +Control +Util + +Pp +Stateid +Loc +Feedback CErrors CWarnings -Bigint -Segmenttree -Unicodetable -Unicode -Minisys + +Rtree System -CThread -Spawn -Trie -Profile Explore -Predicate -Rtree -Heap -Unionfind -Genarg -CEphemeron +RTree +CProfile Future +Spawn + +CAst +DAst +Genarg + RemoteCounter +Aux_file +Envars +CoqProject_file @@ -208,6 +208,7 @@ let string_of_ppcmds c = let pr_comma () = str "," ++ spc () let pr_semicolon () = str ";" ++ spc () let pr_bar () = str "|" ++ spc () +let pr_spcbar () = str " |" ++ spc () let pr_arg pr x = spc () ++ pr x let pr_non_empty_arg pr x = let pp = pr x in if ismt pp then mt () else spc () ++ pr x let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x diff --git a/lib/pp.mli b/lib/pp.mli index 2d11cad86..d9be1c5ce 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -120,6 +120,9 @@ val pr_semicolon : unit -> t val pr_bar : unit -> t (** Well-spaced pipe bar. *) +val pr_spcbar : unit -> t +(** Pipe bar with space before and after. *) + val pr_arg : ('a -> t) -> 'a -> t (** Adds a space in front of its argument. *) diff --git a/lib/system.ml b/lib/system.ml index 4b5066ef4..e56736eb1 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -294,24 +294,18 @@ let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (round (sstop -. sstart)) ++ str "s" ++ str ")" -let with_time time f x = +let with_time ~batch f x = let tstart = get_time() in - let msg = if time then "" else "Finished transaction in " in + let msg = if batch then "" else "Finished transaction in " in try let y = f x in let tend = get_time() in - let msg2 = if time then "" else " (successful)" in + let msg2 = if batch then "" else " (successful)" in Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in - let msg = if time then "" else "Finished failing transaction in " in - let msg2 = if time then "" else " (failure)" in + let msg = if batch then "" else "Finished failing transaction in " in + let msg2 = if batch then "" else " (failure)" in Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e - -let process_id () = - Printf.sprintf "%d:%s:%d" (Unix.getpid ()) - (if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id - else "master") - (Thread.id (Thread.self ())) diff --git a/lib/system.mli b/lib/system.mli index aa964abeb..0c0cc9fae 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -104,7 +104,4 @@ val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) val fmt_time_difference : time -> time -> Pp.t -val with_time : bool -> ('a -> 'b) -> 'a -> 'b - -(** {6 Name of current process.} *) -val process_id : unit -> string +val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b diff --git a/library/declaremods.ml b/library/declaremods.ml index db83dafef..28a04252a 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -180,16 +180,16 @@ let compute_visibility exists i = (** Iterate some function [iter_objects] on all components of a module *) -let do_module exists iter_objects i dir mp sobjs kobjs = - let prefix = (dir,(mp,DirPath.empty)) in +let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let dirinfo = DirModule prefix in - consistency_checks exists dir dirinfo; - Nametab.push_dir (compute_visibility exists i) dir dirinfo; - ModSubstObjs.set mp sobjs; + consistency_checks exists obj_dir dirinfo; + Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; + ModSubstObjs.set obj_mp sobjs; (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let objs = expand_sobjs sobjs in - ModObjs.set mp (prefix,objs,kobjs); + ModObjs.set obj_mp (prefix,objs,kobjs); iter_objects (i+1) prefix objs; iter_objects (i+1) prefix kobjs end @@ -222,20 +222,20 @@ let cache_keep _ = anomaly (Pp.str "This module should not be cached!") let load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let prefix',sobjs,kobjs0 = - try ModObjs.get mp + try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) in assert (eq_op prefix' prefix); assert (List.is_empty kobjs0); - ModObjs.set mp (prefix,sobjs,kobjs); + ModObjs.set obj_mp (prefix,sobjs,kobjs); Lib.load_objects i prefix kobjs let open_keep i ((sp,kn),kobjs) = - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in Lib.open_objects i prefix kobjs let in_modkeep : Lib.lib_objects -> obj = @@ -284,9 +284,9 @@ let (in_modtype : substitutive_objects -> obj), (** {6 Declaration of substitutive objects for Include} *) let do_include do_load do_open i ((sp,kn),aobjs) = - let dir = Libnames.dirpath sp in - let mp = KerName.modpath kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = Libnames.dirpath sp in + let obj_mp = KerName.modpath kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in let o = expand_aobjs aobjs in if do_load then Lib.load_objects i prefix o; if do_open then Lib.open_objects i prefix o @@ -442,23 +442,26 @@ let process_module_binding mbid me = Objects in these parameters are also loaded. Output is accumulated on top of [acc] (in reverse order). *) -let intern_arg interp_modast acc (idl,(typ,ann)) = +let intern_arg interp_modast (acc, cst) (idl,(typ,ann)) = let inl = inl2intopt ann in let lib_dir = Lib.library_dp() in let env = Global.env() in - let mty,_ = interp_modast env ModType typ in + let (mty, _, cst') = interp_modast env ModType typ in + let () = Global.push_context_set true cst' in + let env = Global.env () in let sobjs = get_module_sobjs false env inl mty in let mp0 = get_module_path mty in - List.fold_left - (fun acc (_,id) -> - let dir = DirPath.make [id] in - let mbid = MBId.make lib_dir id in - let mp = MPbound mbid in - let resolver = Global.add_module_parameter mbid mty inl in - let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in - do_module false Lib.load_objects 1 dir mp sobjs []; - (mbid,mty,inl)::acc) - acc idl + let fold acc (_, id) = + let dir = DirPath.make [id] in + let mbid = MBId.make lib_dir id in + let mp = MPbound mbid in + let resolver = Global.add_module_parameter mbid mty inl in + let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in + do_module false Lib.load_objects 1 dir mp sobjs []; + (mbid,mty,inl)::acc + in + let acc = List.fold_left fold acc idl in + (acc, Univ.ContextSet.union cst cst') (** Process a list of declarations of functor parameters (Id11 .. Id1n : Typ1)..(Idk1 .. Idkm : Typk) @@ -472,7 +475,7 @@ let intern_arg interp_modast acc (idl,(typ,ann)) = *) let intern_args interp_modast params = - List.fold_left (intern_arg interp_modast) [] params + List.fold_left (intern_arg interp_modast) ([], Univ.ContextSet.empty) params (** {6 Auxiliary functions concerning subtyping checks} *) @@ -524,13 +527,17 @@ let mk_funct_type env args seb0 = (** Prepare the module type list for check of subtypes *) let build_subtypes interp_modast env mp args mtys = - List.map - (fun (m,ann) -> + let (cst, ans) = List.fold_left_map + (fun cst (m,ann) -> let inl = inl2intopt ann in - let mte,_ = interp_modast env ModType m in + let mte, _, cst' = interp_modast env ModType m in + let env = Environ.push_context_set ~strict:true cst' env in + let cst = Univ.ContextSet.union cst cst' in let mtb = Mod_typing.translate_modtype env mp inl ([],mte) in - { mtb with mod_type = mk_funct_type env args mtb.mod_type }) - mtys + cst, { mtb with mod_type = mk_funct_type env args mtb.mod_type }) + Univ.ContextSet.empty mtys + in + (ans, cst) (** {6 Current module information} @@ -563,21 +570,26 @@ module RawModOps = struct let start_module interp_modast export id args res fs = let mp = Global.start_module id in - let arg_entries_r = intern_args interp_modast args in + let arg_entries_r, cst = intern_args interp_modast args in + let () = Global.push_context_set true cst in let env = Global.env () in - let res_entry_o, subtyps = match res with + let res_entry_o, subtyps, cst = match res with | Enforce (res,ann) -> let inl = inl2intopt ann in - let mte,_ = interp_modast env ModType res in + let (mte, _, cst) = interp_modast env ModType res in + let env = Environ.push_context_set ~strict:true cst env in (* We check immediately that mte is well-formed *) - let _ = Mod_typing.translate_mse env None inl mte in - Some (mte,inl), [] + let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in + let cst = Univ.ContextSet.union cst cst' in + Some (mte, inl), [], cst | Check resl -> - None, build_subtypes interp_modast env mp arg_entries_r resl + let typs, cst = build_subtypes interp_modast env mp arg_entries_r resl in + None, typs, cst in + let () = Global.push_context_set true cst in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModule prefix); mp let end_module () = @@ -622,25 +634,33 @@ let declare_module interp_modast id args res mexpr_o fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_module id in - let arg_entries_r = intern_args interp_modast args in + let arg_entries_r, cst = intern_args interp_modast args in let params = mk_params_entry arg_entries_r in let env = Global.env () in - let mty_entry_o, subs, inl_res = match res with + let env = Environ.push_context_set ~strict:true cst env in + let mty_entry_o, subs, inl_res, cst' = match res with | Enforce (mty,ann) -> let inl = inl2intopt ann in - let mte, _ = interp_modast env ModType mty in + let (mte, _, cst) = interp_modast env ModType mty in + let env = Environ.push_context_set ~strict:true cst env in (* We check immediately that mte is well-formed *) - let _ = Mod_typing.translate_mse env None inl mte in - Some mte, [], inl + let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in + let cst = Univ.ContextSet.union cst cst' in + Some mte, [], inl, cst | Check mtys -> - None, build_subtypes interp_modast env mp arg_entries_r mtys, - default_inline () + let typs, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + None, typs, default_inline (), cst in - let mexpr_entry_o, inl_expr = match mexpr_o with - | None -> None, default_inline () + let env = Environ.push_context_set ~strict:true cst' env in + let cst = Univ.ContextSet.union cst cst' in + let mexpr_entry_o, inl_expr, cst' = match mexpr_o with + | None -> None, default_inline (), Univ.ContextSet.empty | Some (mexpr,ann) -> - Some (fst (interp_modast env Module mexpr)), inl2intopt ann + let (mte, _, cst) = interp_modast env Module mexpr in + Some mte, inl2intopt ann, cst in + let env = Environ.push_context_set ~strict:true cst' env in + let cst = Univ.ContextSet.union cst cst' in let entry = match mexpr_entry_o, mty_entry_o with | None, None -> assert false (* No body, no type ... *) | None, Some typ -> MType (params, typ) @@ -659,6 +679,7 @@ let declare_module interp_modast id args res mexpr_o fs = | None -> None | _ -> inl_res in + let () = Global.push_context_set true cst in let mp_env,resolver = Global.add_module id entry inl in (* Name consistency check : kernel vs. library *) @@ -679,12 +700,14 @@ module RawModTypeOps = struct let start_modtype interp_modast id args mtys fs = let mp = Global.start_modtype id in - let arg_entries_r = intern_args interp_modast args in + let arg_entries_r, cst = intern_args interp_modast args in + let () = Global.push_context_set true cst in let env = Global.env () in - let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in + let sub_mty_l, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + let () = Global.push_context_set true cst in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModtype prefix); mp let end_modtype () = @@ -708,14 +731,21 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_modtype id in - let arg_entries_r = intern_args interp_modast args in + let arg_entries_r, cst = intern_args interp_modast args in + let () = Global.push_context_set true cst in let params = mk_params_entry arg_entries_r in let env = Global.env () in - let mte, _ = interp_modast env ModType mty in + let mte, _, cst = interp_modast env ModType mty in + let () = Global.push_context_set true cst in + let env = Global.env () in (* We check immediately that mte is well-formed *) - let _ = Mod_typing.translate_mse env None inl mte in + let _, _, _, cst = Mod_typing.translate_mse env None inl mte in + let () = Global.push_context_set true cst in + let env = Global.env () in let entry = params, mte in - let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in + let sub_mty_l, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + let () = Global.push_context_set true cst in + let env = Global.env () in let sobjs = get_functor_sobjs false env inl entry in let subst = map_mp (get_module_path (snd entry)) mp empty_delta_resolver in let sobjs = subst_sobjs subst sobjs in @@ -769,7 +799,9 @@ let type_of_incl env is_mod = function let declare_one_include interp_modast (me_ast,annot) = let env = Global.env() in - let me,kind = interp_modast env ModAny me_ast in + let me, kind, cst = interp_modast env ModAny me_ast in + let () = Global.push_context_set true cst in + let env = Global.env () in let is_mod = (kind == Module) in let cur_mp = Lib.current_mp () in let inl = inl2intopt annot in @@ -947,7 +979,7 @@ let iter_all_segments f = type 'modast module_interpretor = Environ.env -> Misctypes.module_kind -> 'modast -> - Entries.module_struct_entry * Misctypes.module_kind + Entries.module_struct_entry * Misctypes.module_kind * Univ.ContextSet.t type 'modast module_params = (Id.t Loc.located list * ('modast * inline)) list diff --git a/library/declaremods.mli b/library/declaremods.mli index 42e5f4b13..0df55f34d 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -13,7 +13,7 @@ open Vernacexpr type 'modast module_interpretor = Environ.env -> Misctypes.module_kind -> 'modast -> - Entries.module_struct_entry * Misctypes.module_kind + Entries.module_struct_entry * Misctypes.module_kind * Univ.ContextSet.t type 'modast module_params = (Id.t Loc.located list * ('modast * inline)) list diff --git a/library/global.ml b/library/global.ml index 43097dc5d..ed847b7cd 100644 --- a/library/global.ml +++ b/library/global.ml @@ -8,7 +8,6 @@ open Names open Environ -open Decl_kinds (** We introduce here the global environment of the system, and we declare it as a synchronized table. *) @@ -21,6 +20,7 @@ module GlobalSafeEnv : sig val set_safe_env : Safe_typing.safe_environment -> unit val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit val is_joined_environment : unit -> bool + val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag end = struct @@ -31,9 +31,9 @@ let join_safe_environment ?except () = let is_joined_environment () = Safe_typing.is_joined_environment !global_env - -let () = - Summary.declare_summary global_env_summary_name + +let global_env_summary_tag = + Summary.declare_summary_tag global_env_summary_name { Summary.freeze_function = (function | `Yes -> join_safe_environment (); !global_env | `No -> !global_env @@ -52,6 +52,8 @@ let set_safe_env e = global_env := e end +let global_env_summary_tag = GlobalSafeEnv.global_env_summary_tag + let safe_env = GlobalSafeEnv.safe_env let join_safe_environment ?except () = GlobalSafeEnv.join_safe_environment ?except () @@ -79,7 +81,7 @@ let globalize_with_summary fs f = let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) -let push_named_def d = globalize (Safe_typing.push_named_def d) +let push_named_def d = globalize0 (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let push_context b c = globalize0 (Safe_typing.push_context b c) @@ -231,18 +233,7 @@ let universes_of_global env r = let universes_of_global gr = universes_of_global (env ()) gr -(** Global universe names *) -type universe_names = - (polymorphic * Univ.Level.t) Id.Map.t * Id.t Univ.LMap.t - -let global_universes = - Summary.ref ~name:"Global universe names" - ((Id.Map.empty, Univ.LMap.empty) : universe_names) - -let global_universe_names () = !global_universes -let set_global_universe_names s = global_universes := s - -let is_polymorphic r = +let is_polymorphic r = let env = env() in match r with | VarRef id -> false diff --git a/library/global.mli b/library/global.mli index 51fe53181..03bc945da 100644 --- a/library/global.mli +++ b/library/global.mli @@ -32,11 +32,11 @@ val set_typing_flags : Declarations.typing_flags -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.ContextSet.t +val push_named_def : (Id.t * Entries.section_def_entry) -> unit val export_private_constants : in_section:bool -> - Safe_typing.private_constants Entries.constant_entry -> - unit Entries.constant_entry * Safe_typing.exported_private_constant list + Safe_typing.private_constants Entries.definition_entry -> + unit Entries.definition_entry * Safe_typing.exported_private_constant list val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> Constant.t @@ -44,7 +44,7 @@ val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> MutInd.t (** Extra universe constraints *) -val add_constraints : Univ.constraints -> unit +val add_constraints : Univ.Constraint.t -> unit val push_context : bool -> Univ.UContext.t -> unit val push_context_set : bool -> Univ.ContextSet.t -> unit @@ -102,13 +102,6 @@ val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option (** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) -(** Global universe name <-> level mapping *) -type universe_names = - (Decl_kinds.polymorphic * Univ.Level.t) Id.Map.t * Id.t Univ.LMap.t - -val global_universe_names : unit -> universe_names -val set_global_universe_names : universe_names -> unit - (** {6 Compiled libraries } *) val start_library : DirPath.t -> ModPath.t @@ -166,4 +159,4 @@ val current_dirpath : unit -> DirPath.t val with_global : (Environ.env -> DirPath.t -> 'a Univ.in_universe_context_set) -> 'a -val global_env_summary_name : string +val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag diff --git a/library/globnames.ml b/library/globnames.ml index 9d7ab2db8..a6e75fdb6 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -30,7 +30,7 @@ let eq_gr gr1 gr2 = | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 | VarRef v1, VarRef v2 -> Id.equal v1 v2 - | _ -> false + | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" diff --git a/library/kindops.ml b/library/kindops.ml index 882f62086..83985ce97 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -23,45 +23,13 @@ let string_of_theorem_kind = function | Proposition -> "Proposition" | Corollary -> "Corollary" -let string_of_definition_kind def = - let (locality, poly, kind) = def in - let error () = CErrors.anomaly (Pp.str "Internal definition kind.") in - match kind with - | Definition -> - begin match locality with - | Discharge -> "Let" - | Local -> "Local Definition" - | Global -> "Definition" - end - | Example -> - begin match locality with - | Discharge -> error () - | Local -> "Local Example" - | Global -> "Example" - end - | Coercion -> - begin match locality with - | Discharge -> error () - | Local -> "Local Coercion" - | Global -> "Coercion" - end - | SubClass -> - begin match locality with - | Discharge -> error () - | Local -> "Local SubClass" - | Global -> "SubClass" - end - | CanonicalStructure -> - begin match locality with - | Discharge -> error () - | Local -> error () - | Global -> "Canonical Structure" - end - | Instance -> - begin match locality with - | Discharge -> error () - | Local -> "Instance" - | Global -> "Global Instance" - end +let string_of_definition_object_kind = function + | Definition -> "Definition" + | Example -> "Example" + | Coercion -> "Coercion" + | SubClass -> "SubClass" + | CanonicalStructure -> "Canonical Structure" + | Instance -> "Instance" + | Let -> "Let" | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> CErrors.anomaly (Pp.str "Internal definition kind.") diff --git a/library/kindops.mli b/library/kindops.mli index 77979c915..06f873e85 100644 --- a/library/kindops.mli +++ b/library/kindops.mli @@ -12,4 +12,4 @@ open Decl_kinds val logical_kind_of_goal_kind : goal_object_kind -> logical_kind val string_of_theorem_kind : theorem_kind -> string -val string_of_definition_kind : definition_kind -> string +val string_of_definition_object_kind : definition_object_kind -> string diff --git a/library/lib.ml b/library/lib.ml index 3dbb16c7b..971089c17 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -93,12 +93,16 @@ let segment_of_objects prefix = sections, but on the contrary there are many constructions of section paths based on the library path. *) -let initial_prefix = default_library,(Names.ModPath.initial,Names.DirPath.empty) +let initial_prefix = { + obj_dir = default_library; + obj_mp = ModPath.initial; + obj_sec = DirPath.empty; +} type lib_state = { - comp_name : Names.DirPath.t option; + comp_name : DirPath.t option; lib_stk : library_segment; - path_prefix : Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t); + path_prefix : object_prefix; } let initial_lib_state = { @@ -115,10 +119,9 @@ let library_dp () = (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let cwd () = fst !lib_state.path_prefix -let current_prefix () = snd !lib_state.path_prefix -let current_mp () = fst (snd !lib_state.path_prefix) -let current_sections () = snd (snd !lib_state.path_prefix) +let cwd () = !lib_state.path_prefix.obj_dir +let current_mp () = !lib_state.path_prefix.obj_mp +let current_sections () = !lib_state.path_prefix.obj_sec let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -136,7 +139,7 @@ let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let make_kn id = - let mp,dir = current_prefix () in + let mp, dir = current_mp (), current_sections () in Names.KerName.make mp dir (Names.Label.of_id id) let make_oname id = Libnames.make_oname !lib_state.path_prefix id @@ -152,8 +155,11 @@ let recalc_path_prefix () = lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk } let pop_path_prefix () = - let dir,(mp,sec) = !lib_state.path_prefix in - lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)} + let op = !lib_state.path_prefix in + lib_state := { !lib_state + with path_prefix = { op with obj_dir = pop_dirpath op.obj_dir; + obj_sec = pop_dirpath op.obj_sec; + } } let find_entry_p p = let rec find = function @@ -226,7 +232,7 @@ let add_anonymous_entry node = add_entry (make_oname (anonymous_id ())) node let add_leaf id obj = - if Names.ModPath.equal (current_mp ()) Names.ModPath.initial then + if ModPath.equal (current_mp ()) ModPath.initial then user_err Pp.(str "No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); @@ -278,8 +284,8 @@ let current_mod_id () = let start_mod is_type export id mp fs = - let dir = add_dirpath_suffix (cwd ()) id in - let prefix = dir,(mp,Names.DirPath.empty) in + let dir = add_dirpath_suffix (!lib_state.path_prefix.obj_dir) id in + let prefix = { obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_module dir @@ -328,10 +334,10 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (current_sections ())) then + if not (Names.DirPath.is_empty (!lib_state.path_prefix.obj_sec)) then user_err Pp.(str "some sections are already opened"); - let prefix = s, (mp, Names.DirPath.empty) in - let () = add_anonymous_entry (CompilingLibrary prefix) in + let prefix = Libnames.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -411,8 +417,11 @@ let find_opening_node id = type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list -type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t - +type abstr_info = { + abstr_ctx : variable_context; + abstr_subst : Univ.Instance.t; + abstr_uctx : Univ.AUContext.t; +} type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t type secentry = @@ -477,8 +486,12 @@ let add_section_replacement f g poly hyps = let inst = Univ.UContext.instance ctx in let subst, ctx = Univ.abstract_universes ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f (inst,args) exps, - g (sechyps,subst,ctx) abs)::sl + let info = { + abstr_ctx = sechyps; + abstr_subst = subst; + abstr_uctx = ctx; + } in + sectab := (vars,f (inst,args) exps, g info abs) :: sl let add_section_kn poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in @@ -496,12 +509,21 @@ let section_segment_of_constant con = let section_segment_of_mutual_inductive kn = Names.Mindmap.find kn (snd (pi3 (List.hd !sectab))) -let variable_section_segment_of_reference = function - | ConstRef con -> pi1 (section_segment_of_constant con) - | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - pi1 (section_segment_of_mutual_inductive kn) - | _ -> [] - +let empty_segment = { + abstr_ctx = []; + abstr_subst = Univ.Instance.empty; + abstr_uctx = Univ.AUContext.empty; +} + +let section_segment_of_reference = function +| ConstRef c -> section_segment_of_constant c +| IndRef (kn,_) | ConstructRef ((kn,_),_) -> + section_segment_of_mutual_inductive kn +| VarRef _ -> empty_segment + +let variable_section_segment_of_reference gr = + (section_segment_of_reference gr).abstr_ctx + let section_instance = function | VarRef id -> let eq = function @@ -522,15 +544,15 @@ let is_in_section ref = (*************) (* Sections. *) let open_section id = - let olddir,(mp,oldsec) = !lib_state.path_prefix in - let dir = add_dirpath_suffix olddir id in - let prefix = dir, (mp, add_dirpath_suffix oldsec id) in - if Nametab.exists_section dir then + let opp = !lib_state.path_prefix in + let obj_dir = add_dirpath_suffix opp.obj_dir id in + let prefix = { obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in + if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) - Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); + Nametab.push_dir (Nametab.Until 1) obj_dir (DirOpenSection prefix); lib_state := { !lib_state with path_prefix = prefix }; add_section () @@ -556,7 +578,7 @@ let close_section () = in let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - let full_olddir = fst !lib_state.path_prefix in + let full_olddir = !lib_state.path_prefix.obj_dir in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in @@ -596,10 +618,10 @@ let init () = (* Misc *) let mp_of_global = function - |VarRef id -> current_mp () - |ConstRef cst -> Names.Constant.modpath cst - |IndRef ind -> Names.ind_modpath ind - |ConstructRef constr -> Names.constr_modpath constr + | VarRef id -> !lib_state.path_prefix.obj_mp + | ConstRef cst -> Names.Constant.modpath cst + | IndRef ind -> Names.ind_modpath ind + | ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp @@ -648,15 +670,10 @@ let discharge_con cst = let discharge_inductive (kn,i) = (discharge_kn kn,i) -let discharge_abstract_universe_context (_, subst, abs_ctx) auctx = +let discharge_abstract_universe_context { abstr_subst = subst; abstr_uctx = abs_ctx } auctx = let open Univ in - let len = LMap.cardinal subst in - let rec gen_subst i acc = - if i < 0 then acc - else - let acc = LMap.add (Level.var i) (Level.var (i + len)) acc in - gen_subst (pred i) acc - in - let subst = gen_subst (AUContext.size auctx - 1) subst in + let ainst = make_abstract_instance auctx in + let subst = Instance.append subst ainst in + let subst = make_instance_subst subst in let auctx = Univ.subst_univs_level_abstract_universe_context subst auctx in subst, AUContext.union abs_ctx auctx diff --git a/library/lib.mli b/library/lib.mli index 721e2896f..cf75d5f8c 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -153,13 +153,22 @@ val init : unit -> unit (** {6 Section management for discharge } *) type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list -type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t +type abstr_info = private { + abstr_ctx : variable_context; + (** Section variables of this prefix *) + abstr_subst : Univ.Instance.t; + (** Actual names of the abstracted variables *) + abstr_uctx : Univ.AUContext.t; + (** Universe quantification, same length as the substitution *) +} val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.Constant.t -> abstr_info val section_segment_of_mutual_inductive: Names.MutInd.t -> abstr_info +val section_segment_of_reference : Globnames.global_reference -> abstr_info + val variable_section_segment_of_reference : Globnames.global_reference -> variable_context val section_instance : Globnames.global_reference -> Univ.Instance.t * Names.Id.t array diff --git a/library/libnames.ml b/library/libnames.ml index 81878e72f..a471d8396 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -156,10 +156,15 @@ let qualid_of_dirpath dir = type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} -let make_oname (dirpath,(mp,dir)) id = - make_path dirpath id, KerName.make mp dir (Label.of_id id) +(* let make_oname (dirpath,(mp,dir)) id = *) +let make_oname { obj_dir; obj_mp; obj_sec } id = + make_path obj_dir id, KerName.make obj_mp obj_sec (Label.of_id id) (* to this type are mapped DirPath.t's in the nametab *) type global_dir_reference = @@ -170,10 +175,10 @@ type global_dir_reference = | DirClosedSection of DirPath.t (* this won't last long I hope! *) -let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) = - DirPath.equal d1 d2 && - DirPath.equal p1 p2 && - ModPath.equal mp1 mp2 +let eq_op op1 op2 = + DirPath.equal op1.obj_dir op2.obj_dir && + DirPath.equal op1.obj_sec op2.obj_sec && + ModPath.equal op1.obj_mp op2.obj_mp let eq_global_dir_reference r1 r2 = match r1, r2 with | DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 diff --git a/library/libnames.mli b/library/libnames.mli index ed01163ee..71f542240 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -94,7 +94,25 @@ val qualid_of_ident : Id.t -> qualid type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +(** Object prefix morally contains the "prefix" naming of an object to + be stored by [library], where [obj_dir] is the "absolute" path, + [obj_mp] is the current "module" prefix and [obj_sec] is the + "section" prefix. + + Thus, for an object living inside [Module A. Section B.] the + prefix would be: + + [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ] + + Note that both [obj_dir] and [obj_sec] are "paths" that is to say, + as opposed to [obj_mp] which is a single module name. + + *) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} val eq_op : object_prefix -> object_prefix -> bool diff --git a/library/library.ml b/library/library.ml index 88470d121..868e26684 100644 --- a/library/library.ml +++ b/library/library.ml @@ -170,7 +170,7 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - if not Coq_config.no_native_compiler then + if Coq_config.native_compiler then Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function @@ -738,7 +738,7 @@ let save_library_to ?todo dir f otab = System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; (* Writing native code files *) - if !Flags.native_compiler then + if !Flags.output_native_objects then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in if not (Nativelib.compile_library dir ast fn) then user_err Pp.(str "Could not compile the library to native code.") diff --git a/library/nametab.ml b/library/nametab.ml index 0ec4a37cd..08881d6d7 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -81,8 +81,9 @@ struct Module F (X : S). Module X. The argument X of the functor F is masked by the inner module X. *) - let masking_absolute n = - Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) + let warn_masking_absolute = + CWarnings.create ~name:"masking-absolute-name" ~category:"deprecated" + (fun n -> str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) type user_name = U.t @@ -121,7 +122,7 @@ struct | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - masking_absolute n; tree.path + warn_masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) else tree.path @@ -154,7 +155,7 @@ let rec push_exactly uname o level tree = function | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - masking_absolute n; tree.path + warn_masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) in @@ -302,6 +303,16 @@ module DirTab = Make(DirPath')(GlobDir) type dirtab = DirTab.t let the_dirtab = ref (DirTab.empty : dirtab) +type universe_id = DirPath.t * int + +module UnivIdEqual = +struct + type t = universe_id + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' +end +module UnivTab = Make(FullPath)(UnivIdEqual) +type univtab = UnivTab.t +let the_univtab = ref (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) @@ -318,6 +329,21 @@ let the_modrevtab = ref (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t let the_modtyperevtab = ref (MPmap.empty : mptrevtab) +module UnivIdOrdered = +struct + type t = universe_id + let hash (d, i) = i + DirPath.hash d + let compare (d, i) (d', i') = + let c = Int.compare i i' in + if Int.equal c 0 then DirPath.compare d d' + else c +end + +module UnivIdMap = HMap.Make(UnivIdOrdered) + +type univrevtab = full_path UnivIdMap.t +let the_univrevtab = ref (UnivIdMap.empty : univrevtab) + (* Push functions *********************************************************) (* This is for permanent constructions (never discharged -- but with @@ -359,9 +385,14 @@ let push_modtype vis sp kn = let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with - DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab - | _ -> () + | DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab + | _ -> () + +(* This is for global universe names *) +let push_universe vis sp univ = + the_univtab := UnivTab.push vis sp univ !the_univtab; + the_univrevtab := UnivIdMap.add univ sp !the_univrevtab (* Locate functions *******************************************************) @@ -382,21 +413,23 @@ let locate_syndef qid = match locate_extended qid with let locate_modtype qid = MPTab.locate qid !the_modtypetab let full_name_modtype qid = MPTab.user_name qid !the_modtypetab +let locate_universe qid = UnivTab.locate qid !the_univtab + let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with - | DirModule (_,(mp,_)) -> mp + | DirModule { obj_mp ; _} -> obj_mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with - | DirModule (dir,_) -> dir + | DirModule { obj_dir ; _} -> obj_dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with - | DirOpenSection (dir, _) + | DirOpenSection { obj_dir; _ } -> obj_dir | DirClosedSection dir -> dir | _ -> raise Not_found @@ -447,6 +480,8 @@ let exists_module = exists_dir let exists_modtype sp = MPTab.exists sp !the_modtypetab +let exists_universe kn = UnivTab.exists kn !the_univtab + (* Reverse locate functions ***********************************************) let path_of_global ref = @@ -469,6 +504,9 @@ let dirpath_of_module mp = let path_of_modtype mp = MPmap.find mp !the_modtyperevtab +let path_of_universe mp = + UnivIdMap.find mp !the_univrevtab + (* Shortest qualid functions **********************************************) let shortest_qualid_of_global ctx ref = @@ -490,6 +528,10 @@ let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab +let shortest_qualid_of_universe kn = + let sp = UnivIdMap.find kn !the_univrevtab in + UnivTab.shortest_qualid Id.Set.empty sp !the_univtab + let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> @@ -508,24 +550,28 @@ let global_inductive r = (********************************************************************) (* Registration of tables as a global table and rollback *) -type frozen = ccitab * dirtab * mptab - * globrevtab * mprevtab * mptrevtab +type frozen = ccitab * dirtab * mptab * univtab + * globrevtab * mprevtab * mptrevtab * univrevtab let freeze _ : frozen = !the_ccitab, !the_dirtab, !the_modtypetab, + !the_univtab, !the_globrevtab, !the_modrevtab, - !the_modtyperevtab + !the_modtyperevtab, + !the_univrevtab -let unfreeze (ccit,dirt,mtyt,globr,modr,mtyr) = +let unfreeze (ccit,dirt,mtyt,univt,globr,modr,mtyr,univr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; + the_univtab := univt; the_globrevtab := globr; the_modrevtab := modr; - the_modtyperevtab := mtyr + the_modtyperevtab := mtyr; + the_univrevtab := univr let _ = Summary.declare_summary "names" diff --git a/library/nametab.mli b/library/nametab.mli index c02447a7c..77fafa100 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -78,6 +78,12 @@ val push_modtype : visibility -> full_path -> ModPath.t -> unit val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit +type universe_id = DirPath.t * int + +module UnivIdMap : CMap.ExtS with type key = universe_id + +val push_universe : visibility -> full_path -> universe_id -> unit + (** {6 The following functions perform globalization of qualified names } *) (** These functions globalize a (partially) qualified name or fail with @@ -91,6 +97,7 @@ val locate_modtype : qualid -> ModPath.t val locate_dir : qualid -> global_dir_reference val locate_module : qualid -> ModPath.t val locate_section : qualid -> DirPath.t +val locate_universe : qualid -> universe_id (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message @@ -119,6 +126,7 @@ val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) +val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) @@ -138,6 +146,10 @@ val path_of_global : global_reference -> full_path val dirpath_of_module : ModPath.t -> DirPath.t val path_of_modtype : ModPath.t -> full_path +(** A universe_id might not be registered with a corresponding user name. + @raise Not_found if the universe was not introduced by the user. *) +val path_of_universe : universe_id -> full_path + (** Returns in particular the dirpath or the basename of the full path associated to global reference *) @@ -158,6 +170,7 @@ val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : ModPath.t -> qualid val shortest_qualid_of_module : ModPath.t -> qualid +val shortest_qualid_of_universe : universe_id -> qualid (** Deprecated synonyms *) diff --git a/library/summary.ml b/library/summary.ml index 9f49d1f83..6df17476b 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -13,17 +13,22 @@ open Util module Dyn = Dyn.Make () type marshallable = [ `Yes | `No | `Shallow ] + type 'a summary_declaration = { freeze_function : marshallable -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } -let summaries = ref Int.Map.empty +let sum_mod = ref None +let sum_map = ref String.Map.empty let mangle id = id ^ "-SUMMARY" +let unmangle id = String.(sub id 0 (length id - 8)) + +let ml_modules = "ML-MODULES" -let internal_declare_summary hash sumname sdecl = - let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in +let internal_declare_summary fadd sumname sdecl = + let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in @@ -32,140 +37,116 @@ let internal_declare_summary hash sumname sdecl = unfreeze_function = dyn_unfreeze; init_function = dyn_init } in - summaries := Int.Map.add hash (sumname, ddecl) !summaries + fadd sumname ddecl; + tag -let all_declared_summaries = ref Int.Set.empty +let declare_ml_modules_summary decl = + let ml_add _ ddecl = sum_mod := Some ddecl in + internal_declare_summary ml_add ml_modules decl -let summary_names = ref [] -let name_of_summary name = - try List.assoc name !summary_names - with Not_found -> "summary name not found" +let declare_ml_modules_summary decl = + ignore(declare_ml_modules_summary decl) -let declare_summary sumname decl = - let hash = String.hash sumname in - let () = if Int.Map.mem hash !summaries then - let (name, _) = Int.Map.find hash !summaries in - anomaly ~label:"Summary.declare_summary" - (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name ++ str ".") +let declare_summary_tag sumname decl = + let fadd name ddecl = sum_map := String.Map.add name ddecl !sum_map in + let () = if String.Map.mem sumname !sum_map then + anomaly ~label:"Summary.declare_summary" + (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str sumname ++ str ".") in - all_declared_summaries := Int.Set.add hash !all_declared_summaries; - summary_names := (hash, sumname) :: !summary_names; - internal_declare_summary hash sumname decl + internal_declare_summary fadd sumname decl + +let declare_summary sumname decl = + ignore(declare_summary_tag sumname decl) type frozen = { - summaries : (int * Dyn.t) list; + summaries : Dyn.t String.Map.t; (** Ordered list w.r.t. the first component. *) ml_module : Dyn.t option; (** Special handling of the ml_module summary. *) } -let empty_frozen = { summaries = []; ml_module = None; } - -let ml_modules = "ML-MODULES" -let ml_modules_summary = String.hash ml_modules +let empty_frozen = { summaries = String.Map.empty; ml_module = None } let freeze_summaries ~marshallable : frozen = - let fold id (_, decl) accu = - (* to debug missing Lazy.force - if marshallable <> `No then begin - let id, _ = Int.Map.find id !summaries in - prerr_endline ("begin marshalling " ^ id); - ignore(Marshal.to_string (decl.freeze_function marshallable) []); - prerr_endline ("end marshalling " ^ id); - end; - /debug *) - let state = decl.freeze_function marshallable in - if Int.equal id ml_modules_summary then { accu with ml_module = Some state } - else { accu with summaries = (id, state) :: accu.summaries } + let smap decl = decl.freeze_function marshallable in + { summaries = String.Map.map smap !sum_map; + ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod; + } + +let unfreeze_single name state = + let decl = + try String.Map.find name !sum_map + with + | Not_found -> + CErrors.anomaly Pp.(str "trying to unfreeze unregistered summary " ++ str name) in - Int.Map.fold_right fold !summaries empty_frozen - -let unfreeze_summaries fs = + try decl.unfreeze_function state + with e when CErrors.noncritical e -> + let e = CErrors.push e in + Feedback.msg_warning + Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]); + iraise e + +let unfreeze_summaries ?(partial=false) { summaries; ml_module } = (* The unfreezing of [ml_modules_summary] has to be anticipated since it - * may modify the content of [summaries] ny loading new ML modules *) - let (_, decl) = - try Int.Map.find ml_modules_summary !summaries - with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") - in - let () = match fs.ml_module with + * may modify the content of [summaries] by loading new ML modules *) + begin match !sum_mod with | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") - | Some state -> decl.unfreeze_function state - in - let fold id (_, decl) states = - if Int.equal id ml_modules_summary then states - else match states with - | [] -> - let () = decl.init_function () in - [] - | (nid, state) :: rstates -> - if Int.equal id nid then - let () = decl.unfreeze_function state in rstates - else - let () = decl.init_function () in states + | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module + end; + (** We must be independent on the order of the map! *) + let ufz name decl = + try decl.unfreeze_function String.Map.(find name summaries) + with Not_found -> + if not partial then begin + Feedback.msg_warning Pp.(str "Summary was captured out of module scope for entry " ++ str name); + decl.init_function () + end; in - let fold id decl state = - try fold id decl state - with e when CErrors.noncritical e -> - let e = CErrors.push e in - Feedback.msg_error - Pp.(seq [str "Error unfreezing summary %s\n%s\n%!"; - str (name_of_summary id); - CErrors.iprint e]); - iraise e - in - (** We rely on the order of the frozen list, and the order of folding *) - ignore (Int.Map.fold_left fold !summaries fs.summaries) + (* String.Map.iter unfreeze_single !sum_map *) + String.Map.iter ufz !sum_map let init_summaries () = - Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries + String.Map.iter (fun _ decl -> decl.init_function ()) !sum_map (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) let nop () = () -(** Selective freeze *) +(** Summary projection *) +let project_from_summary { summaries } tag = + let id = unmangle (Dyn.repr tag) in + let state = String.Map.find id summaries in + Option.get (Dyn.Easy.prj state tag) + +let modify_summary st tag v = + let id = unmangle (Dyn.repr tag) in + let summaries = String.Map.set id (Dyn.Easy.inj v tag) st.summaries in + {st with summaries} -type frozen_bits = (int * Dyn.t) list +let remove_from_summary st tag = + let id = unmangle (Dyn.repr tag) in + let summaries = String.Map.remove id st.summaries in + {st with summaries} + +(** Selective freeze *) -let ids_of_string_list complement ids = - if not complement then List.map String.hash ids - else - let fold accu id = - let id = String.hash id in - Int.Set.remove id accu - in - let ids = List.fold_left fold !all_declared_summaries ids in - Int.Set.elements ids +type frozen_bits = Dyn.t String.Map.t let freeze_summary ~marshallable ?(complement=false) ids = - let ids = ids_of_string_list complement ids in - List.map (fun id -> - let (_, summary) = Int.Map.find id !summaries in - id, summary.freeze_function marshallable) - ids - -let unfreeze_summary datas = - List.iter - (fun (id, data) -> - let (name, summary) = Int.Map.find id !summaries in - try summary.unfreeze_function data - with e -> - let e = CErrors.push e in - prerr_endline ("Exception unfreezing " ^ name); - iraise e) - datas + let sub_map = String.Map.filter (fun id _ -> complement <> List.(mem id ids)) !sum_map in + String.Map.map (fun decl -> decl.freeze_function marshallable) sub_map + +let unfreeze_summary = String.Map.iter unfreeze_single let surgery_summary { summaries; ml_module } bits = - let summaries = List.map (fun (id, _ as orig) -> - try id, List.assoc id bits - with Not_found -> orig) - summaries in + let summaries = + String.Map.fold (fun hash state sum -> String.Map.set hash state sum ) summaries bits in { summaries; ml_module } let project_summary { summaries; ml_module } ?(complement=false) ids = - let ids = ids_of_string_list complement ids in - List.filter (fun (id, _) -> List.mem id ids) summaries + String.Map.filter (fun name _ -> complement <> List.(mem name ids)) summaries let pointer_equal l1 l2 = let ptr_equal d1 d2 = @@ -174,19 +155,22 @@ let pointer_equal l1 l2 = match Dyn.eq t1 t2 with | None -> false | Some Refl -> x1 == x2 - in + in + let l1, l2 = String.Map.bindings l1, String.Map.bindings l2 in CList.for_all2eq (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 (** All-in-one reference declaration + registration *) -let ref ?(freeze=fun _ r -> r) ~name x = +let ref_tag ?(freeze=fun _ r -> r) ~name x = let r = ref x in - declare_summary name + let tag = declare_summary_tag name { freeze_function = (fun b -> freeze b !r); unfreeze_function = ((:=) r); - init_function = (fun () -> r := x) }; - r + init_function = (fun () -> r := x) } in + r, tag + +let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x module Local = struct @@ -198,8 +182,7 @@ let (!) r = let key, name = !r in try CEphemeron.get key with CEphemeron.InvalidKey -> - let _, { init_function } = - Int.Map.find (String.hash (mangle name)) !summaries in + let { init_function } = String.Map.find name !sum_map in init_function (); CEphemeron.get (fst !r) diff --git a/library/summary.mli b/library/summary.mli index d093d95f2..09447199e 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -36,6 +36,12 @@ type 'a summary_declaration = { val declare_summary : string -> 'a summary_declaration -> unit +(** We provide safe projection from the summary to the types stored in + it.*) +module Dyn : Dyn.S + +val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag + (** All-in-one reference declaration + summary registration. It behaves just as OCaml's standard [ref] function, except that a [declare_summary] is done, with [name] as string. @@ -43,6 +49,7 @@ val declare_summary : string -> 'a summary_declaration -> unit The [freeze_function] can be overridden *) val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref +val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag (* As [ref] but the value is local to a process, i.e. not sent to, say, proof * workers. It is useful to implement a local cache for example. *) @@ -55,10 +62,11 @@ module Local : sig end -(** Special name for the summary of ML modules. This summary entry is - special because its unfreeze may load ML code and hence add summary - entries. Thus is has to be recognizable, and handled appropriately *) -val ml_modules : string +(** Special summary for ML modules. This summary entry is special + because its unfreeze may load ML code and hence add summary + entries. Thus is has to be recognizable, and handled properly. + *) +val declare_ml_modules_summary : 'a summary_declaration -> unit (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) @@ -72,19 +80,34 @@ type frozen val empty_frozen : frozen val freeze_summaries : marshallable:marshallable -> frozen -val unfreeze_summaries : frozen -> unit +val unfreeze_summaries : ?partial:bool -> frozen -> unit val init_summaries : unit -> unit -(** The type [frozen_bits] is a snapshot of some of the registered tables *) +(** Typed projection of the summary. Experimental API, use with CARE *) + +val modify_summary : frozen -> 'a Dyn.tag -> 'a -> frozen +val project_from_summary : frozen -> 'a Dyn.tag -> 'a +val remove_from_summary : frozen -> 'a Dyn.tag -> frozen + +(** The type [frozen_bits] is a snapshot of some of the registered + tables. It is DEPRECATED in favor of the typed projection + version. *) + type frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] -val freeze_summary : - marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits +[@@@ocaml.warning "-3"] +val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] val unfreeze_summary : frozen_bits -> unit +[@@ocaml.deprecated "Please use the typed version of summary projection"] val surgery_summary : frozen -> frozen_bits -> frozen +[@@ocaml.deprecated "Please use the typed version of summary projection"] val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] val pointer_equal : frozen_bits -> frozen_bits -> bool +[@@ocaml.deprecated "Please use the typed version of summary projection"] +[@@@ocaml.warning "+3"] (** {6 Debug} *) - val dump : unit -> (int * string) list diff --git a/man/coqchk.1 b/man/coqchk.1 index 76a7cfc5d..f9241c0d4 100644 --- a/man/coqchk.1 +++ b/man/coqchk.1 @@ -23,7 +23,7 @@ library was not found, corrupted content, type-checking failure, etc. .IR modules \& is a list of modules to be checked. Modules can be referred to by a -short or qualified name. +short or qualified logical name, or by their filename. .SH OPTIONS @@ -34,13 +34,17 @@ add directory in the include path .TP -.BI \-R \ dir\ coqdir -recursively map physical +.BI \-Q \ dir\ coqdir +map physical .I dir to logical .I coqdir .TP +.BI \-R \ dir\ coqdir +synonymous for -Q + +.TP .BI \-silent makes coqchk less verbose. diff --git a/man/coqmktop.1 b/man/coqmktop.1 deleted file mode 100644 index 810df782c..000000000 --- a/man/coqmktop.1 +++ /dev/null @@ -1,71 +0,0 @@ -.TH COQ 1 "April 25, 2001" - -.SH NAME -coqmktop \- The Coq Proof Assistant user-tactics linker - - -.SH SYNOPSIS -.B coqmktop -[ -.I options -] -.I files - - -.SH DESCRIPTION - -.B coqmktop -builds a new Coq toplevel extended with user-tactics. -.IR files \& -are the Objective Caml object or library files -(i.e. with suffix .cmo, .cmx, .cma or .cmxa) to link with the Coq system. -The linker produces an executable Coq toplevel which can be called -directly or through coqc(1), using the \-image option. - -.SH OPTIONS - -.TP -.BI \-h -Help. List the available options. - -.TP -.BI \-srcdir \ dir -Specify where the Coq source files are - -.TP -.BI \-o \ exec\-file -Specify the name of the resulting toplevel - -.TP -.B \-opt -Compile in native code - -.TP -.B \-full -Link high level tactics - -.TP -.B \-top -Build Coq on a ocaml toplevel (incompatible with -.BR \-opt ) - -.TP -.BI \-R \ dir -Specify recursively directories for Ocaml - -.TP -.B \-v8 -Link with V8 grammar - - -.SH SEE ALSO - -.BR coqtop (1), -.BR ocamlmktop (1). -.BR ocamlc (1). -.BR ocamlopt (1). -.br -.I -The Coq Reference Manual. -.I -The Coq web site: http://coq.inria.fr diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 9c2766187..a3d257154 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -21,11 +21,11 @@ open Names a reference to the current level (to be translated into "SELF" on the left border and into "constr LEVEL n" elsewhere), to the level below (to be translated into "NEXT") or to an below wrt associativity (to be - translated in camlp4 into "constr" without level) or to another level + translated in camlp5 into "constr" without level) or to another level (to be translated into "constr LEVEL n") The boolean is true if the entry was existing _and_ empty; this to - circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the + circumvent a weakness of camlp5 whose undo mechanism is not the converse of the extension mechanism *) let constr_level = string_of_int @@ -144,11 +144,11 @@ let find_position accu forpat assoc level = (**************************************************************************) (* - * --- Note on the mapping of grammar productions to camlp4 actions --- + * --- Note on the mapping of grammar productions to camlp5 actions --- * * Translation of environments: a production * [ nt1(x1) ... nti(xi) ] -> act(x1..xi) - * is written (with camlp4 conventions): + * is written (with camlp5 conventions): * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) * where v1..vi are the values generated by non-terminals nt1..nti. * Since the actions are executed by substituting an environment, @@ -172,8 +172,8 @@ let find_position accu forpat assoc level = (**********************************************************************) (* Binding constr entry keys to entries *) -(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) -let camlp4_assoc = function +(* Camlp5 levels do not treat NonA: use RightA with a NEXT on the left *) +let camlp5_assoc = function | Some NonA | Some RightA -> RightA | None | Some LeftA -> LeftA @@ -205,7 +205,7 @@ let adjust_level assoc from = function (* If NonA on the left-hand side, adopt the current assoc ?? *) | (NumLevel n,BorderProd (Left,Some NonA)) -> None (* If the expected assoc is the current one, set to SELF *) - | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> + | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp5_assoc assoc) -> None (* Otherwise, force the level, n or n-1, according to expected assoc *) | (NumLevel n,BorderProd (Left,Some a)) -> @@ -229,11 +229,11 @@ type (_, _) entry = | TTName : ('self, Name.t Loc.located) entry | TTReference : ('self, reference) entry | TTBigint : ('self, Constrexpr.raw_natural_number) entry -| TTBinder : ('self, local_binder_expr list) entry | TTConstr : prod_info * 'r target -> ('r, 'r) entry | TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry -| TTBinderListT : ('self, local_binder_expr list) entry -| TTBinderListF : Tok.t list -> ('self, local_binder_expr list list) entry +| TTPattern : int -> ('self, cases_pattern_expr) entry +| TTOpenBinderList : ('self, local_binder_expr list) entry +| TTClosedBinderList : Tok.t list -> ('self, local_binder_expr list list) entry type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry @@ -289,31 +289,24 @@ let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun as Alist1 (symbol_of_target typ' assoc from forpat) | TTConstrList (typ', tkl, forpat) -> Alist1sep (symbol_of_target typ' assoc from forpat, make_sep_rules tkl) -| TTBinderListF [] -> Alist1 (Aentry Constr.binder) -| TTBinderListF tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl) +| TTPattern p -> Aentryl (Constr.pattern, p) +| TTClosedBinderList [] -> Alist1 (Aentry Constr.binder) +| TTClosedBinderList tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl) | TTName -> Aentry Prim.name -| TTBinder -> Aentry Constr.binder -| TTBinderListT -> Aentry Constr.open_binders +| TTOpenBinderList -> Aentry Constr.open_binders | TTBigint -> Aentry Prim.bigint | TTReference -> Aentry Constr.global let interp_entry forpat e = match e with -| ETName -> TTAny TTName -| ETReference -> TTAny TTReference -| ETBigint -> TTAny TTBigint -| ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList.") -| ETBinder false -> TTAny TTBinder -| ETConstr p -> TTAny (TTConstr (p, forpat)) -| ETPattern -> assert false (** not used *) -| ETOther _ -> assert false (** not used *) -| ETConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat)) -| ETBinderList (true, []) -> TTAny TTBinderListT -| ETBinderList (true, _) -> assert false -| ETBinderList (false, tkl) -> TTAny (TTBinderListF tkl) - -let constr_expr_of_name (loc,na) = CAst.make ?loc @@ match na with - | Anonymous -> CHole (None,Misctypes.IntroAnonymous,None) - | Name id -> CRef (Ident (Loc.tag ?loc id), None) +| ETProdName -> TTAny TTName +| ETProdReference -> TTAny TTReference +| ETProdBigint -> TTAny TTBigint +| ETProdConstr p -> TTAny (TTConstr (p, forpat)) +| ETProdPattern p -> TTAny (TTPattern p) +| ETProdOther _ -> assert false (** not used *) +| ETProdConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat)) +| ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList +| ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl) let cases_pattern_expr_of_name (loc,na) = CAst.make ?loc @@ match na with | Anonymous -> CPatAtom None @@ -322,7 +315,8 @@ let cases_pattern_expr_of_name (loc,na) = CAst.make ?loc @@ match na with type 'r env = { constrs : 'r list; constrlists : 'r list list; - binders : (local_binder_expr list * bool) list; + binders : cases_pattern_expr list; + binderlists : local_binder_expr list list; } let push_constr subst v = { subst with constrs = v :: subst.constrs } @@ -332,12 +326,16 @@ match e with | TTConstr _ -> push_constr subst v | TTName -> begin match forpat with - | ForConstr -> push_constr subst (constr_expr_of_name v) + | ForConstr -> { subst with binders = cases_pattern_expr_of_name v :: subst.binders } | ForPattern -> push_constr subst (cases_pattern_expr_of_name v) end -| TTBinder -> { subst with binders = (v, true) :: subst.binders } -| TTBinderListT -> { subst with binders = (v, true) :: subst.binders } -| TTBinderListF _ -> { subst with binders = (List.flatten v, false) :: subst.binders } +| TTPattern _ -> + begin match forpat with + | ForConstr -> { subst with binders = v :: subst.binders } + | ForPattern -> push_constr subst v + end +| TTOpenBinderList -> { subst with binderlists = v :: subst.binderlists } +| TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (v,true))) @@ -437,11 +435,9 @@ let rec pure_sublevels : type a b c. int option -> (a, b, c) rule -> int list = let make_act : type r. r target -> _ -> r gen_eval = function | ForConstr -> fun notation loc env -> - let env = (env.constrs, env.constrlists, List.map fst env.binders) in - CAst.make ~loc @@ CNotation (notation , env) + let env = (env.constrs, env.constrlists, env.binders, env.binderlists) in + CAst.make ~loc @@ CNotation (notation, env) | ForPattern -> fun notation loc env -> - let invalid = List.exists (fun (_, b) -> not b) env.binders in - let () = if invalid then Constrexpr_ops.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in CAst.make ~loc @@ CPatNotation (notation, env, []) @@ -457,7 +453,7 @@ let extend_constr state forpat ng = let needed_levels, state = register_empty_levels state isforpat pure_sublevels in let (pos,p4assoc,name,reinit), state = find_position state isforpat assoc level in let empty_rules = List.map (prepare_empty_levels isforpat) needed_levels in - let empty = { constrs = []; constrlists = []; binders = [] } in + let empty = { constrs = []; constrlists = []; binders = []; binderlists = [] } in let act = ty_eval r (make_act forpat ng.notgram_notation) empty in let rule = (name, p4assoc, [Rule (symbs, act)]) in let r = ExtendRule (entry, reinit, (pos, [rule])) in diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 8e0469275..1e3869818 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Mapping of grammar productions to camlp4 actions *) +(** Mapping of grammar productions to camlp5 actions *) (** This is the part specific to Coq-level Notation and Tactic Notation. For the ML-level tactic and vernac extensions, see Egramml. *) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 7414773d3..74dd95a20 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -8,7 +8,7 @@ open Vernacexpr -(** Mapping of grammar productions to camlp4 actions. *) +(** Mapping of grammar productions to camlp5 actions. *) (** This is the part specific to vernac extensions. For the Coq-level Notation and Tactic Notation, see Egramcoq. *) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 7e5933cea..9f12db649 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -120,7 +120,7 @@ let name_colon = | _ -> err ()) | _ -> err ()) -let aliasvar = function { CAst.loc = loc; CAst.v = CPatAlias (_, id) } -> Some (loc,Name id) | _ -> None +let aliasvar = function { CAst.v = CPatAlias (_, na) } -> Some na | _ -> None GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr universe_level sort sort_family @@ -155,9 +155,15 @@ GEXTEND Gram | "Type" -> Sorts.InType ] ] ; + universe_expr: + [ [ id = global; "+"; n = natural -> Some (id,n) + | id = global -> Some (id,0) + | "_" -> None + ] ] + ; universe: - [ [ IDENT "max"; "("; ids = LIST1 name SEP ","; ")" -> ids - | id = name -> [id] + [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> ids + | u = universe_expr -> [u] ] ] ; lconstr: @@ -210,9 +216,11 @@ GEXTEND Gram | "("; c = operconstr LEVEL "200"; ")" -> (match c.CAst.v with | CPrim (Numeral (n,true)) -> - CAst.make ~loc:(!@loc) @@ CNotation("( _ )",([c],[],[])) + CAst.make ~loc:(!@loc) @@ CNotation("( _ )",([c],[],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c + | "{"; c = binder_constr ; "}" -> + CAst.make ~loc:(!@loc) @@ CNotation(("{ _ }"),([c],[],[],[])) | "`{"; c = operconstr LEVEL "200"; "}" -> CAst.make ~loc:(!@loc) @@ CGeneralization (Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> @@ -261,17 +269,17 @@ GEXTEND Gram | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CAst.make ~loc:!@loc @@ - CCases (LetPatternStyle, None, [c1, None, None], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) + CCases (LetPatternStyle, None, [c1, None, None], [Loc.tag ~loc:!@loc ([[p]], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CAst.make ~loc:!@loc @@ - CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) + CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [Loc.tag ~loc:!@loc ([[p]], c2)]) | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CAst.make ~loc:!@loc @@ - CCases (LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) + CCases (LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [Loc.tag ~loc:!@loc ([[p]], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> @@ -307,8 +315,9 @@ GEXTEND Gram universe_level: [ [ "Set" -> GSet | "Prop" -> GProp - | "Type" -> GType None - | id = name -> GType (Some id) + | "Type" -> GType UUnknown + | "_" -> GType UAnonymous + | id = global -> GType (UNamed id) ] ] ; fix_constr: @@ -355,7 +364,7 @@ GEXTEND Gram [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; mult_pattern: - [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (Loc.tag ~loc:!@loc pl) ] ] + [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> pl ] ] ; eqn: [ [ pll = LIST1 mult_pattern SEP "|"; @@ -378,19 +387,9 @@ GEXTEND Gram | "99" RIGHTA [ ] | "90" RIGHTA [ ] | "10" LEFTA - [ p = pattern; "as"; id = ident -> - CAst.make ~loc:!@loc @@ CPatAlias (p, id) - | p = pattern; lp = LIST1 NEXT -> - (let open CAst in match p with - | { v = CPatAtom (Some r) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, None, lp) - | { v = CPatCstr (r, None, l2); loc } -> - CErrors.user_err ?loc ~hdr:"compound_pattern" - (Pp.str "Nested applications not supported.") - | { v = CPatCstr (r, l1, l2) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, l1 , l2@lp) - | { v = CPatNotation (n, s, l) } -> CAst.make ~loc:!@loc @@ CPatNotation (n , s, l@lp) - | _ -> CErrors.user_err - ?loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" - (Pp.str "Such pattern cannot have arguments.")) + [ p = pattern; "as"; na = name -> + CAst.make ~loc:!@loc @@ CPatAlias (p, na) + | p = pattern; lp = LIST1 NEXT -> mkAppPattern ~loc:!@loc p lp | "@"; r = Prim.reference; lp = LIST0 NEXT -> CAst.make ~loc:!@loc @@ CPatCstr (r, Some lp, []) ] | "1" LEFTA diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index f10d74677..1c3ba7837 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -28,7 +28,8 @@ GEXTEND Gram | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ] ; command: - [ [ IDENT "Goal"; c = lconstr -> VernacGoal c + [ [ IDENT "Goal"; c = lconstr -> + VernacDefinition (Decl_kinds.(NoDischarge, Definition), ((Loc.tag ~loc:!@loc Names.Anonymous), None), ProveBody ([], c)) | IDENT "Proof" -> VernacProof (None,None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; c = lconstr -> VernacExactProof c @@ -70,19 +71,16 @@ GEXTEND Gram VernacCreateHintDb (id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> VernacRemoveHints (dbnames, ids) - | IDENT "Hint"; local = obsolete_locality; h = hint; + | IDENT "Hint"; h = hint; dbnames = opt_hintbases -> - VernacHints (local,dbnames, h) + VernacHints (dbnames, h) (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info; dbnames = opt_hintbases -> - VernacHints (false,dbnames, + VernacHints (dbnames, HintsResolve (List.map (fun x -> (info, true, x)) lc)) ] ]; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; reference_or_constr: [ [ r = global -> HintsReference r | c = constr -> HintsConstr c ] ] diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0e585cff7..d90fd3eb7 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -15,8 +15,9 @@ open Constrexpr_ops open Extend open Vernacexpr open Decl_kinds +open Declarations open Misctypes -open Tok (* necessary for camlp4 *) +open Tok (* necessary for camlp5 *) open Pcoq open Pcoq.Prim @@ -65,39 +66,42 @@ let parse_compat_version ?(allow_old = true) = let open Flags in function Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") GEXTEND Gram - GLOBAL: vernac gallina_ext noedit_mode subprf; - vernac: FIRST - [ [ IDENT "Time"; c = located_vernac -> VernacTime c + GLOBAL: vernac_control gallina_ext noedit_mode subprf; + vernac_control: FIRST + [ [ IDENT "Time"; c = located_vernac -> VernacTime (false,c) | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) - | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) - | IDENT "Fail"; v = vernac -> VernacFail v - - | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) - | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) + | IDENT "Timeout"; n = natural; v = vernac_control -> VernacTimeout(n,v) + | IDENT "Fail"; v = vernac_control -> VernacFail v + | (f, v) = vernac -> VernacExpr(f, v) ] + ] + ; + vernac: + [ [ IDENT "Local"; (f, v) = vernac_poly -> (VernacLocal true :: f, v) + | IDENT "Global"; (f, v) = vernac_poly -> (VernacLocal false :: f, v) | v = vernac_poly -> v ] ] ; vernac_poly: - [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v) - | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) + [ [ IDENT "Polymorphic"; (f, v) = vernac_aux -> (VernacPolymorphic true :: f, v) + | IDENT "Monomorphic"; (f, v) = vernac_aux -> (VernacPolymorphic false :: f, v) | v = vernac_aux -> v ] ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) - [ [ IDENT "Program"; g = gallina; "." -> VernacProgram g - | IDENT "Program"; g = gallina_ext; "." -> VernacProgram g - | g = gallina; "." -> g - | g = gallina_ext; "." -> g - | c = command; "." -> c - | c = syntax; "." -> c - | c = subprf -> c + [ [ IDENT "Program"; g = gallina; "." -> ([VernacProgram], g) + | IDENT "Program"; g = gallina_ext; "." -> ([VernacProgram], g) + | g = gallina; "." -> ([], g) + | g = gallina_ext; "." -> ([], g) + | c = command; "." -> ([], c) + | c = syntax; "." -> ([], c) + | c = subprf -> ([], c) ] ] ; vernac_aux: LAST - [ [ prfcom = command_entry -> prfcom ] ] + [ [ prfcom = command_entry -> ([], prfcom) ] ] ; noedit_mode: [ [ c = query_command -> c None] ] @@ -111,7 +115,7 @@ GEXTEND Gram ; located_vernac: - [ [ v = vernac -> Loc.tag ~loc:!@loc v ] ] + [ [ v = vernac_control -> Loc.tag ~loc:!@loc v ] ] ; END @@ -129,6 +133,12 @@ let test_plural_form_types loc kwd = function warn_plural_command ~loc:!@loc kwd | _ -> () +let lname_of_lident : lident -> lname = + Loc.map (fun s -> Name s) + +let name_of_ident_decl : ident_decl -> name_decl = + on_fst lname_of_lident + (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion @@ -139,17 +149,17 @@ GEXTEND Gram [ [ thm = thm_token; id = ident_decl; bl = binders; ":"; c = lconstr; l = LIST0 [ "with"; id = ident_decl; bl = binders; ":"; c = lconstr -> - (Some id,(bl,c)) ] -> - VernacStartTheoremProof (thm, (Some id,(bl,c))::l) + (id,(bl,c)) ] -> + VernacStartTheoremProof (thm, (id,(bl,c))::l) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list -> test_plural_form loc kwd bl; VernacAssumption (stre, nl, bl) | d = def_token; id = ident_decl; b = def_body -> - VernacDefinition (d, id, b) + VernacDefinition (d, name_of_ident_decl id, b) | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((Some Discharge, Definition), (id, None), b) + VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) (* Gallina inductive declarations *) | cum = cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -167,13 +177,13 @@ GEXTEND Gram in VernacInductive (cum, priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (None, recs) + VernacFixpoint (NoDischarge, recs) | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (Some Discharge, recs) + VernacFixpoint (DoDischarge, recs) | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (None, corecs) + VernacCoFixpoint (NoDischarge, corecs) | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (Some Discharge, corecs) + VernacCoFixpoint (DoDischarge, corecs) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) @@ -195,23 +205,23 @@ GEXTEND Gram | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> (None, Definition) - | IDENT "Example" -> (None, Example) - | IDENT "SubClass" -> (None, SubClass) ] ] + [ [ "Definition" -> (NoDischarge,Definition) + | IDENT "Example" -> (NoDischarge,Example) + | IDENT "SubClass" -> (NoDischarge,SubClass) ] ] ; assumption_token: - [ [ "Hypothesis" -> (Some Discharge, Logical) - | "Variable" -> (Some Discharge, Definitional) - | "Axiom" -> (None, Logical) - | "Parameter" -> (None, Definitional) - | IDENT "Conjecture" -> (None, Conjectural) ] ] + [ [ "Hypothesis" -> (DoDischarge, Logical) + | "Variable" -> (DoDischarge, Definitional) + | "Axiom" -> (NoDischarge, Logical) + | "Parameter" -> (NoDischarge, Definitional) + | IDENT "Conjecture" -> (NoDischarge, Conjectural) ] ] ; assumptions_token: - [ [ IDENT "Hypotheses" -> ("Hypotheses", (Some Discharge, Logical)) - | IDENT "Variables" -> ("Variables", (Some Discharge, Definitional)) - | IDENT "Axioms" -> ("Axioms", (None, Logical)) - | IDENT "Parameters" -> ("Parameters", (None, Definitional)) - | IDENT "Conjectures" -> ("Conjectures", (None, Conjectural)) ] ] + [ [ IDENT "Hypotheses" -> ("Hypotheses", (DoDischarge, Logical)) + | IDENT "Variables" -> ("Variables", (DoDischarge, Definitional)) + | IDENT "Axioms" -> ("Axioms", (NoDischarge, Logical)) + | IDENT "Parameters" -> ("Parameters", (NoDischarge, Definitional)) + | IDENT "Conjectures" -> ("Conjectures", (NoDischarge, Conjectural)) ] ] ; inline: [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) @@ -617,37 +627,23 @@ GEXTEND Gram VernacCanonical (AN qid) | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation -> VernacCanonical (ByNotation ntn) - | IDENT "Canonical"; IDENT "Structure"; qid = global; - d = def_body -> + | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition - ((Some Global,CanonicalStructure),((Loc.tag s),None),d) + VernacDefinition ((NoDischarge,CanonicalStructure),((Loc.tag (Name s)),None),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),((Loc.tag s),None),d) - | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.tag s),None),d) - | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; - ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (true, f, s, t) + VernacDefinition ((NoDischarge,Coercion),((Loc.tag (Name s)),None),d) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (false, f, s, t) - | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, AN qid, s, t) - | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, ByNotation ntn, s, t) + VernacIdentityCoercion (f, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, AN qid, s, t) + VernacCoercion (AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, ByNotation ntn, s, t) + VernacCoercion (ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c @@ -831,7 +827,7 @@ GEXTEND Gram command: [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l - (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) + (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; info = hint_info -> @@ -1106,11 +1102,11 @@ GEXTEND Gram GLOBAL: syntax; syntax: - [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(true,sc)) + [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (true,sc) - | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(false,sc)) + | IDENT "Close"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc, Some key) @@ -1120,32 +1116,31 @@ GEXTEND Gram | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - | IDENT "Infix"; local = obsolete_locality; - op = ne_lstring; ":="; p = constr; + | IDENT "Infix"; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (local,(op,modl),p,sc) - | IDENT "Notation"; local = obsolete_locality; id = identref; + VernacInfix ((op,modl),p,sc) + | IDENT "Notation"; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition - (id,(idl,c),local,b) - | IDENT "Notation"; local = obsolete_locality; s = lstring; ":="; + (id,(idl,c),b) + | IDENT "Notation"; s = lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,(s,modl),sc) + VernacNotation (c,(s,modl),sc) | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> let (loc,s) = s in - VernacSyntaxExtension (true, false,((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (true,((loc,"x '"^s^"' y"),l)) - | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; + | IDENT "Reserved"; IDENT "Notation"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (false, local,(s,l)) + -> VernacSyntaxExtension (false, (s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) @@ -1158,9 +1153,6 @@ GEXTEND Gram Some (parse_compat_version s) | -> None ] ] ; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] @@ -1182,6 +1174,8 @@ GEXTEND Gram | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at"; lev = level -> SetItemLevel (x::l,lev) | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) + | x = IDENT; "at"; lev = level; b = constr_as_binder_kind -> SetItemLevelAsBinder ([x],b,Some lev) + | x = IDENT; b = constr_as_binder_kind -> SetItemLevelAsBinder ([x],b,None) | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) ] ] ; @@ -1189,7 +1183,20 @@ GEXTEND Gram [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference | IDENT "bigint" -> ETBigint | IDENT "binder" -> ETBinder true + | IDENT "constr"; n = OPT at_level; b = constr_as_binder_kind -> ETConstrAsBinder (b,n) + | IDENT "pattern" -> ETPattern (false,None) + | IDENT "pattern"; "at"; IDENT "level"; n = natural -> ETPattern (false,Some n) + | IDENT "strict"; IDENT "pattern" -> ETPattern (true,None) + | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> ETPattern (true,Some n) | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; + at_level: + [ [ "at"; n = level -> n ] ] + ; + constr_as_binder_kind: + [ [ "as"; IDENT "ident" -> AsIdent + | "as"; IDENT "pattern" -> AsIdentOrPattern + | "as"; IDENT "strict"; IDENT "pattern" -> AsStrictPattern ] ] + ; END diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 8e6a01aa3..ddb26d771 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -202,7 +202,7 @@ end = struct end -let camlp4_verbosity silent f x = +let camlp5_verbosity silent f x = let a = !warning_verbose in warning_verbose := silent; f x; @@ -274,7 +274,7 @@ type ext_kind = (** The list of extensions *) -let camlp4_state = ref [] +let camlp5_state = ref [] (** Deletion *) @@ -299,13 +299,13 @@ let grammar_delete e reinit (pos,rls) = let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in let undo () = grammar_delete e reinit ext in - let redo () = camlp4_verbosity false (uncurry (G.extend e)) ext in - camlp4_state := ByEXTEND (undo, redo) :: !camlp4_state; + let redo () = camlp5_verbosity false (uncurry (G.extend e)) ext in + camlp5_state := ByEXTEND (undo, redo) :: !camlp5_state; redo () let grammar_extend_sync e reinit ext = - camlp4_state := ByGrammar (ExtendRule (e, reinit, ext)) :: !camlp4_state; - camlp4_verbosity false (uncurry (G.extend e)) (of_coq_extend_statement ext) + camlp5_state := ByGrammar (ExtendRule (e, reinit, ext)) :: !camlp5_state; + camlp5_verbosity false (uncurry (G.extend e)) (of_coq_extend_statement ext) (** The apparent parser of Coq; encapsulate G to keep track of the extensions. *) @@ -315,20 +315,20 @@ module Gram = include G let extend e = curry - (fun ext -> - camlp4_state := - (ByEXTEND ((fun () -> grammar_delete e None ext), - (fun () -> uncurry (G.extend e) ext))) - :: !camlp4_state; - uncurry (G.extend e) ext) + (fun ext -> + camlp5_state := + (ByEXTEND ((fun () -> grammar_delete e None ext), + (fun () -> uncurry (G.extend e) ext))) + :: !camlp5_state; + uncurry (G.extend e) ext) let delete_rule e pil = (* spiwack: if you use load an ML module which contains GDELETE_RULE - in a section, God kills a kitty. As it would corrupt remove_grammars. + in a section, God kills a kitty. As it would corrupt remove_grammars. There does not seem to be a good way to undo a delete rule. As deleting - takes fewer arguments than extending. The production rule isn't returned - by delete_rule. If we could retrieve the necessary information, then - ByEXTEND provides just the framework we need to allow this in section. - I'm not entirely sure it makes sense, but at least it would be more correct. + takes fewer arguments than extending. The production rule isn't returned + by delete_rule. If we could retrieve the necessary information, then + ByEXTEND provides just the framework we need to allow this in section. + I'm not entirely sure it makes sense, but at least it would be more correct. *) G.delete_rule e pil end @@ -340,18 +340,18 @@ module Gram = let rec remove_grammars n = if n>0 then - (match !camlp4_state with + (match !camlp5_state with | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove.") | ByGrammar (ExtendRule (g, reinit, ext)) :: t -> grammar_delete g reinit (of_coq_extend_statement ext); - camlp4_state := t; + camlp5_state := t; remove_grammars (n-1) | ByEXTEND (undo,redo)::t -> undo(); - camlp4_state := t; + camlp5_state := t; remove_grammars n; redo(); - camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) + camlp5_state := ByEXTEND (undo,redo) :: !camlp5_state) let make_rule r = [None, None, r] @@ -503,8 +503,7 @@ module Vernac_ = let gallina_ext = gec_vernac "gallina_ext" let command = gec_vernac "command" let syntax = gec_vernac "syntax_command" - let vernac = gec_vernac "Vernac.vernac" - let vernac_eoi = eoi_entry vernac + let vernac_control = gec_vernac "Vernac.vernac_control" let rec_definition = gec_vernac "Vernac.rec_definition" let red_expr = make_gen_entry utactic "red_expr" let hint_info = gec_vernac "hint_info" @@ -517,7 +516,7 @@ module Vernac_ = let act_eoi = Gram.action (fun _ loc -> None) in let rule = [ ([ Symbols.stoken Tok.EOI ], act_eoi); - ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); + ([ Symbols.snterm (Gram.Entry.obj vernac_control) ], act_vernac ); ] in uncurry (Gram.extend main_entry) (None, make_rule rule) @@ -611,8 +610,8 @@ let unfreeze (grams, lex) = the lexer state should not be resetted, since it contains keywords declared in g_*.ml4 *) -let _ = - Summary.declare_summary "GRAMMAR_LEXER" +let parser_summary_tag = + Summary.declare_summary_tag "GRAMMAR_LEXER" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = Summary.nop } @@ -639,3 +638,15 @@ let () = Grammar.register0 wit_constr (Constr.constr); Grammar.register0 wit_red_expr (Vernac_.red_expr); () + +(** Registering extra grammar *) + +type any_entry = AnyEntry : 'a Gram.entry -> any_entry + +let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty + +let register_grammars_by_name name grams = + grammar_names := String.Map.add name grams !grammar_names + +let find_grammars_by_name name = + String.Map.find name !grammar_names diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d17ccb0b4..accb51366 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -124,7 +124,7 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e | | Egrammar.make_constr_prod_item V - Gramext.g_symbol list which is sent to camlp4 + Gramext.g_symbol list which is sent to camlp5 For user level tactic notations, dynamic addition of new rules is also done in several steps: @@ -161,9 +161,9 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e *) -(** Temporarily activate camlp4 verbosity *) +(** Temporarily activate camlp5 verbosity *) -val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit +val camlp5_verbosity : bool -> ('a -> unit) -> 'a -> unit (** Parse a string *) @@ -251,9 +251,8 @@ module Vernac_ : val gallina_ext : vernac_expr Gram.entry val command : vernac_expr Gram.entry val syntax : vernac_expr Gram.entry - val vernac : vernac_expr Gram.entry + val vernac_control : vernac_control Gram.entry val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry - val vernac_eoi : vernac_expr Gram.entry val noedit_mode : vernac_expr Gram.entry val command_entry : vernac_expr Gram.entry val red_expr : raw_red_expr Gram.entry @@ -261,7 +260,7 @@ module Vernac_ : end (** The main entry: reads an optional vernac command *) -val main_entry : (Loc.t * vernac_expr) option Gram.entry +val main_entry : (Loc.t * vernac_control) option Gram.entry (** Handling of the proof mode entry *) val get_command_entry : unit -> vernac_expr Gram.entry @@ -313,3 +312,13 @@ val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b (** Location Utils *) val to_coqloc : Ploc.t -> Loc.t val (!@) : Ploc.t -> Loc.t + +type frozen_t +val parser_summary_tag : frozen_t Summary.Dyn.tag + +(** Registering grammars by name *) + +type any_entry = AnyEntry : 'a Gram.entry -> any_entry + +val register_grammars_by_name : string -> any_entry list -> unit +val find_grammars_by_name : string -> any_entry list diff --git a/parsing/tok.ml b/parsing/tok.ml index 0917e8d6d..fafad2779 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -60,7 +60,7 @@ let match_keyword kwd = function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false -(* Needed to fix Camlp4 signature. +(* Needed to fix Camlp5 signature. Cannot use Pp because of silly Tox -> Compat -> Pp dependency *) let print ppf tok = Format.pp_print_string ppf (to_string tok) diff --git a/parsing/tok.mli b/parsing/tok.mli index 59a79dcd2..162310e2a 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -22,7 +22,7 @@ type t = val equal : t -> t -> bool val extract_string : t -> string val to_string : t -> string -(* Needed to fit Camlp4 signature *) +(* Needed to fit Camlp5 signature *) val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool (** for camlp5 *) diff --git a/plugins/.dir-locals.el b/plugins/.dir-locals.el deleted file mode 100644 index 4e8830f6c..000000000 --- a/plugins/.dir-locals.el +++ /dev/null @@ -1,4 +0,0 @@ -((coq-mode . ((eval . (let ((default-directory (locate-dominating-file - buffer-file-name ".dir-locals.el"))) - (setq-local coq-prog-args `("-coqlib" ,(expand-file-name "..") "-R" ,(expand-file-name ".") "Coq")) - (setq-local coq-prog-name (expand-file-name "../bin/coqtop"))))))) diff --git a/plugins/.merlin b/plugins/.merlin index dd6678ba0..2ba616962 100644 --- a/plugins/.merlin +++ b/plugins/.merlin @@ -1,2 +1 @@ REC -FLG -open API diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index 23b91507c..896bb91f1 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin DECLARE PLUGIN "btauto_plugin" diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 8642df684..7f8f60e46 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -187,7 +187,7 @@ let make_prb gls depth additionnal_terms = let open Tacmach.New in let env=pf_env gls in let sigma=project gls in - let state = empty depth {it = Proofview.Goal.goal (Proofview.Goal.assume gls); sigma } in + let state = empty depth {it = Proofview.Goal.goal gls; sigma } in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 6ed4672ce..0d677ac7a 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open Cctac open Stdarg diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index fb65a8639..c8c4c2dad 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -38,9 +38,8 @@ let start_deriving f suchthat lemma = let f_type = EConstr.Unsafe.to_constr f_type in let ef = EConstr.Unsafe.to_constr ef in let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in - let evdref = ref sigma in - let suchthat = Constrintern.interp_type_evars env' evdref suchthat in - TCons ( env' , !evdref , suchthat , (fun sigma _ -> + let sigma, suchthat = Constrintern.interp_type_evars env' sigma suchthat in + TCons ( env' , sigma , suchthat , (fun sigma _ -> TNil sigma)))))) in diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index df701ed80..72057cd9b 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -8,8 +8,6 @@ open Stdarg -(*i camlp4deps: "grammar/grammar.cma" i*) - DECLARE PLUGIN "derive_plugin" let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 4ae875cd7..c169b7b50 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -431,7 +431,7 @@ and extract_really_ind env kn mib = let ip = (kn, 0) in let r = IndRef ip in if is_custom r then raise (I Standard); - if mib.mind_finite == Decl_kinds.CoFinite then raise (I Coinductive); + if mib.mind_finite == CoFinite then raise (I Coinductive); if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); let p,u = packets.(0) in if p.ip_logical then raise (I Standard); diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 23452febd..4b6de58bd 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pcoq.Prim DECLARE PLUGIN "extraction_plugin" @@ -42,14 +40,20 @@ ARGUMENT EXTEND int_or_id END let pr_language = function - | Ocaml -> str "Ocaml" + | Ocaml -> str "OCaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" | JSON -> str "JSON" +let warn_deprecated_ocaml_spelling = + CWarnings.create ~name:"deprecated-ocaml-spelling" ~category:"deprecated" + (fun () -> + strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\".")) + VERNAC ARGUMENT EXTEND language PRINTED BY pr_language -| [ "Ocaml" ] -> [ Ocaml ] +| [ "Ocaml" ] -> [ let _ = warn_deprecated_ocaml_spelling () in Ocaml ] +| [ "OCaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] | [ "JSON" ] -> [ JSON ] diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 9cbc3fd71..5d0f9c167 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -100,11 +100,41 @@ let pp_global k r = str (str_global k r) let pp_modname mp = str (Common.pp_module mp) +(* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *) + +let infix_symbols = + ['=' ; '<' ; '>' ; '@' ; '^' ; ';' ; '&' ; '+' ; '-' ; '*' ; '/' ; '$' ; '%' ] +let operator_chars = + [ '!' ; '$' ; '%' ; '&' ; '*' ; '+' ; '-' ; '.' ; '/' ; ':' ; '<' ; '=' ; '>' ; '?' ; '@' ; '^' ; '|' ; '~' ] + +(* infix ops in OCaml, but disallowed by preceding grammar *) + +let builtin_infixes = + [ "::" ; "," ] + +let substring_all_opchars s start stop = + let rec check_char i = + if i >= stop then true + else + List.mem s.[i] operator_chars && check_char (i+1) + in + check_char start + let is_infix r = is_inline_custom r && (let s = find_custom r in - let l = String.length s in - l >= 2 && s.[0] == '(' && s.[l-1] == ')') + let len = String.length s in + len >= 3 && + (* parenthesized *) + (s.[0] == '(' && s.[len-1] == ')' && + let inparens = String.trim (String.sub s 1 (len - 2)) in + let inparens_len = String.length inparens in + (* either, begins with infix symbol, any remainder is all operator chars *) + (List.mem inparens.[0] infix_symbols && substring_all_opchars inparens 1 inparens_len) || + (* or, starts with #, at least one more char, all are operator chars *) + (inparens.[0] == '#' && inparens_len >= 2 && substring_all_opchars inparens 1 inparens_len) || + (* or, is an OCaml built-in infix *) + (List.mem inparens builtin_infixes))) let get_infix r = let s = find_custom r in diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index c55040df0..4c59996aa 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -55,7 +55,8 @@ let ind_hyps env sigma nevar ind largs = let types= Inductiveops.arities_of_constructors env ind in let myhyps t = let t = EConstr.of_constr t in - let t1=Termops.prod_applist sigma t largs in + let nparam_decls = Context.Rel.length (fst (Global.lookup_inductive (fst ind))).mind_params_ctxt in + let t1=Termops.prod_applist_assum sigma nparam_decls t largs in let t2=snd (decompose_prod_n_assum sigma nevar t1) in fst (decompose_prod_assum sigma t2) in Array.map myhyps types diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 938bec25b..3c6ab47e9 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) open Ltac_plugin open Formula @@ -40,17 +39,17 @@ let _= in declare_int_option gdopt -let congruence_depth=ref 100 let _= + let congruence_depth=ref 100 in let gdopt= - { optdepr=false; + { optdepr=true; (* noop *) optname="Congruence Depth"; optkey=["Congruence";"Depth"]; optread=(fun ()->Some !congruence_depth); optwrite= (function - None->congruence_depth:=0 + None->congruence_depth:=0 | Some i->congruence_depth:=(max i 0))} in declare_int_option gdopt diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index d46201335..09147d606 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -37,7 +37,7 @@ let ground_tac solver startseq = let () = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then - let gl = { Evd.it = Proofview.Goal.goal (Proofview.Goal.assume gl); sigma = project gl } in + let gl = { Evd.it = Proofview.Goal.goal gl; sigma = project gl } in Feedback.msg_debug (Printer.pr_goal gl) in tclORELSE (axiom_tac seq.gl seq) diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index 682673e8d..16dd4c886 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open FourierR diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 62ca70626..d04887a48 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -324,7 +324,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = context in let new_type_of_hyp = - Reductionops.nf_betaiota sigma new_type_of_hyp in + Reductionops.nf_betaiota env sigma new_type_of_hyp in let new_ctxt,new_end_of_type = decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in @@ -698,6 +698,7 @@ let build_proof : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> + let env = pf_env g in let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match EConstr.kind sigma dyn_infos.info with @@ -794,7 +795,7 @@ let build_proof do_finalize dyn_infos g | Lambda _ -> let new_term = - Reductionops.nf_beta sigma dyn_infos.info in + Reductionops.nf_beta env sigma dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -1153,7 +1154,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let bodies_with_all_params = Array.map (fun body -> - Reductionops.nf_betaiota (project g) + Reductionops.nf_betaiota (pf_env g) (project g) (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) @@ -1191,12 +1192,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - Reductionops.nf_betaiota (project g) ( + Reductionops.nf_betaiota (pf_env g) (project g) ( applist(body,List.rev_map var_of_decl full_params)) in match EConstr.kind (project g) body_with_full_params with | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota (project g) + Reductionops.nf_betaiota (pf_env g) (project g) ( (applist (substl @@ -1279,7 +1280,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota (project g) + Reductionops.nf_betaiota (pf_env g) (project g) (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } @@ -1339,7 +1340,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (pf_env g) Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index a3315f22c..ad396a2cb 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -29,10 +29,6 @@ val generate_functional_principle : (EConstr.constr array -> int -> Tacmach.tactic) -> unit -val compute_new_princ_type_from_rel : constr array -> Sorts.t array -> - types -> types - - exception No_graph_found val make_scheme : Evd.evar_map ref -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 829556a71..ac7a2f284 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -5,7 +5,6 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) open Ltac_plugin open Util open Pp @@ -154,7 +153,7 @@ VERNAC COMMAND EXTEND Function | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index fa4353630..693ab464d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -591,6 +591,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> user_err Pp.(str "Not handled GRec") + | GProj _ -> user_err Pp.(str "Funind does not support primitive projections") | GProd _ -> user_err Pp.(str "Cannot apply a type") end (* end of the application treatement *) @@ -697,6 +698,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,_) -> build_entry_lc env funnames avoid b + | GProj(_,_) -> user_err Pp.(str "Funind does not support primitive projections") and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : @@ -1245,7 +1247,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function discrimination ones *) | GSort _ -> params | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> + | GIf _ | GRec _ | GCast _ | GProj _ -> raise (UserError(Some "compute_cst_params", str "Not handled case")) ) gt and compute_cst_params_from_app acc (params,rtl) = @@ -1293,8 +1295,8 @@ let rec rebuild_return_type rt = CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') | Constrexpr.CLetIn(na,v,t,t') -> CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') - | _ -> CAst.make ?loc @@ Constrexpr.CProdN([[Loc.tag Anonymous], - Constrexpr.Default Decl_kinds.Explicit, rt], + | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([Loc.tag Anonymous], + Constrexpr.Default Decl_kinds.Explicit, rt)], CAst.make @@ Constrexpr.CSort(GType [])) let do_build_inductive @@ -1354,7 +1356,7 @@ let do_build_inductive acc) | None -> CAst.make @@ Constrexpr.CProdN - ([[(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + ([Constrexpr.CLocalAssum([(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], acc ) ) @@ -1421,7 +1423,7 @@ let do_build_inductive acc) | None -> CAst.make @@ Constrexpr.CProdN - ([[(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + ([Constrexpr.CLocalAssum([(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], acc ) ) @@ -1497,8 +1499,8 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) - Decl_kinds.Finite + (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + Declarations.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1509,7 +1511,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1524,7 +1526,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 0666ab4f1..41eb48657 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -17,69 +17,12 @@ let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGSort s = DAst.make @@ GSort(s) let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) -let mkGCast(b,t) = DAst.make @@ GCast(b,CastConv t) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -let glob_decompose_prod = - let rec glob_decompose_prod args c = match DAst.get c with - | GProd(n,k,t,b) -> - glob_decompose_prod ((n,t)::args) b - | _ -> args,c - in - glob_decompose_prod [] - -let glob_decompose_prod_or_letin = - let rec glob_decompose_prod args rt = match DAst.get rt with - | GProd(n,k,t,b) -> - glob_decompose_prod ((n,None,Some t)::args) b - | GLetIn(n,b,t,c) -> - glob_decompose_prod ((n,Some b,t)::args) c - | _ -> args,rt - in - glob_decompose_prod [] - -let glob_compose_prod = - List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) - -let glob_compose_prod_or_letin = - List.fold_left ( - fun concl decl -> - match decl with - | (n,None,Some t) -> mkGProd(n,t,concl) - | (n,Some bdy,t) -> mkGLetIn(n,bdy,t,concl) - | _ -> assert false) - -let glob_decompose_prod_n n = - let rec glob_decompose_prod i args c = - if i<=0 then args,c - else - match DAst.get c with - | GProd(n,_,t,b) -> - glob_decompose_prod (i-1) ((n,t)::args) b - | _ -> args,c - in - glob_decompose_prod n [] - - -let glob_decompose_prod_or_letin_n n = - let rec glob_decompose_prod i args c = - if i<=0 then args,c - else - match DAst.get c with - | GProd(n,_,t,b) -> - glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | GLetIn(n,b,t,c) -> - glob_decompose_prod (i-1) ((n,Some b,t)::args) c - | _ -> args,c - in - glob_decompose_prod n [] - - let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) @@ -101,18 +44,6 @@ let glob_make_eq ?(typ= mkGHole ()) t1 t2 = let glob_make_neq t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) -(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) -let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) - -(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec glob_make_or_list = function - | [] -> invalid_arg "mk_or" - | [e] -> e - | e::l -> glob_make_or e (glob_make_or_list l) - - let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping @@ -178,6 +109,7 @@ let change_vars = | GCast(b,c) -> GCast(change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) + | GProj(p,c) -> GProj(p, change_vars mapping c) ) rt and change_vars_br mapping ((loc,(idl,patl,res)) as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in @@ -362,6 +294,7 @@ let rec alpha_rt excluded rt = GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args ) + | GProj(p,c) -> GProj(p, alpha_rt excluded c) in new_rt @@ -413,6 +346,7 @@ let is_free_in id = | GHole _ -> false | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t | GCast (b,CastCoerce) -> is_free_in b + | GProj (_,c) -> is_free_in c ) x and is_free_in_br (_,(ids,_,rt)) = (not (Id.List.mem id ids)) && is_free_in rt @@ -506,6 +440,8 @@ let replace_var_by_term x_id term = | GCast(b,c) -> GCast(replace_var_by_pattern b, Miscops.map_cast_type replace_var_by_pattern c) + | GProj(p,c) -> + GProj(p,replace_var_by_pattern c) ) x and replace_var_by_pattern_br ((loc,(idl,patl,res)) as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl @@ -575,97 +511,6 @@ let ids_of_pat = in ids_of_pat Id.Set.empty -let id_of_name = function - | Anonymous -> Id.of_string "x" - | Name x -> x - -(* TODO: finish Rec caes *) -let ids_of_glob_constr c = - let rec ids_of_glob_constr acc c = - let idof = id_of_name in - match DAst.get c with - | GVar id -> id::acc - | GApp (g,args) -> - ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc - | GLambda (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GProd (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GLetIn (na,b,t,c) -> idof na :: ids_of_glob_constr [] b @ Option.cata (ids_of_glob_constr []) [] t @ ids_of_glob_constr [] c @ acc - | GCast (c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc - | GCast (c,CastCoerce) -> ids_of_glob_constr [] c @ acc - | GIf (c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc - | GLetTuple (nal,(na,po),b,c) -> - List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc - | GCases (sty,rtntypopt,tml,brchl) -> - List.flatten (List.map (fun (_,(idl,patl,c)) -> idl @ ids_of_glob_constr [] c) brchl) - | GRec _ -> failwith "Fix inside a constructor branch" - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] - in - (* build the set *) - List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) - - - - - -let zeta_normalize = - let rec zeta_normalize_term x = DAst.map (function - | GRef _ - | GVar _ - | GEvar _ - | GPatVar _ as rt -> rt - | GApp(rt',rtl) -> - GApp(zeta_normalize_term rt', - List.map zeta_normalize_term rtl - ) - | GLambda(name,k,t,b) -> - GLambda(name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | GProd(name,k,t,b) -> - GProd(name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | GLetIn(Name id,def,typ,b) -> - DAst.get (zeta_normalize_term (replace_var_by_term id def b)) - | GLetIn(Anonymous,def,typ,b) -> - DAst.get (zeta_normalize_term b) - | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map zeta_normalize_term rto), - zeta_normalize_term def, - zeta_normalize_term b - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, - List.map zeta_normalize_br brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(zeta_normalize_term b, - (na,Option.map zeta_normalize_term e_option), - zeta_normalize_term lhs, - zeta_normalize_term rhs - ) - | GRec _ -> raise (UserError(None,str "Not handled GRec")) - | GSort _ - | GHole _ as rt -> rt - | GCast(b,c) -> - GCast(zeta_normalize_term b, - Miscops.map_cast_type zeta_normalize_term c) - ) x - and zeta_normalize_br (loc,(idl,patl,res)) = - (loc,(idl,patl,zeta_normalize_term res)) - in - zeta_normalize_term - - - - let expand_as = let rec add_as map rt = @@ -700,6 +545,7 @@ let expand_as = | GCases(sty,po,el,brl) -> GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) + | GProj(p,c) -> GProj(p, expand_as map c) ) and expand_as_br map (loc,(idl,cpl,rt)) = (loc,(idl,cpl, expand_as (List.fold_left add_as map cpl) rt)) @@ -716,7 +562,7 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in let ctx, f = Evarutil.nf_evars_and_universes ctx in (* then we map [rt] to replace the implicit holes by their values *) diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 99a258de9..7088ae596 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,6 +1,5 @@ open Names open Glob_term -open Misctypes (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Id.t list @@ -21,22 +20,11 @@ val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) -val mkGCast : glob_constr* glob_constr -> glob_constr (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr -val glob_decompose_prod_or_letin : - glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr -val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr -val glob_decompose_prod_or_letin_n : int -> glob_constr -> - (Name.t*glob_constr option*glob_constr option) list * glob_constr -val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list -> glob_constr -val glob_compose_prod_or_letin: glob_constr -> - (Name.t*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) @@ -44,14 +32,6 @@ val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) val glob_make_neq : glob_constr -> glob_constr -> glob_constr -(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) -val glob_make_or : glob_constr -> glob_constr -> glob_constr - -(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -val glob_make_or_list : glob_constr list -> glob_constr - (* alpha_conversion functions *) @@ -109,18 +89,8 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool *) val ids_of_pat : cases_pattern -> Id.Set.t -(* TODO: finish this function (Fix not treated) *) -val ids_of_glob_constr: glob_constr -> Id.Set.t - -(* - removing let_in construction in a glob_constr -*) -val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr - - val expand_as : glob_constr -> glob_constr - (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9e22ad306..96e4a94d3 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -158,8 +158,8 @@ let build_newrecursive (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.mkCProdN bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evdref = ref (Evd.from_env env0) in - let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars env evd bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in let open Context.Named.Declaration in (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) @@ -215,6 +215,7 @@ let is_rec names = | GCases(_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl + | GProj(_,c) -> lookup names c and lookup_br names (_,(idl,_,rt)) = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt @@ -282,7 +283,6 @@ let derive_inversion fix_names = in Invfun.derive_correctness Functional_principles_types.make_scheme - functional_induction fix_names_as_constant lind; with e when CErrors.noncritical e -> @@ -406,7 +406,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - Command.do_definition + ComDefinition.do_definition + ~program_mode:false fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); @@ -426,7 +427,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in evd,List.rev rev_pconstants | _ -> - Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> @@ -590,11 +591,11 @@ and rebuild_nal aux bk bl' nal typ = match nal,typ with | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN((na'::nal',bk',nal't)::rest,typ') } -> + | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> if Name.equal (snd na) (snd na') || Name.is_anonymous (snd na') then let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else ((nal',bk',nal't)::rest) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in rebuild_nal (assum::aux) bk @@ -603,7 +604,7 @@ and rebuild_nal aux bk bl' nal typ = (CAst.make @@ CProdN(new_rest,typ')) else let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else ((nal',bk',nal't)::rest) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in rebuild_nal (assum::aux) bk @@ -616,8 +617,8 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in + let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = @@ -730,10 +731,14 @@ let rec add_args id new_args = CAst.map (function end | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") | CProdN(nal,b1) -> - CProdN(List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, add_args id new_args b1) | CLambdaN(nal,b1) -> - CLambdaN(List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, add_args id new_args b1) | CLetIn(na,b1,t,b2) -> CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) @@ -779,6 +784,7 @@ let rec add_args id new_args = CAst.map (function | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.") | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") + | CProj _ -> user_err Pp.(str "Funind does not support primitive projections") ) exception Stop of Constrexpr.constr_expr @@ -791,7 +797,7 @@ let rec chop_n_arrow n t = then t (* If we have already removed all the arrows then return the type *) else (* If not we check the form of [t] *) match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, to result are possible : + | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on the remaining number of arrow to chop and [t'] we discard it and @@ -803,7 +809,7 @@ let rec chop_n_arrow n t = let new_n = let rec aux (n:int) = function [] -> n - | (nal,k,t'')::nal_ta' -> + | CLocalAssum(nal,k,t'')::nal_ta' -> let nal_l = List.length nal in if n >= nal_l then @@ -811,9 +817,10 @@ let rec chop_n_arrow n t = else let new_t' = CAst.make @@ Constrexpr.CProdN( - ((snd (List.chop n nal)),k,t'')::nal_ta',t') + CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') + | _ -> anomaly (Pp.str "Not enough products.") in aux n nal_ta' in @@ -826,16 +833,13 @@ let rec chop_n_arrow n t = let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = match b.CAst.v with - | Constrexpr.CLambdaN ((nal_ta), b') -> + | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> begin - let n = - (List.fold_left (fun n (nal,_,_) -> - n+List.length nal) 0 nal_ta ) - in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,k,ta) -> - (Constrexpr.CLocalAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + let n = List.length nal in + let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in + d :: nal_tas, b'',t'' end + | Constrexpr.CLambdaN ([], b) -> [],b,t | _ -> [],b,t diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 8bf6e48fd..d6fd2f2a0 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -183,12 +183,13 @@ let with_full_print f a = and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in + let old_printallowmatchdefaultclause = !Detyping.print_allow_match_default_clause in Constrextern.print_universes := true; + Detyping.print_allow_match_default_clause := false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; - Impargs.make_contextual_implicit_args false; Dumpglob.pause (); try let res = f a in @@ -197,6 +198,7 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; + Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; Dumpglob.continue (); res with @@ -206,6 +208,7 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; + Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; Dumpglob.continue (); raise reraise diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 694c80051..4acf82d00 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -56,12 +56,6 @@ let do_observe_tac s tac g = CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; - -let observe_tac_strm s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - let observe_tac s tac g = if do_observe () then do_observe_tac (str s) tac g @@ -87,10 +81,6 @@ let make_eq () = try EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false -let make_eq_refl () = - try - EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) - with _ -> assert false (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] @@ -194,10 +184,9 @@ let rec generate_fresh_id x avoid i = id::(generate_fresh_id x (id::avoid) (pred i)) -(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] +(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. - [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. graphs of the functions and principles and correctness lemma types) to prove correct. @@ -218,7 +207,7 @@ let rec generate_fresh_id x avoid i = \end{enumerate} *) -let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: @@ -752,14 +741,13 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti g -(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness +(* [derive_correctness make_scheme funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and - [functional_induction] is Indfun.functional_induction (same pb) *) -let derive_correctness make_scheme functional_induction (funs: pconstant list) (graphs:inductive list) = +let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list) = assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in @@ -809,7 +797,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( ) in let proving_tac = - prove_fun_correct !evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos + prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli new file mode 100644 index 000000000..e07138596 --- /dev/null +++ b/plugins/funind/invfun.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val invfun : + Misctypes.quantified_hypothesis -> + Globnames.global_reference option -> + Evar.t Evd.sigma -> Evar.t list Evd.sigma +val derive_correctness : + (Evd.evar_map ref -> + (Constr.pconstant * Sorts.family) list -> + 'a Entries.definition_entry list) -> + Constr.pconstant list -> Names.inductive list -> unit diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml deleted file mode 100644 index 9e2774ff3..000000000 --- a/plugins/funind/merge.ml +++ /dev/null @@ -1,1013 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Merging of induction principles. *) - -open Globnames -open Tactics -open Indfun_common -open CErrors -open Util -open Constrexpr -open Vernacexpr -open Pp -open Names -open Term -open Constr -open Vars -open Declarations -open Glob_term -open Glob_termops -open Decl_kinds -open Context.Rel.Declaration - -module RelDecl = Context.Rel.Declaration - -(** {1 Utilities} *) - -(** {2 Useful operations on constr and glob_constr} *) - -let pop c = Vars.lift (-1) c -let rec popn i c = if i<=0 then c else pop (popn (i-1) c) - -(** Substitutions in constr *) -let compare_constr_nosub t1 t2 = - if Constr.compare_head (fun _ _ -> false) t1 t2 - then true - else false - -let rec compare_constr' t1 t2 = - if compare_constr_nosub t1 t2 - then true - else (Constr.compare_head (compare_constr') t1 t2) - -let rec substitterm prof t by_t in_u = - if (compare_constr' (lift prof t) in_u) - then (lift prof by_t) - else Constr.map_with_binders succ - (fun i -> substitterm i t by_t) prof in_u - -let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl - -let understand = Pretyping.understand (Global.env()) Evd.empty - -(** Operations on names and identifiers *) -let id_of_name = function - Anonymous -> Id.of_string "H" - | Name id -> id;; -let name_of_string = Id.of_string %> Name.mk_name -let string_of_name = id_of_name %> Id.to_string - -(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) -let isVarf f x = - match DAst.get x with - | GVar x -> Id.equal x f - | _ -> false - -(** [ident_global_exist id] returns true if identifier [id] is linked - in global environment. *) -let ident_global_exist id = - try - let ans = CAst.make @@ CRef (Libnames.Ident (Loc.tag id), None) in - let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in - true - with e when CErrors.noncritical e -> false - -(** [next_ident_fresh id] returns a fresh identifier (ie not linked in - global env) with base [id]. *) -let next_ident_fresh (id:Id.t) = - let res = ref id in - while ident_global_exist !res do res := Nameops.increment_subscript !res done; - !res - - -(** {2 Debugging} *) -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" -(* uncomment this to see debugging *) -let prconstr c = - let sigma, env = Pfedit.get_current_context () in - msg (str" " ++ Printer.pr_lconstr_env env sigma c) - -let prconstrnl c = - let sigma, env = Pfedit.get_current_context () in - msg (str" " ++ Printer.pr_lconstr_env env sigma c ++ str"\n") - -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - let sigma, env = Pfedit.get_current_context () in - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_lconstr_env env sigma c ++ str " §} "); - msg(str ""); - end -let prNamedRConstr s c = - let sigma, env = Pfedit.get_current_context () in - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_glob_constr_env env c ++ str " §} "); - msg(str ""); - end -let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc -let prNamedLConstr s lc = - begin - prstr "[§§§ "; - prstr s; - prNamedLConstr_aux lc; - prstr " §§§]\n"; - end -let prNamedLDecl s lc = - begin - prstr s; prstr "\n"; - List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; - prstr "\n"; - end -let prNamedRLDecl s lc = - begin - prstr s; prstr "\n"; prstr "{§§ "; - List.iter - (fun x -> - match x with - | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp - | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy - | _ -> assert false - ) lc; - prstr " §§}\n"; - prstr "\n"; - end - -(** {2 Misc} *) - -exception Found of int - -(* Array scanning *) - -let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = -match Array.findi pred arr with -| None -> Array.length arr (* all elt are positive *) -| Some i -> i - -(* Like List.chop but except that [i] is the size of the suffix of [l]. *) -let list_chop_end i l = - let size_prefix = List.length l -i in - if size_prefix < 0 then failwith "list_chop_end" - else List.chop size_prefix l - -let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = - let i = ref 0 in - List.fold_left - (fun acc x -> - let res = f !i acc x in i := !i + 1; res) - acc arr - -let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = - let i = ref 0 in - List.filter (fun x -> let res = f !i x in i := !i + 1; res) l - - -(** Iteration module *) -module For = -struct - let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) - let rec foldup i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc - let rec folddown i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc - let fold i j = if i<j then foldup i j else folddown i j -end - - -(** {1 Parameters shifting and linking information} *) - -(** This type is used to deal with debruijn linked indices. When a - variable is linked to a previous one, we will ignore it and refer - to previous one. *) -type linked_var = - | Linked of int - | Unlinked - | Funres - -(** When merging two graphs, parameters may become regular arguments, - and thus be shifted. This type describes the result of computing - the changes. *) -type 'a shifted_params = - { - nprm1:'a; - nprm2:'a; - prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *) - nuprm1:'a; - nuprm2:'a; - nargs1:'a; - nargs2:'a; - } - - -let prlinked x = - match x with - | Linked i -> Printf.sprintf "Linked %d" i - | Unlinked -> Printf.sprintf "Unlinked" - | Funres -> Printf.sprintf "Funres" - -let linkmonad f lnkvar = - match lnkvar with - | Linked i -> Linked (f i) - | Unlinked -> Unlinked - | Funres -> Funres - -let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar - -(* This map is used to deal with debruijn linked indices. *) -module Link = Map.Make (Int) - -let pr_links l = - Printf.printf "links:\n"; - Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; - Printf.printf "_____________\n" - -type 'a merged_arg = - | Prm_stable of 'a - | Prm_linked of 'a - | Prm_arg of 'a - | Arg_stable of 'a - | Arg_linked of 'a - | Arg_funres - -(** Information about graph merging of two inductives. - All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) - -type merge_infos = - { - ident:Id.t; (** new inductive name *) - mib1: mutual_inductive_body; - oib1: one_inductive_body; - mib2: mutual_inductive_body; - oib2: one_inductive_body; - - (** Array of links of the first inductive (should be all stable) *) - lnk1: int merged_arg array; - - (** Array of links of the second inductive (point to the first ind param/args) *) - lnk2: int merged_arg array; - - (** rec params which remain rec param (ie not linked) *) - recprms1: Context.Rel.Declaration.t list; - recprms2: Context.Rel.Declaration.t list; - nrecprms1: int; - nrecprms2: int; - - (** rec parms which became non parm (either linked to something - or because after a rec parm that became non parm) *) - otherprms1: Context.Rel.Declaration.t list; - otherprms2: Context.Rel.Declaration.t list; - notherprms1:int; - notherprms2:int; - - (** args which remain args in merge *) - args1:Context.Rel.Declaration.t list; - args2:Context.Rel.Declaration.t list; - nargs1:int; - nargs2:int; - - (** functional result args *) - funresprms1: Context.Rel.Declaration.t list; - funresprms2: Context.Rel.Declaration.t list; - nfunresprms1:int; - nfunresprms2:int; - } - - -let pr_merginfo x = - let i,s= - match x with - | Prm_linked i -> Some i,"Prm_linked" - | Arg_linked i -> Some i,"Arg_linked" - | Prm_stable i -> Some i,"Prm_stable" - | Prm_arg i -> Some i,"Prm_arg" - | Arg_stable i -> Some i,"Arg_stable" - | Arg_funres -> None , "Arg_funres" in - match i with - | Some i -> Printf.sprintf "%s(%d)" s i - | None -> Printf.sprintf "%s" s - -let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false - -(* ?? prm_linked?? *) -let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false - -let is_stable x = - match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false - -let isArg_funres x = match x with Arg_funres -> true | _ -> false - -let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = - let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in - let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in - let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in - prms@args@fres - -(** Reverse the link map, keeping only linked vars, elements are list - of int as several vars may be linked to the same var. *) -let revlinked lnk = - For.fold 0 (Array.length lnk - 1) - (fun acc k -> - match lnk.(k) with - | Unlinked | Funres -> acc - | Linked i -> - let old = try Link.find i acc with Not_found -> [] in - Link.add i (k::old) acc) - Link.empty - -let array_switch arr i j = - let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux - -let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = - let larr = Array.of_list l in - let _ = - Array.iteri - (fun j x -> - match x with - | Prm_linked i -> array_switch larr i j - | Arg_linked i -> array_switch larr i j - | Prm_stable i -> () - | Prm_arg i -> () - | Arg_stable i -> () - | Arg_funres -> () - ) lnk in - filter_shift_stable lnk (Array.to_list larr) - - -let error msg = user_err Pp.(str msg) - -(** {1 Utilities for merging} *) - -let ind1name = Id.of_string "__ind1" -let ind2name = Id.of_string "__ind2" - -(** Performs verifications on two graphs before merging: they must not - be co-inductive, and for the moment they must not be mutual - either. *) -let verify_inds mib1 mib2 = - if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive"; - if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive"; - if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual"; - if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual"; - () - -(* -(** [build_raw_params prms_decl avoid] returns a list of variables - attributed to the list of decl [prms_decl], avoiding names in - [avoid]. *) -let build_raw_params prms_decl avoid = - let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in - let _ = prNamedConstr "DUMMY" dummy_constr in - let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in - let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in - let res,_ = glob_decompose_prod dummy_glob_constr in - let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) -*) - -let ids_of_rawlist avoid rawl = - List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) - - - -(** {1 Merging function graphs} *) - -(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec - uniform and ordinary ones) of mutual inductives [mib1] and [mib2] - remain uniform when linked by [lnk]. All parameters are - considered, ie we take parameters of the first inductive body of - [mib1] and [mib2]. - - Explanation: The two inductives have parameters, some of the first - are recursively uniform, some of the last are functional result of - the functional graph. - - (I x1 x2 ... xk ... xk' ... xn) - (J y1 y2 ... xl ... yl' ... ym) - - Problem is, if some rec unif params are linked to non rec unif - ones, they become non rec (and the following too). And functinal - argument have to be shifted at the end *) -let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = - let _ = prstr "\nYOUHOU shift\n" in - let linked_targets = revlinked lnk2 in - let is_param_of_mib1 x = x < mib1.mind_nparams_rec in - let is_param_of_mib2 x = x < mib2.mind_nparams_rec in - let is_targetted_by_non_recparam_lnk1 i = - try - let targets = Link.find i linked_targets in - List.exists (fun x -> not (is_param_of_mib2 x)) targets - with Not_found -> false in - let mlnk1 = - Array.mapi - (fun i lkv -> - let isprm = is_param_of_mib1 i in - let prmlost = is_targetted_by_non_recparam_lnk1 i in - match isprm , prmlost, lnk1.(i) with - | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) - | true , false , _-> Prm_stable i (* recparam remains recparam*) - | false , false , Funres -> Arg_funres - | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) - | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) - lnk1 in - let mlnk2 = - Array.mapi - (fun i lkv -> - (* Is this correct if some param of ind2 is lost? *) - let isprm = is_param_of_mib2 i in - match isprm , lnk2.(i) with - | true , Linked j when not (is_param_of_mib1 j) -> - Prm_arg j (* recparam becoming ordinary *) - | true , Linked j -> Prm_linked j (*recparam linked to recparam*) - | true , Unlinked -> Prm_stable i (* recparam remains recparam*) - | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) - | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) - | false , Funres -> Arg_funres - | true , Funres -> assert false (* fun res cannot be a rec param *) - ) - lnk2 in - let oib1 = mib1.mind_packets.(0) in - let oib2 = mib2.mind_packets.(0) in - (* count params remaining params *) - let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in - let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in - let bldprms arity_ctxt mlnk = - list_fold_lefti - (fun i (acc1,acc2,acc3,acc4) x -> - prstr (pr_merginfo mlnk.(i));prstr "\n"; - match mlnk.(i) with - | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 - | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 - | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 - | Arg_funres -> acc1 , acc2 , acc3, x::acc4 - | _ -> acc1 , acc2 , acc3, acc4) - ([],[],[],[]) arity_ctxt in -(* let arity_ctxt2 = - build_raw_params oib2.mind_arity_ctxt - (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) - let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in - let _ = prstr "\n\n\n" in - let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in - let _ = prstr "\notherprms1:\n" in - let _ = - List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); - prconstr (RelDecl.get_type decl); prstr "\n") - otherprms1 in - let _ = prstr "\notherprms2:\n" in - let _ = - List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); prconstr (RelDecl.get_type decl); prstr "\n") - otherprms2 in - { - ident=id; - mib1=mib1; - oib1 = oib1; - mib2=mib2; - oib2 = oib2; - lnk1 = mlnk1; - lnk2 = mlnk2; - nrecprms1 = n_params1; - recprms1 = recprms1; - otherprms1 = otherprms1; - args1 = args1; - funresprms1 = funresprms1; - notherprms1 = Array.length mlnk1 - n_params1; - nfunresprms1 = List.length funresprms1; - nargs1 = List.length args1; - nrecprms2 = n_params2; - recprms2 = recprms2; - otherprms2 = otherprms2; - args2 = args2; - funresprms2 = funresprms2; - notherprms2 = Array.length mlnk2 - n_params2; - nargs2 = List.length args2; - nfunresprms2 = List.length funresprms2; - } - - - - -(** {1 Merging functions} *) - -exception NoMerge - -let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match DAst.get c1, DAst.get c2 with - | GApp(f1, arr1), GApp(f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> - let _ = prstr "\nICI1!\n" in - let args = filter_shift_stable lnk (arr1 @ arr2) in - DAst.make @@ GApp ((DAst.make @@ GVar shift.ident) , args) - | GApp(f1, arr1), GApp(f2,arr2) -> raise NoMerge - | GLetIn(nme,bdy,typ,trm) , _ -> - let _ = prstr "\nICI2!\n" in - let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - DAst.make @@ GLetIn(nme,bdy,typ,newtrm) - | _, GLetIn(nme,bdy,typ,trm) -> - let _ = prstr "\nICI3!\n" in - let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - DAst.make @@ GLetIn(nme,bdy,typ,newtrm) - | _ -> let _ = prstr "\nICI4!\n" in - raise NoMerge - -let rec merge_app_unsafe c1 c2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match DAst.get c1, DAst.get c2 with - | GApp(f1, arr1), GApp(f2,arr2) -> - let args = filter_shift_stable lnk (arr1 @ arr2) in - DAst.make @@ GApp (DAst.make @@ GVar shift.ident, args) - (* FIXME: what if the function appears in the body of the let? *) - | GLetIn(nme,bdy,typ,trm) , _ -> - let _ = prstr "\nICI2 '!\n" in - let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - DAst.make @@ GLetIn(nme,bdy,typ,newtrm) - | _, GLetIn(nme,bdy,typ,trm) -> - let _ = prstr "\nICI3 '!\n" in - let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - DAst.make @@ GLetIn(nme,bdy,typ,newtrm) - | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge - - - -(* Heuristic when merging two lists of hypothesis: merge every rec - calls of branch 1 with all rec calls of branch 2. *) -(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let rec merge_rec_hyps shift accrec - (ltyp:(Name.t * glob_constr option * glob_constr option) list) - filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = - let is_app c = match DAst.get c with GApp _ -> true | _ -> false in - let mergeonehyp t reldecl = - match reldecl with - | (nme,x,Some ind) when is_app ind - -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) - | (nme,Some _,None) -> error "letins with recursive calls not treated yet" - | (nme,None,Some _) -> assert false - | (nme,None,None) | (nme,Some _,Some _) -> assert false in - let is_app c = match DAst.get c with GApp (f, _) -> isVarf ind2name f | _ -> false in - match ltyp with - | [] -> [] - | (nme,None,Some t) :: lt when is_app t -> - let rechyps = List.map (mergeonehyp t) accrec in - rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable - | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable - - -let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = - List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec - - -let find_app (nme:Id.t) ltyp = - let is_app c = match DAst.get c with GApp (f, _) -> isVarf nme f | _ -> false in - try - ignore - (List.map - (fun x -> - match x with - | _,None,Some c when is_app c -> raise (Found 0) - | _ -> ()) - ltyp); - false - with Found _ -> true - -let prnt_prod_or_letin nm letbdy typ = - match letbdy , typ with - | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy - | None , Some tp -> prNamedRConstr (string_of_name nm) tp - | _ , _ -> assert false - - -let rec merge_types shift accrec1 - (ltyp1:(Name.t * glob_constr option * glob_constr option) list) - (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2 - : (Name.t * glob_constr option * glob_constr option) list * glob_constr = - let _ = prstr "MERGE_TYPES\n" in - let _ = prstr "ltyp 1 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in - let _ = prstr "\nltyp 2 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in - let _ = prstr "\n" in - let res = - match ltyp1 with - | [] -> - let isrec1 = not (List.is_empty accrec1) in - let isrec2 = find_app ind2name ltyp2 in - let rechyps = - if isrec1 && isrec2 - then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) - merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] - filter_shift_stable - else if isrec1 - (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then - merge_rec_hyps shift accrec1 - (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable - else if isrec2 - then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - else ltyp2 in - let _ = prstr"\nrechyps : " in - let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in - let _ = prstr "MERGE CONCL : " in - let _ = prNamedRConstr "concl1" concl1 in - let _ = prstr " with " in - let _ = prNamedRConstr "concl2" concl2 in - let _ = prstr "\n" in - let concl = - merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in - let _ = prstr "FIN " in - let _ = prNamedRConstr "concl" concl in - let _ = prstr "\n" in - - rechyps , concl - | (nme,None, Some t1)as e ::lt1 -> - (match DAst.get t1 with - | GApp(f,carr) when isVarf ind1name f -> - merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 - | _ -> - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,None,Some t1) :: recres) , recconcl2) - | (nme,Some bd, None) ::lt1 -> - (* FIXME: what if ind1name appears in bd? *) - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,Some bd,None) :: recres) , recconcl2 - | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false - in - res - - -(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of - linked args [allargs2] to target args of [allargs1] as specified - in [shift]. [allargs1] and [allargs2] are in reverse order. Also - returns the list of unlinked vars of [allargs2]. *) -let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) - (lnk:int merged_arg array) = - Array.fold_left_i - (fun i acc e -> - if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *) - else - match e with - | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc - | _ -> acc) - Id.Map.empty lnk - -let build_link_map allargs1 allargs2 lnk = - let allargs1 = - Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in - let allargs2 = - Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in - build_link_map_aux allargs1 allargs2 lnk - - -(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two - constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and - [typcstr2] contain all parameters (including rec. unif. ones) of - their inductive. - - if [typcstr1] and [typcstr2] are of the form: - - forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) - forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) - - we build: - - forall recparams1 (recparams2 without linked params), - forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... - -> (newI x1 ... z1 x2 y2 ...z2 without linked params) - - where Hix' have been adapted, ie: - - linked vars have been changed, - - rec calls to I1 and I2 have been replaced by rec calls to - newI. More precisely calls to I1 and I2 have been merge by an - experimental heuristic (in particular if n o rec calls for I1 - or I2 is found, we use the conclusion as a rec call). See - [merge_types] above. - - Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. - - TODO: return nothing if equalities (after linking) are contradictory. *) -let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr) - (typcstr2:glob_constr) : glob_constr = - (* FIXME: les noms des parametres corerspondent en principe au - parametres du niveau mib, mais il faudrait s'en assurer *) - (* shift.nfunresprmsx last args are functional result *) - let nargs1 = - shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in - let nargs2 = - shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in - let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in - (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) - let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in - let rest2 = change_vars linked_map rest2 in - let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in - let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in - let ltyp,concl2 = - merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in - let _ = prNamedRLDecl "ltyp result:" ltyp in - let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in - let revargs1 = - list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in - let _ = prNamedRLDecl "ltyp allargs1" allargs1 in - let _ = prNamedRLDecl "ltyp revargs1" revargs1 in - let revargs2 = - list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in - let _ = prNamedRLDecl "ltyp allargs2" allargs2 in - let _ = prNamedRLDecl "ltyp revargs2" revargs2 in - let typwithprms = - glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in - typwithprms - - -(** constructor numbering *) -let fresh_cstror_suffix , cstror_suffix_init = - let cstror_num = ref 0 in - (fun () -> - let res = string_of_int !cstror_num in - cstror_num := !cstror_num + 1; - res) , - (fun () -> cstror_num := 0) - -(** [merge_constructor_id id1 id2 shift] returns the identifier of the - new constructor from the id of the two merged constructor and - the merging info. *) -let merge_constructor_id id1 id2 shift:Id.t = - let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in - next_ident_fresh (Id.of_string id) - - - -(** [merge_constructors lnk shift avoid] merges the two list of - constructor [(name*type)]. These are translated to glob_constr - first, each of them having distinct var names. *) -let merge_constructors (shift:merge_infos) (avoid:Id.Set.t) - (typcstr1:(Id.t * glob_constr) list) - (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list = - List.flatten - (List.map - (fun (id1,rawtyp1) -> - List.map - (fun (id2,rawtyp2) -> - let typ = merge_one_constructor shift rawtyp1 rawtyp2 in - let newcstror_id = merge_constructor_id id1 id2 shift in - let _ = prstr "\n**************\n" in - newcstror_id , typ) - typcstr2) - typcstr1) - -(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two - inductive bodies [oib1] and [oib2], linking with [lnk], params - info in [shift], avoiding identifiers in [avoid]. *) -let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) - (oib2:one_inductive_body) = - (* building glob_constr type of constructors *) - let mkrawcor nme avoid typ = - (* first replace rel 1 by a varname *) - let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in - let substindtyp = EConstr.of_constr substindtyp in - Detyping.detype Detyping.Now false avoid (Global.env()) Evd.empty substindtyp in - let lcstr1: glob_constr list = - Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in - (* add to avoid all indentifiers of lcstr1 *) - let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in - let lcstr2 = - Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in - let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in - - let params1 = - try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with e when CErrors.noncritical e -> [] in - let params2 = - try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with e when CErrors.noncritical e -> [] in - - let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in - let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in - - cstror_suffix_init(); - params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 - - -(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual - inductive bodies [mib1] and [mib2] linking vars with - [lnk]. [shift] information on parameters of the new inductive. - For the moment, inductives are supposed to be non mutual. -*) -let merge_mutual_inductive_body - (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = - (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0) - - -let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) - Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x - -let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = - let params = prms2 @ prms1 in - let resparams = - List.fold_left - (fun acc (nme,tp) -> - let _ = prstr "param :" in - let _ = prNamedRConstr (string_of_name nme) tp in - let _ = prstr " ; " in - let typ = glob_constr_to_constr_expr tp in - CLocalAssum ([(Loc.tag nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) - [] params in - let concl = Constrextern.extern_constr false (Global.env()) Evd.empty (EConstr.of_constr concl) in - let arity,_ = - List.fold_left - (fun (acc,env) decl -> - let nm = Context.Rel.Declaration.get_name decl in - let c = RelDecl.get_type decl in - let typ = Constrextern.extern_constr false env Evd.empty (EConstr.of_constr c) in - let newenv = Environ.push_rel (LocalAssum (nm,c)) env in - CAst.make @@ CProdN ([[(Loc.tag nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) - (concl,Global.env()) - (shift.funresprms2 @ shift.funresprms1 - @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in - resparams,arity - - - -(** [glob_constr_list_to_inductive_expr ident rawlist] returns the - induct_expr corresponding to the the list of constructor types - [rawlist], named ident. - FIXME: params et cstr_expr (arity) *) -let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(Id.t * glob_constr) list) = - let lident = (Loc.tag shift.ident), None in - let bindlist , cstr_expr = (* params , arities *) - merge_rec_params_and_arity prms1 prms2 shift mkSet in - let lcstor_expr : (bool * (lident * constr_expr)) list = - List.map (* zeta_normalize t ? *) - (fun (id,t) -> false, ((Loc.tag id),glob_constr_to_constr_expr t)) - rawlist in - lident , bindlist , Some cstr_expr , lcstor_expr - - -let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = - match rdecl with - | LocalAssum (nme,t) -> - let t = EConstr.of_constr t in - let traw = Detyping.detype Detyping.Now false Id.Set.empty (Global.env()) Evd.empty t in - DAst.make @@ GProd (nme,Explicit,traw,t2) - | LocalDef _ -> assert false - - -(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking - variables specified in [lnk]. Graphs are not supposed to be mutual - inductives for the moment. *) -let merge_inductive (ind1: inductive) (ind2: inductive) - (lnk1: linked_var array) (lnk2: linked_var array) id = - let env = Global.env() in - let mib1,_ = Inductive.lookup_mind_specif env ind1 in - let mib2,_ = Inductive.lookup_mind_specif env ind2 in - let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) - (* compute params that become ordinary args (because linked to ord. args) *) - let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in - let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in - let _ = prstr "\nrawlist : " in - let _ = - List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in - let _ = prstr "\nend rawlist\n" in -(* FIX: retransformer en constr ici - let shift_prm = - { shift_prm with - recprms1=prms1; - recprms1=prms1; - } in *) - let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in - (* Declare inductive *) - let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,pl,impls = Command.interp_mutual_inductive indl [] - false (* non-cumulative *) false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in - (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) - - -(* Find infos on identifier id. *) -let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = - let kn_of_id x = - let f_ref = Libnames.Ident (Loc.tag x) in - locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) - locate_constant f_ref in - try find_Function_infos (kn_of_id id) - with Not_found -> - user_err ~hdr:"indfun" (Id.print id ++ str " has no functional scheme") - -(** [merge id1 id2 args1 args2 id] builds and declares a new inductive - type called [id], representing the merged graphs of both graphs - [ind1] and [ind2]. identifiers occurring in both arrays [args1] and - [args2] are considered linked (i.e. are the same variable) in the - new graph. - - Warning: For the moment, repetitions of an id in [args1] or - [args2] are not supported. *) -let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array) - (args2:Id.t array) id : unit = - let finfo1 = find_Function_infos_safe id1 in - let finfo2 = find_Function_infos_safe id2 in - (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) - (* We add one arg (functional arg of the graph) *) - let lnk1 = Array.make (Array.length args1 + 1) Unlinked in - let lnk2' = (* args2 may be linked to args1 members. FIXME: same - as above: vars may be linked inside args2?? *) - Array.mapi - (fun i c -> - match Array.findi (fun i x -> Id.equal x c) args1 with - | Some j -> Linked j - | None -> Unlinked) - args2 in - (* We add one arg (functional arg of the graph) *) - let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in - (* setting functional results *) - let _ = lnk1.(Array.length lnk1 - 1) <- Funres in - let _ = lnk2.(Array.length lnk2 - 1) <- Funres in - merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id - - -let remove_last_arg c = - let (x,y) = decompose_prod c in - let xnolast = List.rev (List.tl (List.rev x)) in - compose_prod xnolast y - -let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l) -let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) - -let remove_last_n_arg n c = - let (x,y) = decompose_prod c in - let xnolast = remove_n_last_list n x in - compose_prod xnolast y - -(* [funify_branches relinfo nfuns branch] returns the branch [branch] - of the relinfo [relinfo] modified to fit in a functional principle. - Things to do: - - remove indargs from rel applications - - replace *variables only* corresponding to function (recursive) - results by the actual function application. *) -let funify_branches relinfo nfuns branch = - let mut_induct, induct = - match relinfo.indref with - | None -> assert false - | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind - | _ -> assert false in - let is_dom c = - match Constr.kind c with - | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct - | _ -> false in - let _dom_i c = - assert (is_dom c); - match Constr.kind c with - | Ind((u,i)) | Construct((u,_),i) -> i - | _ -> assert false in - let _is_pred c shift = - match Constr.kind c with - | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) - | _ -> false in - (* FIXME: *) - LocalDef (Anonymous,EConstr.mkProp,EConstr.mkProp) - - -let relprinctype_to_funprinctype relprinctype nfuns = - let relprinctype = EConstr.of_constr relprinctype in - let relinfo = compute_elim_sig Evd.empty (** FIXME*) relprinctype in - assert (not relinfo.farg_in_concl); - assert (relinfo.indarg_in_concl); - (* first remove indarg and indarg_in_concl *) - let relinfo_noindarg = { relinfo with - indarg_in_concl = false; indarg = None; - concl = EConstr.of_constr (remove_last_arg (pop (EConstr.Unsafe.to_constr relinfo.concl))); } in - (* the nfuns last induction arguments are functional ones: remove them *) - let relinfo_argsok = { relinfo_noindarg with - nargs = relinfo_noindarg.nargs - nfuns; - (* args is in reverse order, so remove fst *) - args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = EConstr.of_constr (popn nfuns (EConstr.Unsafe.to_constr relinfo_noindarg.concl)); - } in - let new_branches = - List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in - let relinfo_branches = { relinfo_argsok with branches = new_branches } in - relinfo_branches - -(* @article{ bundy93rippling, - author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", - title = "Rippling: A Heuristic for Guiding Inductive Proofs", - journal = "Artificial Intelligence", - volume = "62", - number = "2", - pages = "185-253", - year = "1993", - url = "citeseer.ist.psu.edu/bundy93rippling.html" } - - *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b0a76137b..8fe05b497 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -141,7 +141,7 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") -let le = function () -> (coq_init_constant "le") +let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") let iter_ref () = @@ -857,9 +857,13 @@ let rec prove_le g = Proofview.V82.of_tactic (apply (delayed_force le_n)); begin try - let matching_fun = - pf_is_matching g - (Pattern.PApp(Pattern.PRef (Globnames.global_of_constr (EConstr.Unsafe.to_constr (le ()))),[|Pattern.PVar (destVar sigma x);Pattern.PMeta None|])) in + let matching_fun c = match EConstr.kind sigma c with + | App (c, [| x0 ; _ |]) -> + EConstr.isVar sigma x0 && + Id.equal (destVar sigma x0) (destVar sigma x) && + EConstr.is_global sigma (le ()) c + | _ -> false + in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let y = @@ -1423,7 +1427,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evmap, env = Pfedit.get_current_context () in + let evd, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; @@ -1475,13 +1479,13 @@ let (com_eqn : int -> Id.t -> | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evmap, env = Pfedit.get_current_context () in - let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in + let evd, env = Pfedit.get_current_context () in + let evd = Evd.from_ctx (Evd.evar_universe_context evd) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) - evmap + evd (EConstr.of_constr equation_lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (by @@ -1524,14 +1528,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let open Constr in let open CVars in let env = Global.env() in - let evd = ref (Evd.from_env env) in - let function_type = interp_type_evars env evd type_of_f in + let evd = Evd.from_env env in + let evd, function_type = interp_type_evars env evd type_of_f in let function_type = EConstr.Unsafe.to_constr function_type in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let ty = interp_type_evars env evd ~impls:rec_impls eq in + let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in let ty = EConstr.Unsafe.to_constr ty in - let evm, nf = Evarutil.nf_evars_and_universes !evd in + let evd, nf = Evarutil.nf_evars_and_universes evd in let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in @@ -1556,16 +1560,16 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = - let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evm) in + let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evd) in declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res in (* Refresh the global universes, now including those of _F *) - let evm = Evd.from_env (Global.env ()) in + let evd = Evd.from_env (Global.env ()) in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in let relation, evuctx = - interp_constr env_with_pre_rec_args evm r + interp_constr env_with_pre_rec_args evd r in - let evm = Evd.from_ctx evuctx in + let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) @@ -1595,7 +1599,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evm (EConstr.of_constr res)) (EConstr.of_constr relation); + functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evd (EConstr.of_constr res)) (EConstr.of_constr relation); Flags.if_verbose msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ @@ -1614,5 +1618,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - evm (Lemmas.mk_hook hook)) + evd (Lemmas.mk_hook hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 50b84731b..b95d64ce9 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,6 +1,5 @@ open Constr -(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) val tclUSER_if_not_mes : Tacmach.tactic -> bool -> diff --git a/plugins/funind/recdef_plugin.mlpack b/plugins/funind/recdef_plugin.mlpack index 2b443f2a1..755fa4f87 100644 --- a/plugins/funind/recdef_plugin.mlpack +++ b/plugins/funind/recdef_plugin.mlpack @@ -6,5 +6,4 @@ Functional_principles_proofs Functional_principles_types Invfun Indfun -Merge G_indfun diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 2769802cf..7d2c4d082 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Util open Locus open Misctypes diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index bb01aca55..4c6d3c2d3 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Genarg open Stdarg diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 982fc7cc3..286f9d95d 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Genarg open Stdarg @@ -25,6 +23,7 @@ open Termops open Equality open Misctypes open Proofview.Notations +open Vernacinterp DECLARE PLUGIN "ltac_plugin" @@ -249,11 +248,10 @@ TACTIC EXTEND rewrite_star (**********************************************************************) (* Hint Rewrite *) -let add_rewrite_hint bases ort t lcsr = +let add_rewrite_hint ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in - let poly = Flags.use_polymorphic_flag () in - let f ce = + let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = let ctx = UState.context_set ctx in @@ -270,16 +268,16 @@ let add_rewrite_hint bases ort t lcsr = let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater -VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint +VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o None l ] + [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o None l; st ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o (Some t) l ] + [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l; st ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ add_rewrite_hint ["core"] o None l ] + [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l; st ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ add_rewrite_hint ["core"] o (Some t) l ] + [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ] END (**********************************************************************) @@ -290,7 +288,7 @@ open EConstr open Vars open Coqlib -let project_hint pri l2r r = +let project_hint ~poly pri l2r r = let gr = Smartlocate.global_with_alias r in let env = Global.env() in let sigma = Evd.from_env env in @@ -313,30 +311,28 @@ let project_hint pri l2r r = let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in - let poly = Flags.use_polymorphic_flag () in let ctx = Evd.const_univ_entry ~poly sigma in let c = EConstr.to_constr sigma c in let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) -let add_hints_iff ?locality l2r lc n bl = - Hints.add_hints (Locality.make_module_locality locality) bl - (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) +let add_hints_iff ~atts l2r lc n bl = + let open Vernacinterp in + Hints.add_hints (Locality.make_module_locality atts.locality) bl + (Hints.HintsResolveEntry (List.map (project_hint ~poly:atts.polymorphic n l2r) lc)) VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ fun ~atts ~st -> begin - let open Vernacinterp in - add_hints_iff ?locality:atts.locality true lc n bl; + add_hints_iff ~atts true lc n bl; st end ] | [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> [ fun ~atts ~st -> begin - let open Vernacinterp in - add_hints_iff ?locality:atts.locality true lc n ["core"]; + add_hints_iff ~atts true lc n ["core"]; st end ] @@ -346,15 +342,13 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ fun ~atts ~st -> begin - let open Vernacinterp in - add_hints_iff ?locality:atts.locality false lc n bl; + add_hints_iff ~atts false lc n bl; st end ] | [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> [ fun ~atts ~st -> begin - let open Vernacinterp in - add_hints_iff ?locality:atts.locality false lc n ["core"]; + add_hints_iff ~atts false lc n ["core"]; st end ] @@ -430,34 +424,46 @@ let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater | [ "Type" ] -> [ InType ] END*) -VERNAC COMMAND EXTEND DeriveInversionClear +VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversionClear | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac; st ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c Sorts.InProp false inv_clear_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac; st ] END -VERNAC COMMAND EXTEND DeriveInversion +VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac; st ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c Sorts.InProp false inv_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac; st ] END -VERNAC COMMAND EXTEND DeriveDependentInversion +VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversion | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac; st ] END -VERNAC COMMAND EXTEND DeriveDependentInversionClear +VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversionClear | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac; st ] END (**********************************************************************) @@ -1117,3 +1123,12 @@ VERNAC COMMAND EXTEND OptimizeProof | [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> [ Gc.compact () ] END + +(** tactic analogous to "OPTIMIZE HEAP" *) + +let tclOPTIMIZE_HEAP = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> Gc.compact ())) + +TACTIC EXTEND optimize_heap +| [ "optimize_heap" ] -> [ tclOPTIMIZE_HEAP ] +END diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 90a44708f..f74d24db0 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Genarg open Stdarg diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index ed2d9da63..014433ac4 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Class_tactics open Stdarg open Tacarg diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 index 549436902..f705778fc 100644 --- a/plugins/ltac/g_eqdecide.ml4 +++ b/plugins/ltac/g_eqdecide.ml4 @@ -12,8 +12,6 @@ (* by Eduardo Gimenez *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Eqdecide DECLARE PLUGIN "ltac_plugin" diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 34fea6175..9ef819569 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - DECLARE PLUGIN "ltac_plugin" open Util @@ -17,7 +15,7 @@ open Tacexpr open Misctypes open Genarg open Genredexpr -open Tok (* necessary for camlp4 *) +open Tok (* necessary for camlp5 *) open Names open Pcoq @@ -78,11 +76,6 @@ let test_bracket_ident = let hint = G_proofs.hint -let warn_deprecated_appcontext = - CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" - (fun () -> strbrk "appcontext is deprecated and will be removed " ++ - strbrk "in a future version") - GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint tactic_mode constr_may_eval constr_eval toplevel_selector @@ -242,12 +235,7 @@ GEXTEND Gram match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> - let mode = not (!Flags.tactic_context_compat) in - Subterm (mode, oid, pc) - | IDENT "appcontext"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - warn_deprecated_appcontext ~loc:!@loc (); - Subterm (true,oid, pc) + Subterm (oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: @@ -337,7 +325,8 @@ GEXTEND Gram | IDENT "all"; ":" -> SelectAll ] ] ; tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g ] ] + [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g + | g = OPT toplevel_selector; "{" -> Vernacexpr.VernacSubproof g ] ] ; command: [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; @@ -471,7 +460,7 @@ END VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation | [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtUnknown, VtNow ] -> + [ VtSideff [], VtNow ] -> [ fun ~atts ~st -> let open Vernacinterp in let n = Option.default 0 n in Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n r e; diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index f6cc3833a..e251b1049 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -6,11 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - (* Syntax for the subtac terms and types. - Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) + Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) open Libnames open Constrexpr diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index ea1808a25..2459a09bc 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - (* Syntax for rewriting with strategies *) open Names diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index d792d4ff7..e68140828 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -115,10 +115,11 @@ let mk_fix_tac (loc,id,bl,ann,ty) = match bl,ann with [([_],_,_)], None -> 1 | _, Some x -> - let ids = List.map snd (List.flatten (List.map pi1 bl)) in + let ids = List.map snd (List.flatten (List.map (fun (nal,_,_) -> nal) bl)) in (try List.index Names.Name.equal (snd x) ids with Not_found -> user_err Pp.(str "No such fix variable.")) | _ -> user_err Pp.(str "Cannot guess decreasing argument of fix.") in + let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in (id,n, CAst.make ~loc @@ CProdN(bl,ty)) let mk_cofix_tac (loc,id,bl,ann,ty) = @@ -126,6 +127,7 @@ let mk_cofix_tac (loc,id,bl,ann,ty) = user_err ~loc:aloc ~hdr:"Constr:mk_cofix_tac" (Pp.str"Annotation forbidden in cofix expression.")) ann in + let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in (id,CAst.make ~loc @@ CProdN(bl,ty)) (* Functions overloaded by quotifier *) @@ -160,7 +162,7 @@ let mkTacCase with_evar = function let rec mkCLambdaN_simple_loc ?loc bll c = match bll with | ((loc1,_)::_ as idl,bk,t) :: bll -> - CAst.make ?loc @@ CLambdaN ([idl,bk,t],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt loc1 loc) bll c) + CAst.make ?loc @@ CLambdaN ([CLocalAssum (idl,bk,t)],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt loc1 loc) bll c) | ([],_,_) :: bll -> mkCLambdaN_simple_loc ?loc bll c | [] -> c diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d70751245..4f430b79e 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -84,6 +84,24 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> Pp.t) -> 'a -> Pp.t +type 'a raw_extra_genarg_printer_with_level = + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a glob_extra_genarg_printer_with_level = + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a extra_genarg_printer_with_level = + (EConstr.constr -> Pp.t) -> + (EConstr.constr -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t + let string_of_genarg_arg (ArgumentType arg) = let rec aux : type a b c. (a, b, c) genarg_type -> string = function | ListArg t -> aux t ^ "_list" @@ -127,9 +145,9 @@ let string_of_genarg_arg (ArgumentType arg) = | Some Refl -> let open Genprint in match generic_top_print (in_gen (Topwit wit) x) with - | PrinterBasic pr -> pr () - | PrinterNeedsContext pr -> pr (Global.env()) Evd.empty - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterBasic pr -> pr () + | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> printer (Global.env()) Evd.empty default_ensure_surrounded end | _ -> default @@ -335,9 +353,10 @@ let string_of_genarg_arg (ArgumentType arg) = let rec strip_ty acc n ty = match ty.CAst.v with Constrexpr.CProdN(bll,a) -> - let nb = - List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in - let bll = List.map (fun (x, _, y) -> x, y) bll in + let bll = List.map (function + | CLocalAssum (nal,_,t) -> nal,t + | _ -> user_err Pp.(str "Cannot translate fix tactic: not only products")) bll in + let nb = List.fold_left (fun i (nal,t) -> i + List.length nal) 0 bll in if nb >= n then (List.rev (bll@acc)), a else strip_ty (bll@acc) (n-nb) a | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in @@ -508,11 +527,9 @@ let pr_goal_selector ~toplevel s = let pr_match_pattern pr_pat = function | Term a -> pr_pat a - | Subterm (b,None,a) -> - (** ppedrot: we don't make difference between [appcontext] and [context] - anymore, and the interpretation is governed by a flag instead. *) + | Subterm (None,a) -> keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" - | Subterm (b,Some id,a) -> + | Subterm (Some id,a) -> keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" let pr_match_hyps pr_pat = function @@ -723,8 +740,10 @@ let pr_goal_selector ~toplevel s = | TacIntroPattern (ev,[]) as t -> pr_atom0 t | TacIntroPattern (ev,(_::_ as p)) -> - hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++ - prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) + hov 1 (primitive (if ev then "eintros" else "intros") ++ + (match p with + | [_,Misctypes.IntroForthcoming false] -> mt () + | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ @@ -1192,42 +1211,77 @@ let declare_extra_genarg_pprule wit | ExtraArg s -> () | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; - let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let f x = + Genprint.PrinterBasic (fun () -> + f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = + Genprint.PrinterBasic (fun () -> let env = Global.env () in - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x) in let h x = - Genprint.PrinterNeedsContext (fun env sigma -> + Genprint.TopPrinterNeedsContext (fun env sigma -> h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h +let declare_extra_genarg_pprule_with_level wit + (f : 'a raw_extra_genarg_printer_with_level) + (g : 'b glob_extra_genarg_printer_with_level) + (h : 'c extra_genarg_printer_with_level) default_surrounded default_non_surrounded = + begin match wit with + | ExtraArg s -> () + | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") + end; + let open Genprint in + let f x = + PrinterNeedsLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun n -> + f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in + let g x = + let env = Global.env () in + PrinterNeedsLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun n -> + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) } + in + let h x = + TopPrinterNeedsContextAndLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun env sigma n -> + h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) } + in + Genprint.register_print0 wit f g h + let declare_extra_vernac_genarg_pprule wit f = - let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in Genprint.register_vernac_print0 wit f (** Registering *) -let pr_intro_pattern_env p = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> let print_constr c = let (sigma, c) = c env sigma in pr_econstr_env env sigma c in Miscprint.pr_intro_pattern print_constr p) -let pr_red_expr_env r = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) -let pr_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in Miscprint.pr_bindings (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) -let pr_with_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_with_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in pr_with_bindings (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) -let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_destruction_arg_env c = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, c = match c with | clear_flag,ElimOnConstr g -> let sigma,c = g env sigma in sigma,(clear_flag,ElimOnConstr c) | clear_flag,ElimOnAnonHyp n as x -> sigma, x @@ -1236,12 +1290,16 @@ let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma -> (pr_econstr_env env sigma) (pr_leconstr_env env sigma) c) let make_constr_printer f c = - Genprint.PrinterNeedsContextAndLevel { + Genprint.TopPrinterNeedsContextAndLevel { Genprint.default_already_surrounded = Ppconstr.ltop; Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; Genprint.printer = (fun env sigma n -> f env sigma n c)} let lift f a = Genprint.PrinterBasic (fun () -> f a) +let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) + +let register_basic_print0 wit f g h = + Genprint.register_print0 wit (lift f) (lift g) (lift_top h) let pr_glob_constr_pptac c = @@ -1255,80 +1313,81 @@ let pr_lglob_constr_pptac c = let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in - Genprint.register_print0 wit_int_or_var - (pr_or_var int) (pr_or_var int) (lift int); - Genprint.register_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) (lift pr_global); - Genprint.register_print0 wit_ident - pr_id pr_id (lift pr_id); - Genprint.register_print0 wit_var - (pr_located pr_id) (pr_located pr_id) (lift pr_id); - Genprint.register_print0 + let open Genprint in + register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; + register_basic_print0 wit_ref + pr_reference (pr_or_var (pr_located pr_global)) pr_global; + register_basic_print0 wit_ident pr_id pr_id pr_id; + register_basic_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id; + register_print0 wit_intro_pattern - (Miscprint.pr_intro_pattern pr_constr_expr) - (Miscprint.pr_intro_pattern (fun (c, _) -> pr_glob_constr_pptac c)) + (lift (Miscprint.pr_intro_pattern pr_constr_expr)) + (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c))) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) pr_lident) - (fun c -> Genprint.PrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c)) + (lift (pr_clauses (Some true) pr_lident)) + (lift (pr_clauses (Some true) pr_lident)) + (fun c -> Genprint.TopPrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c)) ; Genprint.register_print0 wit_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> pr_glob_constr_pptac c) + (lift Ppconstr.pr_lconstr_expr) + (lift (fun (c, _) -> pr_lglob_constr_pptac c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr - Ppconstr.pr_constr_expr - (fun (c, _) -> pr_glob_constr_pptac c) + (lift Ppconstr.pr_constr_expr) + (lift (fun (c,_) -> pr_glob_constr_pptac c)) (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> pr_glob_constr_pptac c) + (lift Ppconstr.pr_constr_expr) + (lift (fun (c, _) -> pr_glob_constr_pptac c)) (make_constr_printer Printer.pr_econstr_n_env) ; - Genprint.register_print0 wit_red_expr - (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) - (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac)) + Genprint.register_print0 + wit_red_expr + (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))) + (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) pr_red_expr_env ; - Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis (lift pr_quantified_hypothesis); - Genprint.register_print0 wit_bindings - (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr) - (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) + register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + register_print0 wit_bindings + (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)) + (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_bindings_env ; - Genprint.register_print0 wit_constr_with_bindings - (pr_with_bindings pr_constr_expr pr_lconstr_expr) - (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) + register_print0 wit_constr_with_bindings + (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) + (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_with_bindings_env ; - Genprint.register_print0 wit_open_constr_with_bindings - (pr_with_bindings pr_constr_expr pr_lconstr_expr) - (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) + register_print0 wit_open_constr_with_bindings + (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) + (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_with_bindings_env ; - Genprint.register_print0 Tacarg.wit_destruction_arg - (pr_destruction_arg pr_constr_expr pr_lconstr_expr) - (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) + register_print0 Tacarg.wit_destruction_arg + (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr)) + (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_destruction_arg_env ; - Genprint.register_print0 Stdarg.wit_int int int (lift int); - Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool (lift pr_bool); - Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit (lift pr_unit); - Genprint.register_print0 Stdarg.wit_pre_ident str str (lift str); - Genprint.register_print0 Stdarg.wit_string qstring qstring (lift qstring) + register_basic_print0 Stdarg.wit_int int int int; + register_basic_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; + register_basic_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; + register_basic_print0 Stdarg.wit_pre_ident str str str; + register_basic_print0 Stdarg.wit_string qstring qstring qstring let () = - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_tactic printer printer printer + let printer _ _ prtac = prtac in + declare_extra_genarg_pprule_with_level wit_tactic printer printer printer + ltop (0,E) let () = - let pr_unit _ _ _ () = str "()" in - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_ltac printer printer pr_unit + let pr_unit _ _ _ _ () = str "()" in + let printer _ _ prtac = prtac in + declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit + ltop (0,E) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 5ecfaf590..bda5774ab 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -40,12 +40,37 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> Pp.t) -> 'a -> Pp.t +type 'a raw_extra_genarg_printer_with_level = + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a glob_extra_genarg_printer_with_level = + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a extra_genarg_printer_with_level = + (EConstr.constr -> Pp.t) -> + (EConstr.constr -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t + val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> 'a raw_extra_genarg_printer -> 'b glob_extra_genarg_printer -> 'c extra_genarg_printer -> unit +val declare_extra_genarg_pprule_with_level : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer_with_level -> + 'b glob_extra_genarg_printer_with_level -> + 'c extra_genarg_printer_with_level -> + (* surroounded *) tolerability -> (* non-surroounded *) tolerability -> unit + val declare_extra_vernac_genarg_pprule : ('a, 'b, 'c) genarg_type -> 'a raw_extra_genarg_printer -> unit diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 9ae8bfe65..161546528 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -289,7 +289,7 @@ let rec find_in_stack what acc = function | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) | { name } as x :: rest -> find_in_stack what (x :: acc) rest -let exit_tactic start_time c = +let exit_tactic ~count_call start_time c = let diff = time () -. start_time in match Local.(!stack) with | [] | [_] -> @@ -304,7 +304,7 @@ let exit_tactic start_time c = let node = { node with total = node.total +. diff; local = node.local +. diff; - ncalls = node.ncalls + 1; + ncalls = node.ncalls + (if count_call then 1 else 0); max_total = max node.max_total diff; } in (* updating the stack *) @@ -341,7 +341,7 @@ let tclFINALLY tac (finally : unit Proofview.tactic) = (fun v -> finally <*> Proofview.tclUNIT v) (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) -let do_profile s call_trace tac = +let do_profile s call_trace ?(count_call=true) tac = let open Proofview.Notations in Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> if !is_profiling then @@ -359,7 +359,7 @@ let do_profile s call_trace tac = tac (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> (match call_trace with - | (_, c) :: _ -> exit_tactic start_time c + | (_, c) :: _ -> exit_tactic ~count_call start_time c | [] -> ())))) | None -> tac @@ -397,6 +397,27 @@ let reset_profile () = reset_profile_tmp (); data := SM.empty +(* ****************************** Named timers ****************************** *) + +let timer_data = ref M.empty + +let timer_name = function + | Some v -> v + | None -> "" + +let restart_timer name = + timer_data := M.add (timer_name name) (System.get_time ()) !timer_data + +let get_timer name = + try M.find (timer_name name) !timer_data + with Not_found -> System.get_time () + +let finish_timing ~prefix name = + let tend = System.get_time () in + let tstart = get_timer name in + Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++ + System.fmt_time_difference tstart tend) + (* ******************** *) let print_results_filter ~cutoff ~filter = @@ -408,7 +429,7 @@ let print_results_filter ~cutoff ~filter = let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in - Feedback.msg_notice (to_string ~cutoff ~filter results) + Feedback.msg_info (to_string ~cutoff ~filter results) ;; let print_results ~cutoff = diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli index 52827cb36..adedf7ee9 100644 --- a/plugins/ltac/profile_ltac.mli +++ b/plugins/ltac/profile_ltac.mli @@ -9,9 +9,39 @@ (** Ltac profiling primitives *) +(* Note(JasonGross): Ltac semantics are a bit insane. There isn't + really a good notion of how many times a tactic has been "called", + because tactics can be partially evaluated, and it's unclear + whether the number of "calls" should be the number of times the + body is fetched and unfolded, or the number of times the code is + executed to a value, etc. The logic in [Tacinterp.eval_tactic] + gives a decent approximation, which I believe roughly corresponds + to the number of times that the engine runs the tactic value which + results from evaluating the tactic expression bound to the name + we're considering. However, this is a poor approximation of the + time spent in the tactic; we want to consider time spent evaluating + a tactic expression to a tactic value to be time spent in the + expression, not just time spent in the caller of the expression. + So we need to wrap some nodes in additional profiling calls which + don't count towards to total call count. Whether or not a call + "counts" is indicated by the [count_call] boolean argument. + + Unfortunately, at present, we can get very strange call graphs when + a named tactic expression never runs as a tactic value: if we have + [Ltac t0 := t.] and [Ltac t1 := t0.], then [t1] is considered to + run 0(!) times. It evaluates to [t] during tactic expression + evaluation, and although the call trace records the fact that it + was called by [t0] which was called by [t1], the tactic running + phase never sees this. Thus we get one call tree (from expression + evaluation) that has [t1] calls [t0] calls [t], and another call + tree which says that the caller of [t1] calls [t] directly; the + expression evaluation time goes in the first tree, and the call + count and tactic running time goes in the second tree. Alas, I + suspect that fixing this requires a redesign of how the profiler + hooks into the tactic engine. *) val do_profile : string -> ('a * Tacexpr.ltac_call_kind) list -> - 'b Proofview.tactic -> 'b Proofview.tactic + ?count_call:bool -> 'b Proofview.tactic -> 'b Proofview.tactic val set_profiling : bool -> unit @@ -22,6 +52,10 @@ val print_results_tactic : string -> unit val reset_profile : unit -> unit +val restart_timer : string option -> unit + +val finish_timing : prefix:string -> string option -> unit + val do_print_results_at_close : unit -> unit (* The collected statistics for a tactic. The timing data is collected over all @@ -46,4 +80,3 @@ type treenode = { (* Returns the profiling results known by the current process *) val get_local_profiling_results : unit -> treenode val feedback_results : treenode -> unit - diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 index 2b1106ee2..7a75662be 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -6,28 +6,60 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - (** Ltac profiling entrypoints *) open Profile_ltac open Stdarg -DECLARE PLUGIN "profile_ltac_plugin" +DECLARE PLUGIN "ltac_plugin" let tclSET_PROFILING b = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) +let tclRESET_PROFILE = + Proofview.tclLIFT (Proofview.NonLogical.make reset_profile) + +let tclSHOW_PROFILE ~cutoff = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results ~cutoff)) + +let tclSHOW_PROFILE_TACTIC s = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results_tactic s)) + +let tclRESTART_TIMER s = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> restart_timer s)) + +let tclFINISH_TIMING ?(prefix="Timer") (s : string option) = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s)) + TACTIC EXTEND start_ltac_profiling | [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] END -TACTIC EXTEND stop_profiling +TACTIC EXTEND stop_ltac_profiling | [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] END +TACTIC EXTEND reset_ltac_profile +| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ] +END + +TACTIC EXTEND show_ltac_profile +| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ] +| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ] +| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ] +END + +TACTIC EXTEND restart_timer +| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ] +END + +TACTIC EXTEND finish_timing +| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ] +| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ] +END + VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ] END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index c0060c5a7..acd7a30c4 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -210,9 +210,9 @@ end) = struct let t = Reductionops.whd_all env (goalevars evars) ty in match EConstr.kind (goalevars evars) t, l with | Prod (na, ty, b), obj :: cstrs -> - let b = Reductionops.nf_betaiota (goalevars evars) b in + let b = Reductionops.nf_betaiota env (goalevars evars) b in if noccurn (goalevars evars) 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in @@ -221,7 +221,7 @@ end) = struct let (evars, b, arg, cstrs) = aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs in - let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in @@ -231,7 +231,7 @@ end) = struct | _, [] -> (match finalcstr with | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (fst evars) ty in + let t = Reductionops.nf_betaiota env (fst evars) ty in let evars, rel = mk_relty evars env t None in evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) @@ -361,8 +361,8 @@ end) = struct end (* let my_type_of env evars c = Typing.e_type_of env evars c *) -(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) -(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) +(* let mytypeofkey = CProfile.declare_profile "my_type_of";; *) +(* let my_type_of = CProfile.profile3 mytypeofkey my_type_of *) let type_app_poly env env evd f args = @@ -1557,9 +1557,8 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (** For compatibility *) - let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in - let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in + let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") @@ -1781,7 +1780,9 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = - new_instance (Flags.is_universe_polymorphism ()) + let program_mode = Flags.is_program_mode () in + let poly = Flags.is_universe_polymorphism () in + new_instance ~program_mode poly binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global ~generalize:false ~refine:false Hints.empty_hint_info @@ -1979,8 +1980,7 @@ let add_morphism_infer glob m n = Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob - poly (ConstRef cst)); + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else let kind = Decl_kinds.Global, poly, @@ -1991,7 +1991,7 @@ let add_morphism_infer glob m n = | Globnames.ConstRef cst -> add_instance (Typeclasses.new_instance (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info - glob poly (ConstRef cst)); + glob (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false in @@ -2012,23 +2012,26 @@ let add_morphism glob binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob poly binders instance - (Some (true, CAst.make @@ CRecord [])) - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let program_mode = Flags.is_program_mode () in + ignore(new_instance ~program_mode ~global:glob poly binders instance + (Some (true, CAst.make @@ CRecord [])) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) (** Taken from original setoid_replace, to emulate the old rewrite semantics where lemmas are first instantiated and then rewrite proceeds. *) -let check_evar_map_of_evars_defs evd = +let check_evar_map_of_evars_defs env evd = let metas = Evd.meta_list evd in let check_freemetas_is_empty rebus = Evd.Metaset.iter (fun m -> - if Evd.meta_defined evd m then () else - raise - (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) + if Evd.meta_defined evd m then () + else begin + raise + (Logic.RefinerError (env, evd, Logic.UnresolvedBindings [Evd.meta_name evd m])) + end) in List.iter (fun (_,binding) -> @@ -2063,7 +2066,7 @@ let unification_rewrite l2r c1 c2 sigma prf car rel but env = let c1 = if l2r then nf c' else nf c1 and c2 = if l2r then nf c2 else nf c' and car = nf car and rel = nf rel in - check_evar_map_of_evars_defs sigma; + check_evar_map_of_evars_defs env sigma; let prf = nf prf in let prfty = nf (Retyping.get_type_of env sigma prf) in let sort = sort_of_rel env sigma but in @@ -2084,8 +2087,8 @@ let get_hyp gl (c,l) clause l2r = let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } -(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) -(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) +(* let rewriteclaustac_key = CProfile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = CProfile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index c03a86732..e5933de2a 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -33,7 +33,7 @@ let (wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_bin let () = register_val0 wit None in let () = Genprint.register_val_print0 (base_val_typ wit) (fun c -> - Genprint.PrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in + Genprint.TopPrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in wit (** All the types considered here are base types *) @@ -61,12 +61,9 @@ struct type t = Val.t -let normalize v = v - let of_constr c = in_gen (topwit wit_constr) c let to_constr v = - let v = normalize v in if has_type v (topwit wit_constr) then let c = out_gen (topwit wit_constr) v in Some c @@ -78,7 +75,6 @@ let to_constr v = let of_uconstr c = in_gen (topwit wit_uconstr) c let to_uconstr v = - let v = normalize v in if has_type v (topwit wit_uconstr) then Some (out_gen (topwit wit_uconstr) v) else None @@ -86,7 +82,6 @@ let to_uconstr v = let of_int i = in_gen (topwit wit_int) i let to_int v = - let v = normalize v in if has_type v (topwit wit_int) then Some (out_gen (topwit wit_int) v) else None @@ -108,14 +103,12 @@ let constr_of_id env id = (* Gives the constr corresponding to a Constr_context tactic_arg *) let coerce_to_constr_context v = - let v = Value.normalize v in if has_type v (topwit wit_constr_context) then out_gen (topwit wit_constr_context) v else raise (CannotCoerceTo "a term context") (* Interprets an identifier which must be fresh *) let coerce_var_to_ident fresh env sigma v = - let v = Value.normalize v in let fail () = raise (CannotCoerceTo "a fresh identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with @@ -140,7 +133,6 @@ let g = sigma in let id_of_name = function | Name.Anonymous -> Id.of_string "x" | Name.Name x -> x in - let v = Value.normalize v in let fail () = raise (CannotCoerceTo "an identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with @@ -179,7 +171,6 @@ let id_of_name = function let coerce_to_intro_pattern env sigma v = - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then snd (out_gen (topwit wit_intro_pattern) v) else if has_type v (topwit wit_var) then @@ -198,7 +189,6 @@ let coerce_to_intro_pattern_naming env sigma v = | _ -> raise (CannotCoerceTo "a naming introduction pattern") let coerce_to_hint_base v = - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) -> Id.to_string id @@ -206,13 +196,11 @@ let coerce_to_hint_base v = else raise (CannotCoerceTo "a hint base name") let coerce_to_int v = - let v = Value.normalize v in if has_type v (topwit wit_int) then out_gen (topwit wit_int) v else raise (CannotCoerceTo "an integer") let coerce_to_constr env v = - let v = Value.normalize v in let fail () = raise (CannotCoerceTo "a term") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with @@ -230,7 +218,6 @@ let coerce_to_constr env v = else fail () let coerce_to_uconstr env v = - let v = Value.normalize v in if has_type v (topwit wit_uconstr) then out_gen (topwit wit_uconstr) v else @@ -243,7 +230,6 @@ let coerce_to_closed_constr env v = let coerce_to_evaluable_ref env sigma v = let fail () = raise (CannotCoerceTo "an evaluable reference") in - let v = Value.normalize v in let ev = if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with @@ -284,7 +270,6 @@ let coerce_to_intro_pattern_list ?loc env sigma v = let coerce_to_hyp env sigma v = let fail () = raise (CannotCoerceTo "a variable") in - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id @@ -306,7 +291,6 @@ let coerce_to_hyp_list env sigma v = (* Interprets a qualified name *) let coerce_to_reference env sigma v = - let v = Value.normalize v in match Value.to_constr v with | Some c -> begin @@ -318,7 +302,6 @@ let coerce_to_reference env sigma v = (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_quantified_hypothesis sigma v = - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with @@ -336,7 +319,6 @@ let coerce_to_quantified_hypothesis sigma v = (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_decl_or_quant_hyp env sigma v = - let v = Value.normalize v in if has_type v (topwit wit_int) then AnonHyp (out_gen (topwit wit_int) v) else diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index d7b253a68..dce16b733 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -31,9 +31,6 @@ module Value : sig type t = Val.t - val normalize : t -> t - (** Eliminated the leading dynamic type casts. *) - val of_constr : constr -> t val to_constr : t -> constr option val of_uconstr : Ltac_pretype.closed_glob_constr -> t diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index ee84be541..8112cc400 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -545,11 +545,10 @@ let print_located_tactic qid = (** Grammar *) let () = - let open Metasyntax in let entries = [ AnyEntry Pltac.tactic_expr; AnyEntry Pltac.binder_tactic; AnyEntry Pltac.simple_tactic; AnyEntry Pltac.tactic_arg; ] in - register_grammar "tactic" entries + register_grammars_by_name "tactic" entries diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 9bd3efc6b..ccd555b61 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -81,7 +81,7 @@ type 'a with_bindings_arg = clear_flag * 'a with_bindings (* Type of patterns *) type 'a match_pattern = | Term of 'a - | Subterm of bool * Id.t option * 'a + | Subterm of Id.t option * 'a (* Type of hypotheses for a Match Context rule *) type 'a match_context_hyps = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index b16b0a7ba..ebffde441 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -428,9 +428,9 @@ let intern_hyp_location ist ((occs,id),hl) = (* Reads a pattern *) let intern_pattern ist ?(as_type=false) ltacvars = function - | Subterm (b,ido,pc) -> + | Subterm (ido,pc) -> let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in - ido, metas, Subterm (b,ido,pc) + ido, metas, Subterm (ido,pc) | Term pc -> let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in None, metas, Term pc diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 1a8ec6d6f..f2720954d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -128,7 +128,7 @@ let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = let wit = Genarg.create_arg "tacvalue" in let () = register_val0 wit None in let () = Genprint.register_val_print0 (base_val_typ wit) - (fun _ -> Genprint.PrinterBasic (fun () -> str "<tactic closure>")) in + (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in wit let of_tacvalue v = in_gen (topwit wit_tacvalue) v @@ -136,7 +136,6 @@ let to_tacvalue v = out_gen (topwit wit_tacvalue) v (** More naming applications *) let name_vfun appl vle = - let vle = Value.normalize vle in if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) @@ -235,16 +234,15 @@ let curr_debug ist = match TacStore.get ist.extra f_debug with (* Displays a value *) let pr_value env v = - let v = Value.normalize v in let pr_with_env pr = match env with | Some (env,sigma) -> pr env sigma | None -> str "a value of type" ++ spc () ++ pr_argument_type v in let open Genprint in match generic_val_print v with - | PrinterBasic pr -> pr () - | PrinterNeedsContext pr -> pr_with_env pr - | PrinterNeedsContextAndLevel { default_already_surrounded; printer } -> + | TopPrinterBasic pr -> pr () + | TopPrinterNeedsContext pr -> pr_with_env pr + | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) let pr_closure env ist body = @@ -285,7 +283,6 @@ let push_trace call ist = match TacStore.get ist.extra f_trace with | Some trace -> Proofview.tclUNIT (call :: trace) let propagate_trace ist loc id v = - let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with @@ -298,7 +295,6 @@ let propagate_trace ist loc id v = else Proofview.tclUNIT v let append_trace trace v = - let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) @@ -307,11 +303,9 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = - let v = Value.normalize v in let fail () = user_err ?loc (str "Variable " ++ Id.print id ++ str " should be bound to a tactic.") in - let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with @@ -420,7 +414,7 @@ let interp_hyp ist env sigma (loc,id as locid) = with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id - else Loc.raise ?loc (Logic.RefinerError (Logic.NoSuchHyp id)) + else Loc.raise ?loc (Logic.RefinerError (env, sigma, Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env sigma (Id.Map.find id ist.lfun) @@ -514,7 +508,6 @@ let rec intropattern_ids accu (loc,pat) = match pat with let extract_ids ids lfun accu = let fold id v accu = - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let (_, ipat) = out_gen (topwit wit_intro_pattern) v in if Id.List.mem id ids then accu @@ -816,14 +809,13 @@ let interp_constr_may_eval ist env sigma c = (** TODO: should use dedicated printers *) let message_of_value v = - let v = Value.normalize v in let pr_with_env pr = Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in let open Genprint in match generic_val_print v with - | PrinterBasic pr -> Ftactic.return (pr ()) - | PrinterNeedsContext pr -> pr_with_env pr - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterBasic pr -> Ftactic.return (pr ()) + | TopPrinterNeedsContext pr -> pr_with_env pr + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_ensure_surrounded) let interp_message_token ist = function @@ -890,7 +882,7 @@ let interp_intro_pattern_naming_option ist env sigma = function let interp_or_and_intro_pattern_option ist env sigma = function | None -> sigma, None | Some (ArgVar (loc,id)) -> - (match coerce_to_intro_pattern env sigma (Id.Map.find id ist.lfun) with + (match interp_intro_pattern_var loc ist env sigma id with | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) | _ -> user_err ?loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) @@ -986,7 +978,6 @@ let interp_destruction_arg ist gl arg = try (** FIXME: should be moved to taccoerce *) let v = Id.Map.find id ist.lfun in - let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with @@ -1040,7 +1031,7 @@ let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) = (bvars,instantiate_pattern env sigma lfun pat) let read_pattern lfun ist env sigma = function - | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) + | Subterm (ido,c) -> Subterm (ido,eval_pattern lfun ist env sigma c) | Term c -> Term (eval_pattern lfun ist env sigma c) (* Reads the hypotheses of a Match Context rule *) @@ -1158,10 +1149,14 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Proofview.V82.tactic begin tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end - | TacAbstract (tac,ido) -> + | TacAbstract (t,ido) -> + let call = LtacMLCall tac in + push_trace(None,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:TacAbstract" trace + (catch_error_tac trace begin Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT - (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) - end + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t) + end end) | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> @@ -1244,7 +1239,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.run args tac and force_vrec ist v : Val.t Ftactic.t = - let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let v = to_tacvalue v in match v with @@ -1272,7 +1266,8 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; extra = extra; } in let appl = GlbAppl[r,[]] in - val_interp ~appl ist (Tacenv.interp_ltac r) + Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false + (val_interp ~appl ist (Tacenv.interp_ltac r)) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1319,7 +1314,6 @@ and interp_tacarg ist arg : Val.t Ftactic.t = and interp_app loc ist fv largs : Val.t Ftactic.t = let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in - let fv = Value.normalize fv in if has_type fv (topwit wit_tacvalue) then match to_tacvalue fv with (* if var=[] and body has been delayed by val_interp, then body @@ -1338,7 +1332,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = let ist = { lfun = newlfun; extra = TacStore.set ist.extra f_trace []; } in - catch_error_tac trace (val_interp ist body) >>= fun v -> + Profile_ltac.do_profile "interp_app" trace ~count_call:false + (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1353,8 +1348,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = begin let open Genprint in match generic_val_print v with - | PrinterBasic _ -> call_debug None - | PrinterNeedsContext _ | PrinterNeedsContextAndLevel _ -> + | TopPrinterBasic _ -> call_debug None + | TopPrinterNeedsContext _ | TopPrinterNeedsContextAndLevel _ -> Proofview.Goal.enter (fun gl -> call_debug (Some (pf_env gl,project gl))) end <*> if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval @@ -1371,7 +1366,6 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = (* Gives the tactic corresponding to the tactic value *) and tactic_of_value ist vle = - let vle = Value.normalize vle in if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> @@ -1380,13 +1374,38 @@ and tactic_of_value ist vle = extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) - | VFun (_, _, _,vars,_) -> - let numargs = List.length vars in - Tacticals.New.tclZEROMSG - (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ - Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ - Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ - pr_enum Name.print vars ++ Pp.str ".") + | VFun (appl,_,vmap,vars,_) -> + let tactic_nm = + match appl with + UnnamedAppl -> "An unnamed user-defined tactic" + | GlbAppl apps -> + let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in + match nms with + [] -> assert false + | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *) + in + let numargs = List.length vars in + let givenargs = + List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in + let numgiven = List.length givenargs in + Tacticals.New.tclZEROMSG + (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++ + (match numargs with + 0 -> assert false + | 1 -> + Pp.str "There is a missing argument for variable " ++ + (Name.print (List.hd vars)) + | _ -> Pp.str "There are missing arguments for variables " ++ + pr_enum Name.print vars) ++ Pp.pr_comma () ++ + match numgiven with + 0 -> + Pp.str "no arguments at all were provided." + | 1 -> + Pp.str "an argument was provided for variable " ++ + Pp.str (List.hd givenargs) ++ Pp.str "." + | _ -> + Pp.str "arguments were provided for variables " ++ + pr_enum Pp.str givenargs ++ Pp.str ".") | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in @@ -1573,7 +1592,6 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in - let result = Value.normalize result in try let cresult = coerce_to_closed_constr env result in Proofview.tclLIFT begin diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 918d1faeb..79bf3685e 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -121,7 +121,7 @@ let subst_raw_may_eval subst = function | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) let subst_match_pattern subst = function - | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) + | Subterm (ido,pc) -> Subterm (ido,(subst_glob_constr_or_pattern subst pc)) | Term pc -> Term (subst_glob_constr_or_pattern subst pc) let rec subst_match_goal_hyps subst = function diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 89b78e590..e87951dd7 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -237,7 +237,7 @@ module PatternMatching (E:StaticEnvironment) = struct return lhs with Constr_matching.PatternMatchingFailure -> fail end - | Subterm (with_app_context,id_ctxt,p) -> + | Subterm (id_ctxt,p) -> let rec map s (e, info) = { stream = fun k ctx -> match IStream.peek s with @@ -252,7 +252,7 @@ module PatternMatching (E:StaticEnvironment) = struct | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx) } in - map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error + map (Constr_matching.match_subterm E.env E.sigma p term) imatching_error (** [rule_match_term term rule] matches the term [term] with the diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index e5b5854f0..362cc3a59 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -49,16 +49,13 @@ Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". -(** We now extract to stdout, see comment in Makefile.build *) - -(*Extraction "plugins/micromega/micromega.ml" *) -Recursive Extraction - List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add - n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. - - - +(** In order to avoid annoying build dependencies the actual + extraction is only performed as a test in the test suite. *) +(* Extraction "plugins/micromega/micromega.ml" *) +(* Recursive Extraction *) +(* List.map simpl_cone (*map_cone indexes*) *) +(* denorm Qpower vm_add *) +(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index b15dd7ae6..9f1d83f96 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -14,8 +14,6 @@ (* *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open Stdarg open Tacarg diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 49ccb468c..387a52514 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -149,7 +149,7 @@ let open_in f = match read_key_elem inch with | None -> () | Some (key,elem) -> - Table.add htbl key elem ; + Table.replace htbl key elem ; xload () in try (* Locking of the (whole) file while reading *) @@ -195,7 +195,7 @@ let add t k e = else let fd = descr_of_out_channel outch in begin - Table.add tbl k e ; + Table.replace tbl k e ; do_under_lock Write fd (fun _ -> Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 01c3d7940..272d4a20f 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin DECLARE PLUGIN "nsatz_plugin" diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 869284246..4271c80cd 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -652,7 +652,7 @@ let decompile af = (** Backward compat to emulate the old Refine: normalize the goal conclusion *) let new_hole env sigma c = - let c = Reductionops.nf_betaiota sigma c in + let c = Reductionops.nf_betaiota env sigma c in Evarutil.new_evar env sigma c let clever_rewrite_base_poly typ p result theorem = diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 735af6bab..f7b153a13 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -13,8 +13,6 @@ (* *) (**************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - DECLARE PLUGIN "omega_plugin" diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index f7ebd3204..40897d62f 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open Names open Misctypes diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 337510ef1..0f5417e7d 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -155,7 +155,7 @@ let mk_list univ typ l = loop l let mk_plist = - let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in + let type1lev = Universes.new_univ_level () in fun l -> mk_list type1lev mkProp l let mk_list = mk_list Univ.Level.set @@ -223,7 +223,7 @@ let mk_N = function module type Int = sig val typ : constr Lazy.t - val is_int_typ : [ `NF ] Proofview.Goal.t -> constr -> bool + val is_int_typ : Proofview.Goal.t -> constr -> bool val plus : constr Lazy.t val mult : constr Lazy.t val opp : constr Lazy.t @@ -231,7 +231,7 @@ module type Int = sig val mk : Bigint.bigint -> constr val parse_term : constr -> parse_term - val parse_rel : [ `NF ] Proofview.Goal.t -> constr -> parse_rel + val parse_rel : Proofview.Goal.t -> constr -> parse_rel (* check whether t is built only with numbers and + * - *) val get_scalar : constr -> Bigint.bigint option end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 5ba063d9d..ecddc55de 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -105,7 +105,7 @@ module type Int = (* the coq type of the numbers *) val typ : constr Lazy.t (* Is a constr expands to the type of these numbers *) - val is_int_typ : [ `NF ] Proofview.Goal.t -> constr -> bool + val is_int_typ : Proofview.Goal.t -> constr -> bool (* the operations on the numbers *) val plus : constr Lazy.t val mult : constr Lazy.t @@ -116,7 +116,7 @@ module type Int = (* parsing a term (one level, except if a number is found) *) val parse_term : constr -> parse_term (* parsing a relation expression, including = < <= >= > *) - val parse_rel : [ `NF ] Proofview.Goal.t -> constr -> parse_rel + val parse_rel : Proofview.Goal.t -> constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val get_scalar : constr -> Bigint.bigint option end diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 5fd9c9419..5b77d08de 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -6,8 +6,6 @@ *************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - DECLARE PLUGIN "romega_plugin" diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index bfa1e5f39..1bfcdc2fb 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -7,8 +7,6 @@ (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin DECLARE PLUGIN "rtauto_plugin" diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index a7d6d5bb2..b34d12952 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open Pp open Util diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index f22f00839..e3e749b75 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -152,7 +152,8 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na univs c = let open Constr in - let vars = Univops.universes_of_constr c in + let env = Global.env () in + let vars = Univops.universes_of_constr env c in let univs = Univops.restrict_universe_context univs vars in let univs = Monomorphic_const_entry univs in mkConst(declare_constant (Id.of_string na) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 047ca509b..499154d50 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -563,7 +563,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | _ -> Constr.fold put evlist c in let evlist = put [] c0 in if evlist = [] then 0, c0 else - let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in + let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (pf_env gl) (project gl) (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") (fun (k,_) -> Evar.print k) evlist)); let evplist = @@ -745,7 +745,7 @@ let discharge_hyp (id', (id, mode)) gl = let cl' = Vars.subst_var id (pf_concl gl) in match pf_get_hyp gl id, mode with | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> - Proofview.V82.of_tactic (Tactics.apply_type (EConstr.of_constr (mkProd (Name id', t, cl'))) + Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false (EConstr.of_constr (mkProd (Name id', t, cl'))) [EConstr.of_constr (mkVar id)]) gl | NamedDecl.LocalDef (_, v, t), _ -> Proofview.V82.of_tactic @@ -835,9 +835,9 @@ let rec mkCHoles ?loc n = if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ - CLambdaN ([[loc, name], Default Explicit, ty], t) + CLambdaN ([CLocalAssum([loc, name], Default Explicit, ty)], t) let mkCArrow ?loc ty t = CAst.make ?loc @@ - CProdN ([[Loc.tag Anonymous], Default Explicit, ty], t) + CProdN ([CLocalAssum([Loc.tag Anonymous], Default Explicit, ty)], t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, CastConv ty) let rec isCHoles = function { CAst.v = CHole _ } :: cl -> isCHoles cl | cl -> cl = [] @@ -855,7 +855,7 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = | _, (_, Some ty) -> let rec force_type ty = CAst.(map (function | CProdN (abs, t) -> - n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + n_binders := !n_binders + List.length (List.flatten (List.map (function CLocalAssum (nal,_,_) -> nal | CLocalDef (na,_,_) -> [na] | CLocalPattern (_,_) -> (* We count a 'pat for 1; TO BE CHECKED *) [Loc.tag Name.Anonymous]) abs)); 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 @@ -894,7 +894,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ let sigma = create_evar_defs sigma in let (sigma, x) = Evarutil.new_evar env sigma - (if bi_types then Reductionops.nf_betaiota sigma src else src) in + (if bi_types then Reductionops.nf_betaiota env sigma src else src) in loop (EConstr.Vars.subst1 x tgt) ((m - n,x) :: args) sigma (n-1) | CastType (t, _) -> loop t args sigma n | LetInType (_, v, _, t) -> loop (EConstr.Vars.subst1 v t) args sigma n @@ -1061,7 +1061,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; (** Basic tactics *) let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id | _ -> if red then Tacticals.New.tclZEROMSG (str"No product even after head-reduction.") @@ -1159,6 +1159,7 @@ let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = let (c, ucst), cl = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 with NoMatch -> redex_of_pattern env pat, (EConstr.Unsafe.to_constr cl) in + let gl = pf_merge_uc ucst gl in let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in @@ -1178,7 +1179,7 @@ let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match") -let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs) let genclrtac cl cs clr = let tclmyORELSE tac1 tac2 gl = diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 4e0b44a44..5782a7621 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -28,7 +28,7 @@ module RelDecl = Context.Rel.Declaration (** The "case" and "elim" tactic *) -let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs) (* TASSI: given the type of an elimination principle, it finds the higher order * argument (index), it computes it's arity and the arity of the eliminator and diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index bd9633afb..11ebe4337 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -143,14 +143,14 @@ let newssrcongrtac arg ist gl = (** Coq rewrite compatibility flag *) -let ssr_strict_match = ref false let _ = - Goptions.declare_bool_option + let ssr_strict_match = ref false in + Goptions.declare_bool_option { Goptions.optname = "strict redex matching"; Goptions.optkey = ["Match"; "Strict"]; Goptions.optread = (fun () -> !ssr_strict_match); - Goptions.optdepr = false; + Goptions.optdepr = true; (* noop *) Goptions.optwrite = (fun b -> ssr_strict_match := b) } (** Rewrite rules *) @@ -382,7 +382,7 @@ let is_construct_ref sigma c r = EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r -let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs) let rwcltac cl rdx dir sr gl = let n, r_n,_, ucst = pf_abs_evars gl sr in diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 6c325cce4..b3be31b7b 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -41,7 +41,7 @@ module RelDecl = Context.Rel.Declaration (* They require guessing the view hints and the number of *) (* implicits, respectively, which we do by brute force. *) -let apply_type x xs = Proofview.V82.of_tactic (apply_type x xs) +let apply_type x xs = Proofview.V82.of_tactic (apply_type ~typecheck:false x xs) let new_tac = Proofview.V82.of_tactic diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 46403aef3..211cad3f5 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1023,10 +1023,10 @@ let rec format_local_binders h0 bl0 = match h0, bl0 with | _ -> [] let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with - | BFvar :: h, { v = CLambdaN ([[_, x], _, _], c) } -> + | BFvar :: h, { v = CLambdaN ([CLocalAssum([_, x], _, _)], c) } -> let bs, c' = format_constr_expr h c in Bvar x :: bs, c' - | BFdecl _:: h, { v = CLambdaN ([lxs, _, t], c) } -> + | BFdecl _:: h, { v = CLambdaN ([CLocalAssum(lxs, _, t)], c) } -> let bs, c' = format_constr_expr h c in Bdecl (List.map snd lxs, t) :: bs, c' | BFdef :: h, { v = CLetIn((_, x), v, oty, c) } -> @@ -1165,20 +1165,20 @@ ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder | [ ssrbvar(bv) ] -> [ let xloc, _ as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([[x],Default Explicit,mkCHole xloc],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] | [ "(" ssrbvar(bv) ")" ] -> [ let xloc, _ as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([[x],Default Explicit,mkCHole xloc],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> [ let x = bvar_lname bv in (FwdPose, [BFdecl 1]), - CAst.make ~loc @@ CLambdaN ([[x], Default Explicit, t], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) ] | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> [ let xs = List.map bvar_lname (bv :: bvs) in let n = List.length xs in (FwdPose, [BFdecl n]), - CAst.make ~loc @@ CLambdaN ([xs, Default Explicit, t], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) ] | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) ] | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> @@ -1191,7 +1191,7 @@ GEXTEND Gram [ ["of" | "&"]; c = operconstr LEVEL "99" -> let loc = !@loc in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([[Loc.tag ~loc Anonymous],Default Explicit,c],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([Loc.tag ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) ] ]; END @@ -1217,7 +1217,7 @@ let push_binders c2 bs = | ct -> loop false ct bs let rec fix_binders = let open CAst in function - | (_, { v = CLambdaN ([xs, _, t], _) } ) :: bs -> + | (_, { v = CLambdaN ([CLocalAssum(xs, _, t)], _) } ) :: bs -> CLocalAssum (xs, Default Explicit, t) :: fix_binders bs | (_, { v = CLetIn (x, v, oty, _) } ) :: bs -> CLocalDef (x, v, oty) :: fix_binders bs @@ -1325,13 +1325,13 @@ let intro_id_to_binder = List.map (function | IPatId id -> let xloc, _ as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), - CAst.make @@ CLambdaN ([[x], Default Explicit, mkCHole xloc], + CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], mkCHole None) | _ -> anomaly "non-id accepted as binder") let binder_to_intro_id = CAst.(List.map (function - | (FwdPose, [BFvar]), { v = CLambdaN ([ids,_,_],_) } - | (FwdPose, [BFdecl _]), { v = CLambdaN ([ids,_,_],_) } -> + | (FwdPose, [BFvar]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } + | (FwdPose, [BFdecl _]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } -> List.map (function (_, Name id) -> IPatId id | _ -> IPatAnon One) ids | (FwdPose, [BFdef]), { v = CLetIn ((_,Name id),_,_,_) } -> [IPatId id] | (FwdPose, [BFdef]), { v = CLetIn ((_,Anonymous),_,_,_) } -> [IPatAnon One] diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 5e43c8374..6514b186e 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -122,7 +122,7 @@ let endclausestac id_map clseq gl_id cl0 gl = if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else CErrors.user_err (Pp.str "tampering with discharged assumptions of \"in\" tactical") -let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs) let tclCLAUSES ist tac (gens, clseq) gl = if clseq = InGoal || clseq = InSeqGoal then tac gl else diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 7385ed84c..25d1472f1 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -74,7 +74,7 @@ let frozen_lexer = CLexer.get_keyword_state () ;; let no_ct = None, None and no_rt = None in let aliasvar = function - | [_, [{ CAst.v = CPatAlias (_, id); loc }]] -> Some (loc,Name id) + | [[{ CAst.v = CPatAlias (_, na); loc }]] -> Some na | _ -> None in let mk_cnotype mp = aliasvar mp, None in let mk_ctype mp t = aliasvar mp, Some t in @@ -86,14 +86,14 @@ let mk_pat c (na, t) = (c, na, t) in GEXTEND Gram GLOBAL: binder_constr; ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; - ssr_mpat: [[ p = pattern -> [Loc.tag ~loc:!@loc [p]] ]]; + ssr_mpat: [[ p = pattern -> [[p]] ]]; ssr_dpat: [ [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt | mp = ssr_mpat -> mp, no_ct, no_rt ] ]; ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen ~loc:!@loc dp c ]]; - ssr_elsepat: [[ "else" -> [Loc.tag ~loc:!@loc [CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; + ssr_elsepat: [[ "else" -> [[CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; ssr_else: [[ mp = ssr_elsepat; c = lconstr -> Loc.tag ~loc:!@loc (mp, c) ]]; binder_constr: [ [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> @@ -298,7 +298,7 @@ let interp_search_notation ?loc tag okey = let rec sub () = function | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) | c -> - glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), x) sub () c in + glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in let _, npat = Patternops.pattern_of_glob_constr (sub () body) in Search.GlobSearchSubPattern npat @@ -551,9 +551,9 @@ GEXTEND Gram | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> let s = coerce_reference_to_id qid in - Vernacexpr.VernacDefinition - ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), - ((Loc.tag s),None),(d )) + Vernacexpr.VernacDefinition + ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), + ((Loc.tag (Name s)),None), d) ]]; END diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index e63a05b78..71e8b4ac4 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -12,9 +12,6 @@ * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; -(*i camlp4use: "pa_extend.cmo" i*) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Ltac_plugin open Names open Pp @@ -140,7 +137,7 @@ let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) let isGHole c = match DAst.get c with GHole _ -> true | _ -> false let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ - CLambdaN ([[Loc.tag ?loc name], Default Explicit, ty], t) + CLambdaN ([CLocalAssum([Loc.tag ?loc name], Default Explicit, ty)], t) let mkCLetIn ?loc name bo t = CAst.make ?loc @@ CLetIn ((Loc.tag ?loc name), bo, None, t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) @@ -919,7 +916,7 @@ let glob_cpattern gs p = | k, (v, Some t) as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else match t.CAst.v with - | CNotation("( _ in _ )", ([t1; t2], [], [])) -> + | CNotation("( _ in _ )", ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with | (r1, None), (r2, None) -> encode k "In" [r1;r2] | (r1, Some _), (r2, Some _) when isCVar t1 -> @@ -927,11 +924,11 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] | _ -> CErrors.anomaly (str"where are we?.") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation("( _ as _ )", ([t1; t2], [], [])) -> + | CNotation("( _ as _ )", ([t1; t2], [], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; @@ -1228,7 +1225,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in sigma, [pat] in match pattern with - | None -> do_subst env0 concl0 concl0 1 + | None -> do_subst env0 concl0 concl0 1, Evd.empty_evar_universe_context | Some (sigma, (T rp | In_T rp)) -> let rp = fs sigma rp in let ise = create_evar_defs sigma in @@ -1236,8 +1233,8 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in let concl = find_T env0 concl0 1 ~k:do_subst in - let _ = end_T () in - concl + let _, _, (_, us, _) = end_T () in + concl, us | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> let p = fs sigma p in let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in @@ -1252,8 +1249,8 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h ~k:(fun env _ -> do_subst env e_body))) in - let _ = end_X () in let _ = end_T () in - concl + let _ = end_X () in let _, _, (_, us, _) = end_T () in + concl, us | Some (sigma, E_In_X_In_T (e, hole, p)) -> let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in @@ -1268,8 +1265,9 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h ~k:(fun env c _ h -> find_E env e_body h ~k:do_subst))) in - let _ = end_E () in let _ = end_X () in let _ = end_T () in - concl + let _,_,(_,us,_) = end_E () in + let _ = end_X () in let _ = end_T () in + concl, us | Some (sigma, E_As_X_In_T (e, hole, p)) -> let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in @@ -1287,8 +1285,8 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let e_sigma = unify_HO env sigma (EConstr.of_constr e_body) (EConstr.of_constr e) in let e_body = fs e_sigma e in do_subst env e_body e_body h))) in - let _ = end_X () in let _ = end_TE () in - concl + let _ = end_X () in let _,_,(_,us,_) = end_TE () in + concl, us ;; let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = @@ -1306,12 +1304,14 @@ let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = let find_R, conclude = let r = ref None in (fun env c _ h' -> - do_once r (fun () -> c, Evd.empty_evar_universe_context); + do_once r (fun () -> c); if do_make_rel then mkRel (h'+h-1) else c), - (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in - let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in + (fun _ -> if !r = None then fst(redex_of_pattern env pat) + else assert_done r) in + let cl, us = + eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in let e = conclude cl in - e, cl + (e, us), cl ;; (* clenup interface for external use *) @@ -1319,6 +1319,10 @@ let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = mk_tpattern ?p_origin env sigma0 sigma_t f dir c ;; +let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = + fst (eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst) +;; + let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let p = EConstr.Unsafe.to_constr p in let concl = EConstr.Unsafe.to_constr concl in diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index d59102b6c..8ac471404 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -40,16 +40,10 @@ let subst_rename_args (subst, (_, (r, names as orig))) = let r' = fst (subst_global subst r) in if r==r' then orig else (r', names) -let section_segment_of_reference = function - | ConstRef con -> Lib.section_segment_of_constant con - | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - Lib.section_segment_of_mutual_inductive kn - | _ -> [], Univ.LMap.empty, Univ.AUContext.empty - let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try - let vars,_,_ = section_segment_of_reference c in + let vars = Lib.variable_section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 4f3669a2b..a0434f927 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -450,11 +450,6 @@ let current_pattern eqn = | pat::_ -> pat | [] -> anomaly (Pp.str "Empty list of patterns.") -let alias_of_pat = DAst.with_val (function - | PatVar name -> name - | PatCstr(_,_,name) -> name - ) - let remove_current_pattern eqn = match eqn.patterns with | pat::pats -> @@ -1276,7 +1271,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* This is a bit too strong I think, in the sense that what we would *) (* really like is to have beta-iota reduction only at the positions where *) (* parameters are substituted *) - let typs = List.map (map_type (nf_betaiota !(pb.evdref))) typs in + let typs = List.map (map_type (nf_betaiota pb.env !(pb.evdref))) typs in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) @@ -1426,7 +1421,7 @@ and match_current pb (initial,tomatch) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in let ci = make_case_info pb.env (fst mind) pb.casestyle in - let pred = nf_betaiota !(pb.evdref) pred in + let pred = nf_betaiota pb.env !(pb.evdref) pred in let case = make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals in @@ -1566,11 +1561,9 @@ substituer après par les initiaux *) (* builds the matrix of equations testing that each eqn has n patterns * and linearizing the _ patterns. - * Syntactic correctness has already been done in astterm *) + * Syntactic correctness has already been done in constrintern *) let matx_of_eqns env eqns = - let build_eqn (loc,(ids,lpat,rhs)) = - let initial_lpat,initial_rhs = lpat,rhs in - let initial_rhs = rhs in + let build_eqn (loc,(ids,initial_lpat,initial_rhs)) = let avoid = ids_of_named_context_val (named_context_val env) in let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in let rhs = @@ -1665,7 +1658,7 @@ let rec list_assoc_in_triple x = function *) let abstract_tycon ?loc env evdref subst tycon extenv t = - let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*) + let t = nf_betaiota env !evdref t in (* it helps in some cases to remove K-redex*) let src = match EConstr.kind !evdref t with | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar evk) | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 192eca63b..e42576d95 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -171,7 +171,7 @@ let fixp_reducible flgs ((reci,i),_) stk = let cofixp_reducible flgs _ stk = if red_set flgs fCOFIX then match stk with - | (CASE _ | APP(_,CASE _)) -> true + | (CASE _ | PROJ _ | APP(_,CASE _) | APP(_,PROJ _)) -> true | _ -> false else false diff --git a/pretyping/classops.ml b/pretyping/classops.ml index c36630f5d..6d5ee504e 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -322,16 +322,16 @@ let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) -let path_printer = ref (fun _ -> str "<a class path>" - : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) +let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = + ref (fun _ _ _ -> str "<a class path>") let install_path_printer f = path_printer := f -let print_path x = !path_printer x +let print_path env sigma x = !path_printer env sigma x -let message_ambig l = - (str"Ambiguous paths:" ++ spc () ++ - prlist_with_sep fnl (fun ijp -> print_path ijp) l) +let message_ambig env sigma l = + str"Ambiguous paths:" ++ spc () ++ + prlist_with_sep fnl (fun ijp -> print_path env sigma ijp) l (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -344,8 +344,8 @@ let different_class_params i = | CL_IND i -> Global.is_polymorphic (IndRef i) | CL_CONST c -> Global.is_polymorphic (ConstRef c) | _ -> false - -let add_coercion_in_graph (ic,source,target) = + +let add_coercion_in_graph env sigma (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in @@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) = end; let is_ambig = match !ambig_paths with [] -> false | _ -> true in if is_ambig && not !Flags.quiet then - Feedback.msg_info (message_ambig !ambig_paths) + Feedback.msg_info (message_ambig env sigma !ambig_paths) type coercion = { coercion_type : coe_typ; @@ -433,13 +433,13 @@ let _ = optread = (fun () -> !automatically_import_coercions); optwrite = (:=) automatically_import_coercions } -let cache_coercion (_, c) = +let cache_coercion env sigma (_, c) = let () = add_class c.coercion_source in let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in - let typ = Retyping.get_type_of (Global.env ()) Evd.empty (EConstr.of_constr value) in + let value, ctx = Universes.fresh_global_instance env c.coercion_type in + let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in let typ = EConstr.Unsafe.to_constr typ in let xf = { coe_value = value; @@ -450,15 +450,15 @@ let cache_coercion (_, c) = coe_is_projection = c.coercion_is_proj; coe_param = c.coercion_params } in let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph (xf,is,it) + add_coercion_in_graph env sigma (xf,is,it) let load_coercion _ o = if !automatically_import_coercions then - cache_coercion o + cache_coercion (Global.env ()) Evd.empty o let open_coercion i o = if Int.equal i 1 && not !automatically_import_coercions then - cache_coercion o + cache_coercion (Global.env ()) Evd.empty o let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in @@ -497,7 +497,9 @@ let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with open_function = open_coercion; load_function = load_coercion; - cache_function = cache_coercion; + cache_function = (fun objn -> + let env = Global.env () in cache_coercion env Evd.empty objn + ); subst_function = subst_coercion; classify_function = classify_coercion; discharge_function = discharge_coercion } diff --git a/pretyping/classops.mli b/pretyping/classops.mli index b41d0efac..47b41f17b 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -96,7 +96,7 @@ val lookup_pattern_path_between : (**/**) (* Crade *) val install_path_printer : - ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit + (env -> evar_map -> (cl_index * cl_index) * inheritance_path -> Pp.t) -> unit (**/**) (** {6 This is for printing purpose } *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 20ef65c88..c3a221944 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -13,7 +13,6 @@ open Util open Names open Globnames open Termops -open Reductionops open Term open EConstr open Vars @@ -207,7 +206,7 @@ let merge_binding sigma allow_bound_rels ctx n cT subst = in constrain sigma n c subst -let matches_core env sigma convert allow_partial_app allow_bound_rels +let matches_core env sigma allow_bound_rels (binding_vars,pat) c = let open EConstr in let convref ref c = @@ -216,11 +215,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | ConstRef c, Const (c',_) -> Constant.equal c c' | IndRef i, Ind (i', _) -> Names.eq_ind i i' | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' - | _, _ -> - (if convert then - let sigma,c' = Evd.fresh_global env sigma ref in - is_conv env sigma (EConstr.of_constr c') c - else false) + | _, _ -> false in let rec sorec ctx env subst p t = let cT = strip_outer_cast sigma t in @@ -265,7 +260,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PApp (PApp (h, a1), a2), _ -> sorec ctx env subst (PApp(h,Array.append a1 a2)) t - | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app -> + | PApp (PMeta meta,args1), App (c2,args2) -> (let diff = Array.length args2 - Array.length args1 in if diff >= 0 then let args21, args22 = Array.chop diff args2 in @@ -378,14 +373,14 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels in sorec [] env (Id.Map.empty, Id.Map.empty) pat c -let matches_core_closed env sigma convert allow_partial_app pat c = - let names, subst = matches_core env sigma convert allow_partial_app false pat c in +let matches_core_closed env sigma pat c = + let names, subst = matches_core env sigma false pat c in (names, Id.Map.map snd subst) -let extended_matches env sigma = matches_core env sigma false true true +let extended_matches env sigma = matches_core env sigma true let matches env sigma pat c = - snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c) + snd (matches_core_closed env sigma (Id.Set.empty,pat) c) let special_meta = (-1) @@ -410,9 +405,9 @@ let matches_head env sigma pat c = matches env sigma pat head (* Tells if it is an authorized occurrence and if the instance is closed *) -let authorized_occ env sigma partial_app closed pat c mk_ctx = +let authorized_occ env sigma closed pat c mk_ctx = try - let subst = matches_core_closed env sigma false partial_app pat c in + let subst = matches_core_closed env sigma pat c in if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst) then (fun next -> next ()) else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next) @@ -421,10 +416,10 @@ let authorized_occ env sigma partial_app closed pat c mk_ctx = let subargs env v = Array.map_to_list (fun c -> (env, c)) v (* Tries to match a subterm of [c] with [pat] *) -let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = +let sub_match ?(closed=true) env sigma pat c = let open EConstr in let rec aux env c mk_ctx next = - let here = authorized_occ env sigma partial_app closed pat c mk_ctx in + let here = authorized_occ env sigma closed pat c mk_ctx in let next () = match EConstr.kind sigma c with | Cast (c1,k,c2) -> let next_mk_ctx = function @@ -454,34 +449,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let env' = EConstr.push_rel (LocalDef (x,c1,t)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> - let topdown = true in - if partial_app then - if topdown then - let lc1 = Array.sub lc 0 (Array.length lc - 1) in - let app = mkApp (c1,lc1) in - let mk_ctx = function - | [app';c] -> mk_ctx (mkApp (app',[|c|])) - | _ -> assert false in - try_aux [(env, app); (env, Array.last lc)] mk_ctx next - else - let rec aux2 app args next = - match args with - | [] -> - let mk_ctx le = - mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in - let sub = (env, c1) :: subargs env lc in - try_aux sub mk_ctx next - | arg :: args -> - let app = mkApp (app,[|arg|]) in - let next () = aux2 app args next in - let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in - aux env app mk_ctx next in - aux2 c1 (Array.to_list lc) next - else - let mk_ctx le = - mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in - let sub = (env, c1) :: subargs env lc in - try_aux sub mk_ctx next + let lc1 = Array.sub lc 0 (Array.length lc - 1) in + let app = mkApp (c1,lc1) in + let mk_ctx = function + | [app';c] -> mk_ctx (mkApp (app',[|c|])) + | _ -> assert false in + try_aux [(env, app); (env, Array.last lc)] mk_ctx next | Case (ci,hd,c1,lc) -> let next_mk_ctx = function | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) @@ -489,29 +462,28 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = in let sub = (env, c1) :: (env, hd) :: subargs env lc in try_aux sub next_mk_ctx next - | Fix (indx,(names,types,bodies)) -> + | Fix (indx,(names,types,bodies as recdefs)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkFix (indx,(names, Array.of_list ntypes, Array.of_list nbodies))) in - let sub = subargs env types @ subargs env bodies in + let env' = push_rec_types recdefs env in + let sub = subargs env types @ subargs env' bodies in try_aux sub next_mk_ctx next - | CoFix (i,(names,types,bodies)) -> + | CoFix (i,(names,types,bodies as recdefs)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkCoFix (i,(names, Array.of_list ntypes, Array.of_list nbodies))) in - let sub = subargs env types @ subargs env bodies in + let env' = push_rec_types recdefs env in + let sub = subargs env types @ subargs env' bodies in try_aux sub next_mk_ctx next | Proj (p,c') -> - let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in - if partial_app then - try - let term = Retyping.expand_projection env sigma p c' [] in - aux env term mk_ctx next - with Retyping.RetypeError _ -> next () - else - try_aux [env, c'] next_mk_ctx next + begin try + let term = Retyping.expand_projection env sigma p c' [] in + aux env term mk_ctx next + with Retyping.RetypeError _ -> next () + end | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> next () in @@ -532,13 +504,7 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let result () = aux env c (fun x -> x) lempty in IStream.thunk result -let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c - -let match_appsubterm env sigma pat c = - sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c - -let match_subterm_gen env sigma app pat c = - sub_match ~partial_app:app env sigma pat c +let match_subterm env sigma pat c = sub_match env sigma pat c let is_matching env sigma pat c = try let _ = matches env sigma pat c in true @@ -550,12 +516,5 @@ let is_matching_head env sigma pat c = let is_matching_appsubterm ?(closed=true) env sigma pat c = let pat = (Id.Set.empty,pat) in - let results = sub_match ~partial_app:true ~closed env sigma pat c in + let results = sub_match ~closed env sigma pat c in not (IStream.is_empty results) - -let matches_conv env sigma p c = - snd (matches_core_closed env sigma true false (Id.Set.empty,p) c) - -let is_matching_conv env sigma pat n = - try let _ = matches_conv env sigma pat n in true - with PatternMatchingFailure -> false diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 780ccc23d..e4d9ff9e1 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -55,38 +55,19 @@ val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool prefix of it matches against [pat] *) val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool -(** [matches_conv env sigma] matches up to conversion in environment - [(env,sigma)] when constants in pattern are concerned; it raises - [PatternMatchingFailure] if not matchable; bindings are given in - increasing order based on the numbers given in the pattern *) -val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map - (** The type of subterm matching results: a substitution + a context (whose hole is denoted here with [special_meta]) *) type matching_result = { m_sub : bound_ident_map * patvar_map; m_ctx : EConstr.t } -(** [match_subterm n pat c] returns the substitution and the context - corresponding to each **closed** subterm of [c] matching [pat]. *) -val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t - -(** [match_appsubterm pat c] returns the substitution and the context +(** [match_subterm pat c] returns the substitution and the context corresponding to each **closed** subterm of [c] matching [pat], considering application contexts as well. *) -val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t - -(** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) -val match_subterm_gen : env -> Evd.evar_map -> - bool (** true = with app context *) -> +val match_subterm : env -> Evd.evar_map -> binding_bound_vars * constr_pattern -> constr -> matching_result IStream.t (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches against [pat] taking partial subterms into consideration *) val is_matching_appsubterm : ?closed:bool -> env -> Evd.evar_map -> constr_pattern -> constr -> bool - -(** [is_matching_conv env sigma pat c] tells if [c] matches against [pat] - up to conversion for constants in patterns *) -val is_matching_conv : - env -> Evd.evar_map -> constr_pattern -> constr -> bool diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 0d1e401d9..18ecbf8ed 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -252,6 +252,89 @@ let lookup_index_as_renamed env sigma t n = in lookup n 1 t (**********************************************************************) +(* Factorization of match patterns *) + +let print_factorize_match_patterns = ref true + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "factorization of \"match\" patterns in printing"; + optkey = ["Printing";"Factorizable";"Match";"Patterns"]; + optread = (fun () -> !print_factorize_match_patterns); + optwrite = (fun b -> print_factorize_match_patterns := b) } + +let print_allow_match_default_clause = ref true + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "possible use of \"match\" default pattern in printing"; + optkey = ["Printing";"Allow";"Match";"Default";"Clause"]; + optread = (fun () -> !print_allow_match_default_clause); + optwrite = (fun b -> print_allow_match_default_clause := b) } + +let rec join_eqns (ids,rhs as x) patll = function + | (loc,(ids',patl',rhs') as eqn')::rest -> + if not !Flags.raw_print && !print_factorize_match_patterns && + List.eq_set Id.equal ids ids' && glob_constr_eq rhs rhs' + then + join_eqns x (patl'::patll) rest + else + let eqn,rest = join_eqns x patll rest in + eqn, eqn'::rest + | [] -> + patll, [] + +let number_of_patterns (_gloc,(_ids,patll,_rhs)) = List.length patll + +let is_default_candidate (_gloc,(ids,_patll,_rhs) ) = ids = [] + +let rec move_more_factorized_default_candidate_to_end eqn n = function + | eqn' :: eqns -> + let set,get = set_temporary_memory () in + if is_default_candidate eqn' && set (number_of_patterns eqn') >= n then + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn' (get ()) eqns in + if isbest then false, dft, eqns else false, dft, eqn' :: eqns + else + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn n eqns in + isbest, dft, eqn' :: eqns + | [] -> true, Some eqn, [] + +let rec select_default_clause = function + | eqn :: eqns -> + let set,get = set_temporary_memory () in + if is_default_candidate eqn && set (number_of_patterns eqn) > 1 then + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn (get ()) eqns in + if isbest then dft, eqns else dft, eqn :: eqns + else + let dft, eqns = select_default_clause eqns in dft, eqn :: eqns + | [] -> None, [] + +let factorize_eqns eqns = + let rec aux found = function + | (loc,(ids,patl,rhs))::rest -> + let patll,rest = join_eqns (ids,rhs) [patl] rest in + aux ((loc,(ids,patll,rhs))::found) rest + | [] -> + found in + let eqns = aux [] (List.rev eqns) in + let mk_anon patl = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl in + if not !Flags.raw_print && !print_allow_match_default_clause && eqns <> [] then + match select_default_clause eqns with + (* At least two clauses and the last one is disjunctive with no variables *) + | Some (gloc,([],patl::_::_,rhs)), (_::_ as eqns) -> eqns@[gloc,([],[mk_anon patl],rhs)] + (* Only one clause which is disjunctive with no variables: we keep at least one constructor *) + (* so that it is not interpreted as a dummy "match" *) + | Some (gloc,([],patl::patl'::_,rhs)), [] -> [gloc,([],[patl;mk_anon patl'],rhs)] + | Some (_,((_::_,_,_ | _,([]|[_]),_))), _ -> assert false + | None, eqns -> eqns + else + eqns + +(**********************************************************************) (* Fragile algorithm to reverse pattern-matching compilation *) let update_name sigma na ((_,(e,_)),c) = @@ -284,13 +367,12 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = let rec build_tree na isgoal e sigma ci cl = let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in let cnl = ci.ci_pp_info.cstr_tags in - let cna = ci.ci_cstr_nargs in List.flatten (List.init (Array.length cl) - (fun i -> contract_branch isgoal e sigma (cnl.(i),cna.(i),mkpat i,cl.(i)))) + (fun i -> contract_branch isgoal e sigma (cnl.(i),mkpat i,cl.(i)))) and align_tree nal isgoal (e,c as rhs) sigma = match nal with - | [] -> [[],rhs] + | [] -> [Id.Set.empty,[],rhs] | na::nal -> match EConstr.kind sigma c with | Case (ci,p,c,cl) when @@ -300,19 +382,20 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> let clauses = build_tree na isgoal e sigma ci cl in List.flatten - (List.map (fun (pat,rhs) -> + (List.map (fun (ids,pat,rhs) -> let lines = align_tree nal isgoal rhs sigma in - List.map (fun (hd,rest) -> pat::hd,rest) lines) + List.map (fun (ids',hd,rest) -> Id.Set.fold Id.Set.add ids ids',pat::hd,rest) lines) clauses) | _ -> - let pat = DAst.make @@ PatVar(update_name sigma na rhs) in - let mat = align_tree nal isgoal rhs sigma in - List.map (fun (hd,rest) -> pat::hd,rest) mat + let na = update_name sigma na rhs in + let pat = DAst.make @@ PatVar na in + let mat = align_tree nal isgoal rhs sigma in + List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat -and contract_branch isgoal e sigma (cdn,can,mkpat,b) = - let nal,rhs = decomp_branch cdn [] isgoal e sigma b in +and contract_branch isgoal e sigma (cdn,mkpat,rhs) = + let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in - List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat + List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat (**********************************************************************) (* Transform internal representation of pattern-matching into list of *) @@ -368,17 +451,15 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = then Anonymous, None, None else - match Option.map detype p with - | None -> Anonymous, None, None - | Some p -> - let nl,typ = it_destRLambda_or_LetIn_names k p in - let n,typ = match DAst.get typ with - | GLambda (x,_,t,c) -> x, c - | _ -> Anonymous, typ in - let aliastyp = - if List.for_all (Name.equal Anonymous) nl then None - else Some (Loc.tag (indsp,nl)) in - n, aliastyp, Some typ + let p = detype p in + let nl,typ = it_destRLambda_or_LetIn_names k p in + let n,typ = match DAst.get typ with + | GLambda (x,_,t,c) -> x, c + | _ -> Anonymous, typ in + let aliastyp = + if List.for_all (Name.equal Anonymous) nl then None + else Some (Loc.tag (indsp,nl)) in + n, aliastyp, Some typ in let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in let tag = @@ -414,15 +495,17 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = let eqnl = detype_eqns constructs constagsl bl in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) +let detype_universe sigma u = + let fn (l, n) = Some (Termops.reference_of_level sigma l, n) in + Univ.Universe.map fn u + let detype_sort sigma = function | Prop Null -> GProp | Prop Pos -> GSet | Type u -> GType (if !print_universes - then - let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in - [Loc.tag @@ Name.mk_name (Id.of_string_soft u)] + then detype_universe sigma u else []) type binder_kind = BProd | BLambda | BLetIn @@ -434,8 +517,8 @@ let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in - GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l))) + let l = Termops.reference_of_level sigma l in + GType (UNamed l) let detype_instance sigma l = let l = EInstance.kind sigma l in @@ -496,12 +579,7 @@ and detype_r d flags avoid env sigma t = | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = - let pb = Environ.lookup_projection p (snd env) in - let pars = pb.Declarations.proj_npars in - let hole = DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in - let args = List.make pars hole in - GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), - (args @ [detype d flags avoid env sigma c])) + GProj (p, detype d flags avoid env sigma c) in if fst flags || !Flags.in_debugger || !Flags.in_toplevel then try noparams () @@ -570,7 +648,7 @@ and detype_r d flags avoid env sigma t = (is_nondep_branch sigma) avoid (ci.ci_ind,ci.ci_pp_info.style, ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) - (Some p) c bl + p c bl | Fix (nvn,recdef) -> detype_fix d flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix d flags avoid env sigma n recdef @@ -646,7 +724,7 @@ and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in - List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype d flags avoid env sigma c)) + List.map (fun (ids,pat,((avoid,env),c)) -> Loc.tag (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> Array.to_list @@ -917,6 +995,13 @@ let rec subst_glob_constr subst = DAst.map (function let r1' = subst_glob_constr subst r1 in let k' = Miscops.smartmap_cast_type (subst_glob_constr subst) k in if r1' == r1 && k' == k then raw else GCast (r1',k') + + | GProj (p,c) as raw -> + let kn = Projection.constant p in + let b = Projection.unfolded p in + let kn' = subst_constant subst kn in + let c' = subst_glob_constr subst c in + if kn' == kn && c' == c then raw else GProj(Projection.make kn' b, c') ) (* Utilities to transform kernel cases to simple pattern-matching problem *) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index cb1c0d8d4..f150cb195 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -26,10 +26,20 @@ val print_universes : bool ref (** If true, prints full local context of evars *) val print_evar_arguments : bool ref +(** If true, contract branches with same r.h.s. and same matching + variables in a disjunctive pattern *) +val print_factorize_match_patterns : bool ref + +(** If true and the last non unique clause of a "match" is a + variable-free disjunctive pattern, turn it into a catch-call case *) +val print_allow_match_default_clause : bool ref + val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern val subst_glob_constr : substitution -> glob_constr -> glob_constr +val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g + (** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr de Bruijn indexes are turned to bound names, avoiding names in [avoid] [isgoal] tells if naming must avoid global-level synonyms as intro does diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 18e0c31dd..dc3acbc3e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -218,6 +218,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let t' = EConstr.of_constr t' in let t' = subst_univs_level_constr subst t' in let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in + let params = List.map (fun c -> subst_univs_level_constr subst c) params in + let us = List.map (fun c -> subst_univs_level_constr subst c) us in let h, _ = decompose_app_vect sigma t' in ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, @@ -274,11 +276,6 @@ let rec ise_app_stack2 env f evd sk1 sk2 = end | _, _ -> (sk1,sk2), Success evd -let push_rec_types pfix env = - let (i, c, t) = pfix in - let inj c = EConstr.Unsafe.to_constr c in - push_rec_types (i, Array.map inj c, Array.map inj t) env - (* 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 @@ -310,8 +307,6 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i' -> ise_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x else fail (UnifFailure (i,NotSameHead)) - | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _ - | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false | 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 @@ -344,8 +339,6 @@ let exact_ise_stack2 env evd f sk1 sk2 = if Constant.equal (Projection.constant p1) (Projection.constant p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) - | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _ - | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false | Stack.App _ :: _, Stack.App _ :: _ -> begin match ise_app_stack2 env f i sk1 sk2 with |_,(UnifFailure _ as x) -> x @@ -360,19 +353,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = let check_leq_inductives evd cumi u u' = let u = EConstr.EInstance.kind evd u in let u' = EConstr.EInstance.kind evd u' in - let length_ind_instance = - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) - in - let ind_sbcst = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((length_ind_instance = Univ.Instance.length u) && - (length_ind_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - begin - let comp_subst = (Univ.Instance.append u u') in - let comp_cst = Univ.AUContext.instantiate comp_subst ind_sbcst in - Evd.add_constraints evd comp_cst - end + Evd.add_constraints evd (Reduction.get_cumulativity_constraints CUMUL cumi u u') let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in @@ -457,7 +438,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd - (Stack.zip evd (term', sk' @ [Stack.Shift 1]), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), + (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x ts env' evd CONV out1 out2 else evar_eqappr_x ts env' evd CONV out2 out1 @@ -1046,7 +1027,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with - | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> + | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Declarations.BiFinite -> let pars = mib.Declarations.mind_nparams in (try let l1' = Stack.tail pars sk1 in @@ -1067,8 +1048,8 @@ let evar_conv_x ts = evar_conv_x (ts, true) (* Profiling *) let evar_conv_x = if Flags.profile then - let evar_conv_xkey = Profile.declare_profile "evar_conv_x" in - Profile.profile6 evar_conv_xkey evar_conv_x + let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in + CProfile.profile6 evar_conv_xkey evar_conv_x else evar_conv_x let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index b646a37f8..fd83795f5 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -28,8 +28,8 @@ let env_nf_evar sigma env = let env_nf_betaiotaevar sigma env = process_rel_context - (fun d e -> - push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota sigma c) d) e) env + (fun d env -> + push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota env sigma c) d) env) env (****************************************) (* Operations on value/type constraints *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 093f1f0b6..25817478e 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -19,6 +19,16 @@ open Ltac_pretype let cases_pattern_loc c = c.CAst.loc +let alias_of_pat pat = DAst.with_val (function + | PatVar name -> name + | PatCstr(_,_,name) -> name + ) pat + +let set_pat_alias id = DAst.map (function + | PatVar Anonymous -> PatVar (Name id) + | PatCstr (cstr,patl,Anonymous) -> PatCstr (cstr,patl,Name id) + | pat -> assert false) + let cases_predicate_names tml = List.flatten (List.map (function | (tm,(na,None)) -> [na] @@ -133,8 +143,10 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with Miscops.intro_pattern_naming_eq nam1 nam2 | GCast (c1, t1), GCast (c2, t2) -> f c1 c2 && cast_type_eq f t1 t2 + | GProj (p1, t1), GProj (p2, t2) -> + Projection.equal p1 p2 && f t1 t2 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | - GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _), _ -> false + GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | GProj _), _ -> false let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c @@ -180,6 +192,8 @@ let map_glob_constr_left_to_right f = DAst.map (function let comp1 = f c in let comp2 = Miscops.map_cast_type f k in GCast (comp1,comp2) + | GProj (p,c) -> + GProj (p, f c) | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x ) @@ -212,6 +226,8 @@ let fold_glob_constr f acc = DAst.with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in f acc c + | GProj(_,c) -> + f acc c | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc ) @@ -253,6 +269,8 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in f v acc c + | GProj(_,c) -> + f v acc c | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc)) let iter_glob_constr f = fold_glob_constr (fun () -> f) () @@ -444,6 +462,10 @@ let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function (**********************************************************************) (* Conversion from glob_constr to cases pattern, if possible *) +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + let rec cases_pattern_of_glob_constr na = DAst.map (function | GVar id -> begin match na with @@ -460,6 +482,9 @@ let rec cases_pattern_of_glob_constr na = DAst.map (function PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found end + | GLetIn (Name id as na',b,None,e) when is_gvar id e && na = Anonymous -> + (* A canonical encoding of aliases *) + DAst.get (cases_pattern_of_glob_constr na' b) | _ -> raise Not_found ) @@ -495,23 +520,34 @@ let add_patterns_for_params_remove_local_defs (ind,j) l = drop_local_defs typi l in Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l +let add_alias ?loc na c = + match na with + | Anonymous -> c + | Name id -> GLetIn (na,DAst.make ?loc c,None,DAst.make ?loc (GVar id)) + (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_closed_cases_pattern_aux x = DAst.map_with_loc (fun ?loc -> function - | PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None) - | PatCstr (cstr,l,Anonymous) -> +let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?loc -> function + | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (ConstructRef cstr,None)) + | PatCstr (cstr,l,na) -> let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in let l = add_patterns_for_params_remove_local_defs cstr l in - GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l) + add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux isclosed) l)) + | PatVar (Name id) when not isclosed -> + GVar id + | PatVar Anonymous when not isclosed -> + GHole (Evar_kinds.QuestionMark (Define false,Anonymous),Misctypes.IntroAnonymous,None) | _ -> raise Not_found ) x let glob_constr_of_closed_cases_pattern p = match DAst.get p with | PatCstr (cstr,l,na) -> let loc = p.CAst.loc in - na,glob_constr_of_closed_cases_pattern_aux (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) + na,glob_constr_of_cases_pattern_aux true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found +let glob_constr_of_cases_pattern p = glob_constr_of_cases_pattern_aux false p + (**********************************************************************) (* Interpreting ltac variables *) diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 9dd7068cb..0d9fb1f45 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -13,6 +13,10 @@ open Glob_term val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool +val alias_of_pat : 'a cases_pattern_g -> Name.t + +val set_pat_alias : Id.t -> 'a cases_pattern_g -> 'a cases_pattern_g + val cast_type_eq : ('a -> 'a -> bool) -> 'a Misctypes.cast_type -> 'a Misctypes.cast_type -> bool @@ -78,10 +82,14 @@ val map_pattern : (glob_constr -> glob_constr) -> Take the current alias as parameter, @raise Not_found if translation is impossible *) -val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern +val cases_pattern_of_glob_constr : Name.t -> 'a glob_constr_g -> 'a cases_pattern_g val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob_constr_g +(** A canonical encoding of cases pattern into constr such that + composed with [cases_pattern_of_glob_constr Anonymous] gives identity *) +val glob_constr_of_cases_pattern : 'a cases_pattern_g -> 'a glob_constr_g + val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list val ltac_interp_name : Ltac_pretype.ltac_var_map -> Name.t -> Name.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 34df7d3d7..275a079d5 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -84,7 +84,7 @@ let mis_is_recursive_subset listind rarg = List.exists (fun ra -> match dest_recarg ra with - | Mrec (_,i) -> Int.List.mem i listind + | Mrec (_,i) -> Int.List.mem i listind | _ -> false) rvec in Array.exists one_is_rec (dest_subterms rarg) @@ -275,7 +275,7 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p let has_dependent_elim mib = match mib.mind_record with - | Some (Some _) -> mib.mind_finite == Decl_kinds.BiFinite + | Some (Some _) -> mib.mind_finite == BiFinite | _ -> true (* Annotation for cases *) @@ -361,20 +361,20 @@ let make_case_or_project env sigma indf ci pred c branches = if (* dependent *) not (Vars.noccurn sigma 1 t) && not (has_dependent_elim mib) then user_err ~hdr:"make_case_or_project" - Pp.(str"Dependent case analysis not allowed" ++ - str" on inductive type " ++ Names.MutInd.print (fst ind)) + Pp.(str"Dependent case analysis not allowed" ++ + str" on inductive type " ++ Names.MutInd.print (fst ind)) in let branch = branches.(0) in let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in let n, subst = List.fold_right (fun decl (i, subst) -> - match decl with - | LocalAssum (na, t) -> - let t = mkProj (Projection.make ps.(i) true, c) in - (i + 1, t :: subst) - | LocalDef (na, b, t) -> (i, Vars.substl subst b :: subst)) - ctx (0, []) + match decl with + | LocalAssum (na, t) -> + let t = mkProj (Projection.make ps.(i) true, c) in + (i + 1, t :: subst) + | LocalDef (na, b, t) -> (i, Vars.substl subst b :: subst)) + ctx (0, []) in Vars.substl subst br (* substitution in a signature *) @@ -486,7 +486,7 @@ let find_inductive env sigma c = let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind ind - when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> CoFinite -> let l = List.map EConstr.Unsafe.to_constr l in (ind, l) | _ -> raise Not_found @@ -496,7 +496,7 @@ let find_coinductive env sigma c = let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind ind - when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == CoFinite -> let l = List.map EConstr.Unsafe.to_constr l in (ind, l) | _ -> raise Not_found @@ -511,25 +511,25 @@ let is_predicate_explicitly_dep env sigma pred arsign = let pv' = whd_all env sigma pval in match EConstr.kind sigma pv', arsign with | Lambda (na,t,b), (LocalAssum _)::arsign -> - srec (push_rel_assum (na, t) env) b arsign + srec (push_rel_assum (na, t) env) b arsign | Lambda (na,_,t), _ -> (* The following code has an impact on the introduction names - given by the tactics "case" and "inversion": when the - elimination is not dependent, "case" uses Anonymous for - inductive types in Prop and names created by mkProd_name for - inductive types in Set/Type while "inversion" uses anonymous - for inductive types both in Prop and Set/Type !! - - Previously, whether names were created or not relied on - whether the predicate created in Indrec.make_case_com had a - dependent arity or not. To avoid different predicates - printed the same in v8, all predicates built in indrec.ml - got a dependent arity (Aug 2004). The new way to decide - whether names have to be created or not is to use an - Anonymous or Named variable to enforce the expected - dependency status (of course, Anonymous implies non - dependent, but not conversely). + given by the tactics "case" and "inversion": when the + elimination is not dependent, "case" uses Anonymous for + inductive types in Prop and names created by mkProd_name for + inductive types in Set/Type while "inversion" uses anonymous + for inductive types both in Prop and Set/Type !! + + Previously, whether names were created or not relied on + whether the predicate created in Indrec.make_case_com had a + dependent arity or not. To avoid different predicates + printed the same in v8, all predicates built in indrec.ml + got a dependent arity (Aug 2004). The new way to decide + whether names have to be created or not is to use an + Anonymous or Named variable to enforce the expected + dependency status (of course, Anonymous implies non + dependent, but not conversely). From Coq > 8.2, using or not the the effective dependency of the predicate is parametrable! *) @@ -600,15 +600,15 @@ let rec instantiate_universes env evdref scl is = function let ctx,_ = Reduction.dest_arity env ty in let u = Univ.Universe.make l in let s = - (* Does the sort of parameter [u] appear in (or equal) + (* Does the sort of parameter [u] appear in (or equal) the sort of inductive [is] ? *) if univ_level_mem l is then scl (* constrained sort: replace by scl *) else (* unconstrained sort: replace by fresh universe *) let evm, s = Evd.new_sort_variable Evd.univ_flexible !evdref in - let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in - evdref := evm; s + let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in + evdref := evm; s in (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp) | sign, [] -> sign (* Uniform parameters are exhausted *) @@ -656,93 +656,3 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c - -(* inference of subtyping condition for inductive types *) - -let infer_inductive_subtyping_arity_constructor - (env, evd, csts) (subst : constr -> constr) (arcn : types) is_arity (params : Context.Rel.t) = - let numchecked = ref 0 in - let numparams = Context.Rel.nhyps params in - let update_contexts (env, evd, csts) csts' = - (Environ.add_constraints csts' env, Evd.add_constraints evd csts', Univ.Constraint.union csts csts') - in - let basic_check (env, evd, csts) tp = - let result = - if !numchecked >= numparams then - let csts' = - Reduction.infer_conv_leq ~evars:(Evd.existential_opt_value evd) env (Evd.universes evd) tp (subst tp) - in update_contexts (env, evd, csts) csts' - else - (env, evd, csts) - in - numchecked := !numchecked + 1; result - in - let infer_typ typ ctxs = - match typ with - | LocalAssum (_, typ') -> - begin - try - let (env, evd, csts) = basic_check ctxs typ' in (Environ.push_rel typ env, evd, csts) - with Reduction.NotConvertible -> - anomaly ~label:"inference of record/inductive subtyping relation failed" - (Pp.str "Can't infer subtyping for record/inductive type") - end - | _ -> anomaly (Pp.str "") - in - let arcn' = Term.it_mkProd_or_LetIn arcn params in - let typs, codom = Reduction.dest_prod env arcn' in - let last_contexts = Context.Rel.fold_outside infer_typ typs ~init:(env, evd, csts) in - if not is_arity then basic_check last_contexts codom else last_contexts - -let infer_inductive_subtyping env evd mind_ent = - let { Entries.mind_entry_params = params; - Entries.mind_entry_inds = entries; - Entries.mind_entry_universes = ground_univs; - } = mind_ent - in - let uinfind = - match ground_univs with - | Entries.Monomorphic_ind_entry _ - | Entries.Polymorphic_ind_entry _ -> ground_univs - | Entries.Cumulative_ind_entry cumi -> - begin - let uctx = Univ.CumulativityInfo.univ_context cumi in - let sbsubst = Univ.CumulativityInfo.subtyping_susbst cumi in - let dosubst = subst_univs_level_constr sbsubst in - let instance_other = - Univ.subst_univs_level_instance sbsubst (Univ.UContext.instance uctx) - in - let constraints_other = - Univ.subst_univs_level_constraints - sbsubst (Univ.UContext.constraints uctx) - in - let uctx_other = Univ.UContext.make (instance_other, constraints_other) in - let env = Environ.push_context uctx env in - let env = Environ.push_context uctx_other env in - let evd = - Evd.merge_universe_context - evd (UState.of_context_set (Univ.ContextSet.of_context uctx_other)) - in - let (_, _, subtyp_constraints) = - List.fold_left - (fun ctxs indentry -> - let _, params = Typeops.infer_local_decls env params in - let ctxs' = infer_inductive_subtyping_arity_constructor - ctxs dosubst indentry.Entries.mind_entry_arity true params - in - List.fold_left - (fun ctxs cons -> - infer_inductive_subtyping_arity_constructor - ctxs dosubst cons false params - ) - ctxs' indentry.Entries.mind_entry_lc - ) (env, evd, Univ.Constraint.empty) entries - in - Entries.Cumulative_ind_entry - (Univ.CumulativityInfo.make - (Univ.CumulativityInfo.univ_context cumi, - Univ.UContext.make - (Univ.UContext.instance (Univ.CumulativityInfo.subtyp_context cumi), - subtyp_constraints))) - end - in {mind_ent with Entries.mind_entry_universes = uinfind;} diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 58b1ce6c3..55149552a 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -199,12 +199,3 @@ val type_of_inductive_knowing_conclusion : (********************) val control_only_guard : env -> types -> unit - -(* inference of subtyping condition for inductive types *) -(* for debugging purposes only to be removed *) -val infer_inductive_subtyping_arity_constructor : Environ.env * Evd.evar_map * Univ.Constraint.t -> -(constr -> constr) -> -types -> bool -> Context.Rel.t -> Environ.env * Evd.evar_map * Univ.Constraint.t - -val infer_inductive_subtyping : Environ.env -> Evd.evar_map -> Entries.mutual_inductive_entry -> - Entries.mutual_inductive_entry diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml new file mode 100644 index 000000000..a4097237f --- /dev/null +++ b/pretyping/inferCumulativity.ml @@ -0,0 +1,208 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Reduction +open Declarations +open Constr +open Univ +open Util + +(** Throughout this module we modify a map [variances] from local + universes to [Variance.t]. It starts as a trivial mapping to + [Irrelevant] and every time we encounter a local universe we + restrict it accordingly. *) + +let infer_level_eq u variances = + if LMap.mem u variances + then LMap.set u Variance.Invariant variances + else variances + +let infer_level_leq u variances = + match LMap.find u variances with + | exception Not_found -> variances + | varu -> LMap.set u (Variance.sup varu Variance.Covariant) variances + +let infer_generic_instance_eq variances u = + Array.fold_left (fun variances u -> infer_level_eq u variances) + variances (Instance.to_array u) + +let variance_pb cv_pb var = + let open Variance in + match cv_pb, var with + | _, Irrelevant -> Irrelevant + | _, Invariant -> Invariant + | CONV, Covariant -> Invariant + | CUMUL, Covariant -> Covariant + +let infer_cumulative_ind_instance cv_pb cumi variances u = + Array.fold_left2 (fun variances varu u -> + match LMap.find u variances with + | exception Not_found -> variances + | varu' -> + LMap.set u (Variance.sup varu' (variance_pb cv_pb varu)) variances) + variances (ACumulativityInfo.variance cumi) (Instance.to_array u) + +let infer_inductive_instance cv_pb env variances ind nargs u = + let mind = Environ.lookup_mind (fst ind) env in + match mind.mind_universes with + | Monomorphic_ind _ -> assert (Instance.is_empty u); variances + | Polymorphic_ind _ -> infer_generic_instance_eq variances u + | Cumulative_ind cumi -> + if not (Int.equal (inductive_cumulativity_arguments (mind,snd ind)) nargs) + then infer_generic_instance_eq variances u + else infer_cumulative_ind_instance cv_pb cumi variances u + +let infer_constructor_instance_eq env variances ((mi,ind),ctor) nargs u = + let mind = Environ.lookup_mind mi env in + match mind.mind_universes with + | Monomorphic_ind _ -> assert (Instance.is_empty u); variances + | Polymorphic_ind _ -> infer_generic_instance_eq variances u + | Cumulative_ind cumi -> + if not (Int.equal (constructor_cumulativity_arguments (mind,ind,ctor)) nargs) + then infer_generic_instance_eq variances u + else infer_cumulative_ind_instance CONV cumi variances u + +let infer_sort cv_pb variances s = + match cv_pb with + | CONV -> + LSet.fold infer_level_eq (Universe.levels (Sorts.univ_of_sort s)) variances + | CUMUL -> + LSet.fold infer_level_leq (Universe.levels (Sorts.univ_of_sort s)) variances + +let infer_table_key infos variances c = + let open Names in + match c with + | ConstKey (_, u) -> + infer_generic_instance_eq variances u + | VarKey _ | RelKey _ -> variances + +let rec infer_fterm cv_pb infos variances hd stk = + Control.check_for_interrupt (); + let open CClosure in + let hd,stk = whd_stack infos hd stk in + match fterm_of hd with + | FAtom a -> + begin match kind a with + | Sort s -> infer_sort cv_pb variances s + | Meta _ -> infer_stack infos variances stk + | _ -> assert false + end + | FEvar ((_,args),e) -> + let variances = infer_stack infos variances stk in + infer_vect infos variances (Array.map (mk_clos e) args) + | FRel _ -> variances + | FFlex fl -> + let variances = infer_table_key infos variances fl in + infer_stack infos variances stk + | FProj (_,c) -> + let variances = infer_fterm CONV infos variances c [] in + infer_stack infos variances stk + | FLambda _ -> + let (_,ty,bd) = destFLambda mk_clos hd in + let variances = infer_fterm CONV infos variances ty [] in + infer_fterm CONV infos variances bd [] + | FProd (_,dom,codom) -> + let variances = infer_fterm CONV infos variances dom [] in + infer_fterm cv_pb infos variances codom [] + | FInd (ind, u) -> + let variances = + if Instance.is_empty u then variances + else + let nargs = stack_args_size stk in + infer_inductive_instance cv_pb (info_env infos) variances ind nargs u + in + infer_stack infos variances stk + | FConstruct (ctor,u) -> + let variances = + if Instance.is_empty u then variances + else + let nargs = stack_args_size stk in + infer_constructor_instance_eq (info_env infos) variances ctor nargs u + in + infer_stack infos variances stk + | FFix ((_,(_,tys,cl)),e) | FCoFix ((_,(_,tys,cl)),e) -> + let n = Array.length cl in + let variances = infer_vect infos variances (Array.map (mk_clos e) tys) in + let le = Esubst.subs_liftn n e in + let variances = infer_vect infos variances (Array.map (mk_clos le) cl) in + infer_stack infos variances stk + + (* Removed by whnf *) + | FLOCKED | FCaseT _ | FCast _ | FLetIn _ | FApp _ | FLIFT _ | FCLOS _ -> assert false + +and infer_stack infos variances (stk:CClosure.stack) = + match stk with + | [] -> variances + | z :: stk -> + let open CClosure in + let variances = match z with + | Zapp v -> infer_vect infos variances v + | Zproj _ -> variances + | Zfix (fx,a) -> + let variances = infer_fterm CONV infos variances fx [] in + infer_stack infos variances a + | ZcaseT (ci,p,br,e) -> + let variances = infer_fterm CONV infos variances (mk_clos e p) [] in + infer_vect infos variances (Array.map (mk_clos e) br) + | Zshift _ -> variances + | Zupdate _ -> variances + in + infer_stack infos variances stk + +and infer_vect infos variances v = + Array.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v + +let infer_term cv_pb env variances c = + let open CClosure in + let infos = create_clos_infos all env in + infer_fterm cv_pb infos variances (CClosure.inject c) [] + +let infer_arity_constructor is_arity env variances arcn = + let infer_typ typ (env,variances) = + match typ with + | Context.Rel.Declaration.LocalAssum (_, typ') -> + (Environ.push_rel typ env, infer_term CUMUL env variances typ') + | Context.Rel.Declaration.LocalDef _ -> assert false + in + let typs, codom = Reduction.dest_prod env arcn in + let env, variances = Context.Rel.fold_outside infer_typ typs ~init:(env, variances) in + (* If we have Inductive foo@{i j} : ... -> Type@{i} := C : ... -> foo Type@{j} + i is irrelevant, j is invariant. *) + if not is_arity then infer_term CUMUL env variances codom else variances + +let infer_inductive env mie = + let open Entries in + let { mind_entry_params = params; + mind_entry_inds = entries; } = mie + in + let univs = + match mie.mind_entry_universes with + | Monomorphic_ind_entry _ + | Polymorphic_ind_entry _ as univs -> univs + | Cumulative_ind_entry cumi -> + let uctx = CumulativityInfo.univ_context cumi in + let uarray = Instance.to_array @@ UContext.instance uctx in + let env = Environ.push_context uctx env in + let variances = + Array.fold_left (fun variances u -> LMap.add u Variance.Irrelevant variances) + LMap.empty uarray + in + let env, _ = Typeops.infer_local_decls env params in + let variances = List.fold_left (fun variances entry -> + let variances = infer_arity_constructor true + env variances entry.mind_entry_arity + in + List.fold_left (infer_arity_constructor false env) + variances entry.mind_entry_lc) + variances + entries + in + let variances = Array.map (fun u -> LMap.find u variances) uarray in + Cumulative_ind_entry (CumulativityInfo.make (uctx, variances)) + in + { mie with mind_entry_universes = univs } diff --git a/pretyping/inferCumulativity.mli b/pretyping/inferCumulativity.mli new file mode 100644 index 000000000..a5037ea47 --- /dev/null +++ b/pretyping/inferCumulativity.mli @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> + Entries.mutual_inductive_entry diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index bc563b46d..f0cb8fd1f 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -30,7 +30,8 @@ let smartmap_cast_type f c = let glob_sort_eq g1 g2 = match g1, g2 with | GProp, GProp -> true | GSet, GSet -> true -| GType l1, GType l2 -> List.equal (fun x y -> Names.Name.equal (snd x) (snd y)) l1 l2 +| GType l1, GType l2 -> + List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2 | _ -> false let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index dafe8cb26..b41e15f5a 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -224,7 +224,7 @@ and nf_accu env sigma accu = if Int.equal (accu_nargs accu) 0 then nf_atom env sigma atom else let a,typ = nf_atom_type env sigma atom in - let _, args = nf_args env sigma accu typ in + let _, args = nf_args env sigma (args_of_accu accu) typ in mkApp(a,Array.of_list args) and nf_accu_type env sigma accu = @@ -232,10 +232,10 @@ and nf_accu_type env sigma accu = if Int.equal (accu_nargs accu) 0 then nf_atom_type env sigma atom else let a,typ = nf_atom_type env sigma atom in - let t, args = nf_args env sigma accu typ in + let t, args = nf_args env sigma (args_of_accu accu) typ in mkApp(a,Array.of_list args), t -and nf_args env sigma accu t = +and nf_args env sigma args t = let aux arg (t,l) = let _,dom,codom = try decompose_prod env t with @@ -246,7 +246,7 @@ and nf_args env sigma accu t = let c = nf_val env sigma arg dom in (subst1 c codom, c::l) in - let t,l = List.fold_right aux (args_of_accu accu) (t,[]) in + let t,l = Array.fold_right aux args (t,[]) in t, List.rev l and nf_bargs env sigma b t = @@ -277,7 +277,6 @@ and nf_atom env sigma atom = let codom = nf_type env sigma (codom vn) in mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv - | Aevar (ev,_) -> mkEvar ev | Aproj(p,c) -> let c = nf_accu env sigma c in mkProj(Projection.make p true,c) @@ -347,9 +346,9 @@ and nf_atom_type env sigma atom = let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env sigma (codom vn) in mkProd(n,dom,codom), Typeops.type_of_product env n s1 s2 - | Aevar(ev,ty) -> - let ty = nf_type env sigma ty in - mkEvar ev, ty + | Aevar(evk,ty,args) -> + let ty = nf_type env sigma ty in + nf_evar env sigma evk ty args | Ameta(mv,ty) -> let ty = nf_type env sigma ty in mkMeta mv, ty @@ -386,6 +385,19 @@ and nf_predicate env sigma ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_type env sigma v +and nf_evar env sigma evk ty args = + let evi = try Evd.find sigma evk with Not_found -> assert false in + let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in + if List.is_empty hyps then begin + assert (Int.equal (Array.length args) 0); + mkEvar (evk, [||]), ty + end + else + let fold accu d = Term.mkNamedProd_or_LetIn d accu in + let t = List.fold_left fold ty hyps in + let ty, args = nf_args env sigma args t in + mkEvar (evk, Array.of_list args), ty + let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value sigma; Nativelambda.evars_typ = Evd.existential_type sigma; @@ -436,11 +448,11 @@ let stop_profiler m_pid = match profiler_platform() with "Unix (Linux)" -> stop_profiler_linux m_pid | _ -> () - + let native_norm env sigma c ty = let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in - if Coq_config.no_native_compiler then + if not Coq_config.native_compiler then user_err Pp.(str "Native_compute reduction has been disabled at configure time.") else let penv = Environ.pre_env env in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 41e09004c..1bec4a6f1 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -137,8 +137,7 @@ let rec head_pattern_bound t = | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id - | PProj (p,c) -> ConstRef (Projection.constant p) - | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ + | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ | PProj _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern @@ -446,6 +445,9 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) + | GProj(p,c) -> + PProj(p, pat_of_raw metas vars c) + | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ | GRec _ -> err ?loc (Pp.str "Non supported pattern.")) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 00c254dbe..6700748eb 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -70,7 +70,7 @@ let get_extra env sigma = let ids = List.map get_id (named_context env) in let avoid = List.fold_right Id.Set.add ids Id.Set.empty in Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) - (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) + (rel_context env) ~init:(empty_csubst, avoid, named_context env) let make_env env sigma = { env = env; extra = lazy (get_extra env sigma) } let rel_context env = rel_context env.env @@ -90,12 +90,11 @@ let push_rel_context sigma ctx env = { let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = - let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in - let (subst, vsubst, _, nc) = Lazy.force env.extra in - let typ' = subst2 subst vsubst typ in + let (subst, _, nc) = Lazy.force env.extra in + let typ' = csubst_subst subst typ in let instance = inst_rels @ inst_vars in let sign = val_of_named_context nc in let sigma = !evdref in @@ -177,61 +176,77 @@ let _ = optwrite = (:=) Universes.set_minimization }) (** Miscellaneous interpretation functions *) -let interp_known_universe_level evd id = + +let interp_known_universe_level evd r = + let loc, qid = Libnames.qualid_of_reference r in try - let level = Evd.universe_of_name evd id in - level + match r with + | Libnames.Ident (loc, id) -> Evd.universe_of_name evd id + | Libnames.Qualid _ -> raise Not_found with Not_found -> - let names, _ = Global.global_universe_names () in - snd (Id.Map.find id names) - -let interp_universe_level_name ~anon_rigidity evd (loc, s) = - match s with - | Anonymous -> - new_univ_level_variable ?loc anon_rigidity evd - | Name id -> - let s = Id.to_string id in - if CString.string_contains ~where:s ~what:"." then - match List.rev (CString.split '.' s) with - | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".") - | n :: dp -> - let num = int_of_string n in - let dp = DirPath.make (List.map Id.of_string dp) in - let level = Univ.Level.make dp num in - let evd = - try Evd.add_global_univ evd level - with UGraph.AlreadyDeclared -> evd - in evd, level - else - try evd, interp_known_universe_level evd id - with Not_found -> - if not (is_strict_universe_declarations ()) then - new_univ_level_variable ?loc ~name:id univ_rigid evd - else user_err ?loc ~hdr:"interp_universe_level_name" - (Pp.(str "Undeclared universe: " ++ str s)) + let univ, k = Nametab.locate_universe qid in + Univ.Level.make univ k + +let interp_universe_level_name ~anon_rigidity evd r = + try evd, interp_known_universe_level evd r + with Not_found -> + match r with (* Qualified generated name *) + | Libnames.Qualid (loc, qid) -> + let dp, i = Libnames.repr_qualid qid in + let num = + try int_of_string (Id.to_string i) + with Failure _ -> + user_err ?loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared global universe: " ++ Libnames.pr_reference r)) + in + let level = Univ.Level.make dp num in + let evd = + try Evd.add_global_univ evd level + with UGraph.AlreadyDeclared -> evd + in evd, level + | Libnames.Ident (loc, id) -> (* Undeclared *) + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ?loc ~name:id univ_rigid evd + else user_err ?loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ Id.print id)) let interp_universe ?loc evd = function | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in evd, Univ.Universe.make l | l -> - List.fold_left (fun (evd, u) l -> - (* [univ_flexible_alg] can produce algebraic universes in terms *) - let evd', l = interp_universe_level_name ~anon_rigidity:univ_flexible evd l in - (evd', Univ.sup u (Univ.Universe.make l))) + List.fold_left (fun (evd, u) l -> + let evd', u' = + match l with + | Some (l,n) -> + (* [univ_flexible_alg] can produce algebraic universes in terms *) + let anon_rigidity = univ_flexible in + let evd', l = interp_universe_level_name ~anon_rigidity evd l in + let u' = Univ.Universe.make l in + (match n with + | 0 -> evd', u' + | 1 -> evd', Univ.Universe.super u' + | _ -> + user_err ?loc ~hdr:"interp_universe" + (Pp.(str "Cannot interpret universe increment +" ++ int n))) + | None -> + let evd, l = new_univ_level_variable ?loc univ_flexible evd in + evd, Univ.Universe.make l + in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l let interp_known_level_info ?loc evd = function - | None | Some (_, Anonymous) -> + | UUnknown | UAnonymous -> user_err ?loc ~hdr:"interp_known_level_info" (str "Anonymous universes not allowed here.") - | Some (loc, Name id) -> - try interp_known_universe_level evd id + | UNamed ref -> + try interp_known_universe_level evd ref with Not_found -> - user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Id.print id) + user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_reference ref) let interp_level_info ?loc evd : Misctypes.level_info -> _ = function - | None -> new_univ_level_variable ?loc univ_rigid evd - | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s) + | UUnknown -> new_univ_level_variable ?loc univ_rigid evd + | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd + | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr @@ -363,10 +378,10 @@ let check_evars_are_solved env current_sigma init_sigma = let frozen = frozen_and_pending_holes (init_sigma, current_sigma) in check_evars_are_solved env current_sigma frozen -let process_inference_flags flags env initial_sigma (sigma,c) = +let process_inference_flags flags env initial_sigma (sigma,c,cty) = let sigma = solve_remaining_evars flags env sigma initial_sigma in let c = if flags.expand_evars then nf_evar sigma c else c in - sigma,c + sigma,c,cty let adjust_evar_source evdref na c = match na, kind !evdref c with @@ -722,6 +737,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j = pretype_sort ?loc evdref s in inh_conv_coerce_to_tycon ?loc env evdref j tycon + | GProj (p, c) -> + (* TODO: once GProj is used as an input syntax, use bidirectional typing here *) + let cj = pretype empty_tycon env evdref lvar c in + judge_of_projection env.ExtraEnv.env !evdref p cj + | GApp (f,args) -> let fj = pretype empty_tycon env evdref lvar f in let floc = loc_of_glob_constr f in @@ -1153,15 +1173,18 @@ let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env sigma in let evdref = ref sigma in let k0 = Context.Rel.length (rel_context env) in - let c' = match kind with + let c', c'_ty = match kind with | WithoutTypeConstraint -> - (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val + let j = pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c in + j.uj_val, j.uj_type | OfType exptyp -> - (pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val + let j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c in + j.uj_val, j.uj_type | IsType -> - (pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val + let tj = pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c in + tj.utj_val, mkSort tj.utj_type in - process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c') + process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c',c'_ty) let default_inference_flags fail = { use_typeclasses = true; @@ -1181,7 +1204,7 @@ let all_and_fail_flags = default_inference_flags true let all_no_fail_flags = default_inference_flags false let ise_pretype_gen_ctx flags env sigma lvar kind c = - let evd, c = ise_pretype_gen flags env sigma lvar kind c in + let evd, c, _ = ise_pretype_gen flags env sigma lvar kind c in let evd, f = Evarutil.nf_evars_and_universes evd in f (EConstr.Unsafe.to_constr c), Evd.evar_universe_context evd @@ -1193,12 +1216,15 @@ let understand env sigma c = ise_pretype_gen_ctx flags env sigma empty_lvar expected_type c -let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c = - let (sigma, c) = ise_pretype_gen flags env sigma empty_lvar expected_type c in - (sigma, c) +let understand_tcc_ty ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c = + ise_pretype_gen flags env sigma empty_lvar expected_type c + +let understand_tcc ?flags env sigma ?expected_type c = + let sigma, c, _ = understand_tcc_ty ?flags env sigma ?expected_type c in + sigma, c let understand_ltac flags env sigma lvar kind c = - let (sigma, c) = ise_pretype_gen flags env sigma lvar kind c in + let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) let pretype k0 resolve_tc typcon env evdref lvar t = diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index fe10be9e7..864768fe5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -58,6 +58,11 @@ val all_and_fail_flags : inference_flags val understand_tcc : ?flags:inference_flags -> env -> evar_map -> ?expected_type:typing_constraint -> glob_constr -> evar_map * constr +(** As [understand_tcc] but also returns the type of the elaborated term. + The [expand_evars] flag is not applied to the type (only to the term). *) +val understand_tcc_ty : ?flags:inference_flags -> env -> evar_map -> + ?expected_type:typing_constraint -> glob_constr -> evar_map * constr * types + (** More general entry point with evars from ltac *) (** Generic call to the interpreter from glob_constr to constr @@ -116,7 +121,7 @@ val pretype_type : val ise_pretype_gen : inference_flags -> env -> evar_map -> - ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr + ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr * types (**/**) diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 1da5b4567..ae4ad0be7 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -4,6 +4,7 @@ Locusops Pretype_errors Reductionops Inductiveops +InferCumulativity Vnorm Arguments_renaming Nativenorm diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 9ff9a75b3..ab1f3cd32 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -298,29 +298,40 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) (*s High-level declaration of a canonical structure *) -let error_not_structure ref = +let error_not_structure ref description = user_err ~hdr:"object_declare" - (Id.print (basename_of_global ref) ++ str" is not a structure object.") + (str"Could not declare a canonical structure " ++ + (Id.print (basename_of_global ref) ++ str"." ++ spc() ++ + str(description))) let check_and_decompose_canonical_structure ref = - let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in + let sp = + match ref with + ConstRef sp -> sp + | _ -> error_not_structure ref "Expected an instance of a record or structure." + in let env = Global.env () in let u = Univ.make_abstract_instance (Environ.constant_context env sp) in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc - | None -> error_not_structure ref in + | None -> error_not_structure ref "Could not find its value in the global environment." in let body = snd (splay_lam (Global.env()) Evd.empty (EConstr.of_constr vc)) (** FIXME *) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with | App (f,args) -> f,args - | _ -> error_not_structure ref in + | _ -> + error_not_structure ref "Expected a record or structure constructor applied to arguments." in let indsp = match kind f with | Construct ((indsp,1),u) -> indsp - | _ -> error_not_structure ref in - let s = try lookup_structure indsp with Not_found -> error_not_structure ref in + | _ -> error_not_structure ref "Expected an instance of a record or structure." in + let s = + try lookup_structure indsp + with Not_found -> + error_not_structure ref + ("Could not find the record or structure " ^ (MutInd.to_string (fst indsp))) in let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then - error_not_structure ref; + error_not_structure ref "Got too few arguments to the record or structure constructor."; (sp,indsp) let declare_canonical_structure ref = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index ba0502ca4..418ea271c 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -121,10 +121,10 @@ module ReductionBehaviour = struct let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) let discharge = function - | _,(ReqGlobal (ConstRef c, req), (_, b)) -> + | _,(ReqGlobal (ConstRef c as gr, req), (_, b)) -> let b = - if Lib.is_in_section (ConstRef c) then - let vars, _, _ = Lib.section_segment_of_constant c in + if Lib.is_in_section gr then + let vars = Lib.variable_section_segment_of_reference gr in let extra = List.length vars in let nargs' = if b.b_nargs = max_int then max_int @@ -284,8 +284,6 @@ sig | Proj of int * int * projection * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list exception IncompatibleFold2 @@ -296,12 +294,12 @@ 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 equal : ('a * int -> 'a * int -> bool) -> (('a, 'a) pfixpoint * int -> ('a, 'a) pfixpoint * int -> bool) - -> 'a t -> 'a t -> (int * int) option + val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool) + -> 'a t -> 'a t -> bool val compare_shape : 'a t -> 'a t -> bool val map : ('a -> 'a) -> 'a t -> 'a t val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> - constr t -> constr t -> 'a * int * int + constr t -> constr t -> 'a val append_app_list : 'a list -> 'a t -> 'a t val strip_app : 'a t -> 'a t * 'a t val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option @@ -343,8 +341,6 @@ struct | Proj of int * int * projection * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list let rec pr_member pr_c member = @@ -367,8 +363,6 @@ struct ++ pr_comma () ++ prlist_with_sep pr_semicolon int remains ++ pr_comma () ++ pr pr_c params ++ str ")" - | Shift i -> str "ZShift(" ++ int i ++ str ")" - | Update t -> str "ZUpdate(" ++ pr_c t ++ str ")" and pr pr_c l = let open Pp in prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l @@ -403,54 +397,42 @@ struct else (l.(j), sk) let equal f f_fix sk1 sk2 = - let equal_cst_member x lft1 y lft2 = + let equal_cst_member x y = match x, y with | Cst_const (c1,u1), Cst_const (c2, u2) -> - Constant.equal c1 c2 && Univ.Instance.equal u1 u2 + Constant.equal c1 c2 && Univ.Instance.equal u1 u2 | Cst_proj p1, Cst_proj p2 -> - Constant.equal (Projection.constant p1) (Projection.constant p2) + Constant.equal (Projection.constant p1) (Projection.constant p2) | _, _ -> false in - let rec equal_rec sk1 lft1 sk2 lft2 = + let rec equal_rec sk1 sk2 = match sk1,sk2 with - | [],[] -> Some (lft1,lft2) - | (Update _ :: _, _ | _, Update _ :: _) -> assert false - | Shift k :: s1, _ -> equal_rec s1 (lft1+k) sk2 lft2 - | _, Shift k :: s2 -> equal_rec sk1 lft1 s2 (lft2+k) + | [],[] -> true | App a1 :: s1, App a2 :: s2 -> - let t1,s1' = decomp_node_last a1 s1 in - let t2,s2' = decomp_node_last a2 s2 in - if f (t1,lft1) (t2,lft2) then equal_rec s1' lft1 s2' lft2 else None + let t1,s1' = decomp_node_last a1 s1 in + let t2,s2' = decomp_node_last a2 s2 in + (f t1 t2) && (equal_rec s1' s2') | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 -> - if f (t1,lft1) (t2,lft2) && CArray.equal (fun x y -> f (x,lft1) (y,lft2)) a1 a2 - then equal_rec s1 lft1 s2 lft2 - else None + f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) -> - if Int.equal n1 n2 && Int.equal m1 m2 - && Constant.equal (Projection.constant p) (Projection.constant p2) - then equal_rec s1 lft1 s2 lft2 - else None + Int.equal n1 n2 && Int.equal m1 m2 + && Constant.equal (Projection.constant p) (Projection.constant p2) + && equal_rec s1 s2 | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> - if f_fix (f1,lft1) (f2,lft2) then - match equal_rec (List.rev s1) lft1 (List.rev s2) lft2 with - | None -> None - | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2' - else None + f_fix f1 f2 + && equal_rec (List.rev s1) (List.rev s2) + && equal_rec s1' s2' | Cst (c1,curr1,remains1,params1,_)::s1', Cst (c2,curr2,remains2,params2,_)::s2' -> - if equal_cst_member c1 lft1 c2 lft2 then - match equal_rec (List.rev params1) lft1 (List.rev params2) lft2 with - | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2' - | None -> None - else None - | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> None - in equal_rec (List.rev sk1) 0 (List.rev sk2) 0 + equal_cst_member c1 c2 + && equal_rec (List.rev params1) (List.rev params2) + && equal_rec s1' s2' + | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> false + in equal_rec (List.rev sk1) (List.rev sk2) let compare_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> Int.equal bal 0 - | ((Update _|Shift _)::s1, _) -> compare_rec bal s1 stk2 - | (_, (Update _|Shift _)::s2) -> compare_rec bal stk1 s2 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> @@ -466,40 +448,29 @@ struct exception IncompatibleFold2 let fold2 f o sk1 sk2 = - let rec aux o lft1 sk1 lft2 sk2 = - let fold_array = - Array.fold_left2 (fun a x y -> f a (Vars.lift lft1 x) (Vars.lift lft2 y)) - in + let rec aux o sk1 sk2 = match sk1,sk2 with - | [], [] -> o,lft1,lft2 - | Shift n :: q1, _ -> aux o (lft1+n) q1 lft2 sk2 - | _, Shift n :: q2 -> aux o lft1 sk1 (lft2+n) q2 + | [], [] -> o | App n1 :: q1, App n2 :: q2 -> - let t1,l1 = decomp_node_last n1 q1 in - let t2,l2 = decomp_node_last n2 q2 in - aux (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) - lft1 l1 lft2 l2 + let t1,l1 = decomp_node_last n1 q1 in + let t2,l2 = decomp_node_last n2 q2 in + aux (f o t1 t2) l1 l2 | Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 -> - aux (fold_array - (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) - a1 a2) lft1 q1 lft2 q2 + aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 | Proj (n1,m1,p1,_) :: q1, Proj (n2,m2,p2,_) :: q2 -> - aux o lft1 q1 lft2 q2 + aux o q1 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> - let (o',lft1',lft2') = aux (fold_array (fold_array o b1 b2) a1 a2) - lft1 (List.rev s1) lft2 (List.rev s2) in - aux o' lft1' q1 lft2' q2 + let o' = aux (Array.fold_left2 f (Array.fold_left2 f o b1 b2) a1 a2) (List.rev s1) (List.rev s2) in + aux o' q1 q2 | Cst (cst1,_,_,params1,_) :: q1, Cst (cst2,_,_,params2,_) :: q2 -> - let (o',lft1',lft2') = - aux o lft1 (List.rev params1) lft2 (List.rev params2) - in aux o' lft1' q1 lft2' q2 - | (((Update _|App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) -> - raise IncompatibleFold2 - in aux o 0 (List.rev sk1) 0 (List.rev sk2) + let o' = aux o (List.rev params1) (List.rev params2) in + aux o' q1 q2 + | (((App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) -> + raise IncompatibleFold2 + in aux o (List.rev sk1) (List.rev sk2) let rec map f x = List.map (function - | Update _ -> assert false - | (Proj (_,_,_,_) | Shift _) as e -> e + | (Proj (_,_,_,_)) as e -> e | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) @@ -516,18 +487,15 @@ struct let rec args_size = function | App (i,_,j)::s -> j + 1 - i + args_size s - | Shift(_)::s -> args_size s - | Update(_)::s -> args_size s | (Case _|Fix _|Proj _|Cst _)::_ | [] -> 0 let strip_app s = let rec aux out = function - | ( App _ | Shift _ as e) :: s -> aux (e :: out) s + | ( 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 - | Shift k as e :: s -> aux n (e :: out) s | App (i,a,j) as e :: s -> let nb = j - i + 1 in if n >= nb then @@ -552,14 +520,12 @@ struct let list_of_app_stack s = let rec aux = function | App (i,a,j) :: s -> - let (k,(args',s')) = aux s in - let a' = Array.map (Vars.lift k) (Array.sub a i (j - i + 1)) in - k,(Array.fold_right (fun x y -> x::y) a' args', s') - | Shift n :: s -> - let (k,(args',s')) = aux s in (k+n,(args', s')) - | s -> (0,([],s)) in - let (lft,(out,s')) = aux s in - let init = match s' with [] when Int.equal lft 0 -> true | _ -> false in + let (args',s') = aux s in + let a' = Array.sub a i (j - i + 1) in + (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 let assign s p c = @@ -568,20 +534,18 @@ struct | None -> assert false let tail n0 s0 = - let rec aux lft n s = - let out s = if Int.equal lft 0 then s else Shift lft :: s in - if Int.equal n 0 then out s else + let rec aux n s = + if Int.equal n 0 then s else match s with | App (i,a,j) :: s -> let nb = j - i + 1 in if n >= nb then - aux lft (n - nb) s + aux (n - nb) s else let p = i+n in if j >= p then App(p,a,j)::s else s - | Shift k :: s' -> aux (lft+k) n s' | _ -> raise (Invalid_argument "Reductionops.Stack.tail") - in aux 0 n0 s0 + in aux n0 s0 let nth s p = match strip_n_app p s with @@ -627,11 +591,9 @@ struct zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Shift n::s) -> zip (lift n f, s) | f, (Proj (n,m,p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) - | _, (Update _::_) -> assert false in zip s @@ -868,11 +830,9 @@ let _ = Goptions.declare_bool_option { } let equal_stacks sigma (x, l) (y, l') = - let f_equal (x,lft1) (y,lft2) = eq_constr sigma (Vars.lift lft1 x) (Vars.lift lft2 y) in - let eq_fix (a,b) (c,d) = f_equal (mkFix a, b) (mkFix c, d) in - match Stack.equal f_equal eq_fix l l' with - | None -> false - | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) + let f_equal x y = eq_constr sigma x y in + let eq_fix a b = f_equal (mkFix a) (mkFix b) in + Stack.equal f_equal eq_fix l l' && f_equal x y let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in @@ -1074,7 +1034,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (arg, Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''') end - |_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false + |_, (Stack.App _)::_ -> assert false |_, _ -> fold () else fold () @@ -1155,7 +1115,7 @@ let local_whd_state_gen flags sigma = |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> let x' = Stack.zip sigma (x,args) in whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) - |_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false + |_, (Stack.App _|Stack.Cst _)::_ -> assert false |_, _ -> s else s @@ -1281,9 +1241,9 @@ let clos_whd_flags flgs env sigma t = (CClosure.inject (EConstr.Unsafe.to_constr t))) with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") -let nf_beta = clos_norm_flags CClosure.beta (Global.env ()) -let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ()) -let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ()) +let nf_beta = clos_norm_flags CClosure.beta +let nf_betaiota = clos_norm_flags CClosure.betaiota +let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta let nf_all env sigma = clos_norm_flags CClosure.all env sigma @@ -1292,11 +1252,11 @@ let nf_all env sigma = (* Conversion *) (********************************************************************) (* -let fkey = Profile.declare_profile "fhnf";; -let fhnf info v = Profile.profile2 fkey fhnf info v;; +let fkey = CProfile.declare_profile "fhnf";; +let fhnf info v = CProfile.profile2 fkey fhnf info v;; -let fakey = Profile.declare_profile "fhnf_apply";; -let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;; +let fakey = CProfile.declare_profile "fhnf_apply";; +let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;; *) let is_transparent e k = @@ -1306,7 +1266,7 @@ let is_transparent e k = (* Conversion utility functions *) -type conversion_test = constraints -> constraints +type conversion_test = Constraint.t -> Constraint.t let pb_is_equal pb = pb == Reduction.CONV @@ -1364,79 +1324,17 @@ let sigma_compare_instances ~flex i0 i1 sigma = | Univ.UniverseInconsistency _ -> raise Reduction.NotConvertible -let sigma_check_inductive_instances cv_pb uinfind u u' sigma = - let len_instance = - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context uinfind) - in - let ind_sbctx = Univ.ACumulativityInfo.subtyp_context uinfind in - if not ((len_instance = Univ.Instance.length u) && - (len_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.AUContext.instantiate comp_subst ind_sbctx - in - let comp_cst = - match cv_pb with - Reduction.CONV -> - let comp_subst = (Univ.Instance.append u' u) in - let comp_cst' = Univ.AUContext.instantiate comp_subst ind_sbctx in - Univ.Constraint.union comp_cst comp_cst' - | Reduction.CUMUL -> comp_cst - in - try Evd.add_constraints sigma comp_cst - with Evd.UniversesDiffer - | Univ.UniverseInconsistency _ -> - raise Reduction.NotConvertible - -let sigma_conv_inductives - cv_pb (mind, ind) u1 sv1 u2 sv2 sigma = - try sigma_compare_instances ~flex:false u1 u2 sigma with - Reduction.NotConvertible -> - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - raise Reduction.NotConvertible - | Declarations.Polymorphic_ind _ -> - raise Reduction.NotConvertible - | Declarations.Cumulative_ind cumi -> - let num_param_arity = - mind.Declarations.mind_nparams + - mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - in - if not (num_param_arity = sv1 && num_param_arity = sv2) then - raise Reduction.NotConvertible - else - sigma_check_inductive_instances cv_pb cumi u1 u2 sigma - -let sigma_conv_constructors - (mind, ind, cns) u1 sv1 u2 sv2 sigma = - try sigma_compare_instances ~flex:false u1 u2 sigma with - Reduction.NotConvertible -> - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - raise Reduction.NotConvertible - | Declarations.Polymorphic_ind _ -> - raise Reduction.NotConvertible - | Declarations.Cumulative_ind cumi -> - let num_cnstr_args = - let nparamsctxt = - mind.Declarations.mind_nparams + - mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - in - nparamsctxt + - mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(cns - 1) - in - if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then - raise Reduction.NotConvertible - else - sigma_check_inductive_instances Reduction.CONV cumi u1 u2 sigma +let sigma_check_inductive_instances csts sigma = + try Evd.add_constraints sigma csts + with Evd.UniversesDiffer + | Univ.UniverseInconsistency _ -> + raise Reduction.NotConvertible let sigma_univ_state = - { Reduction.compare = sigma_compare_sorts; - Reduction.compare_instances = sigma_compare_instances; - Reduction.conv_inductives = sigma_conv_inductives; - Reduction.conv_constructors = sigma_conv_constructors} + let open Reduction in + { compare_sorts = sigma_compare_sorts; + compare_instances = sigma_compare_instances; + compare_cumul_instances = sigma_check_inductive_instances; } let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = @@ -1685,7 +1583,7 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = if isConstruct sigma t_o then whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'') else s,csts' - |_, ((Stack.App _| Stack.Shift _|Stack.Update _|Stack.Cst _) :: _|[]) -> s,csts' + |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts' in whrec csts s let find_conclusion env sigma = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index db0c29aef..0565baf45 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -82,8 +82,6 @@ module Stack : sig | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list val pr : ('a -> Pp.t) -> 'a t -> Pp.t @@ -102,12 +100,12 @@ module Stack : sig @return the result and the lifts to apply on the terms @raise IncompatibleFold2 when [sk1] and [sk2] have incompatible shapes *) val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> - constr t -> constr t -> 'a * int * int + constr t -> constr t -> 'a val map : ('a -> 'a) -> 'a t -> 'a t 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 or Shift *) + start by App *) val strip_app : 'a t -> 'a t * 'a t (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option @@ -170,9 +168,9 @@ val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function (** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) -val nf_beta : local_reduction_function -val nf_betaiota : local_reduction_function -val nf_betaiotazeta : local_reduction_function +val nf_beta : reduction_function +val nf_betaiota : reduction_function +val nf_betaiotazeta : reduction_function val nf_all : reduction_function val nf_evar : evar_map -> constr -> constr @@ -262,7 +260,7 @@ val is_transparent : Environ.env -> Constant.t tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) -type conversion_test = constraints -> constraints +type conversion_test = Constraint.t -> Constraint.t val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5dd6879d3..00b175c48 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -166,23 +166,6 @@ let retype ?(polyprop=true) sigma = | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) - and sort_family_of env t = - match EConstr.kind sigma t with - | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) - | Sort _ -> InType - | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in - if not (is_impredicative_set env) && - s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env sigma f -> - let t = type_of_global_reference_knowing_parameters env f args in - Sorts.family (sort_of_atomic_type env sigma t args) - | App(f,args) -> - Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) - | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | _ -> - Sorts.family (decomp_sort env sigma (type_of env t)) - and type_of_global_reference_knowing_parameters env c args = let argtyps = Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in @@ -198,15 +181,34 @@ let retype ?(polyprop=true) sigma = EConstr.of_constr (type_of_constructor env (cstr, u)) | _ -> assert false - in type_of, sort_of, sort_family_of, - type_of_global_reference_knowing_parameters + in type_of, sort_of, type_of_global_reference_knowing_parameters + +let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = + let type_of,_,type_of_global_reference_knowing_parameters = retype ~polyprop sigma in + let rec sort_family_of env t = + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) + | Sort _ -> InType + | Prod (name,t,c2) -> + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + if not (is_impredicative_set env) && + s2 == InSet && sort_family_of env t == InType then InType else s2 + | App(f,args) when is_template_polymorphic env sigma f -> + if truncation_style then InType else + let t = type_of_global_reference_knowing_parameters env f args in + Sorts.family (sort_of_atomic_type env sigma t args) + | App(f,args) -> + Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) + | Lambda _ | Fix _ | Construct _ -> retype_error NotAType + | Ind _ when truncation_style && is_template_polymorphic env sigma t -> InType + | _ -> + Sorts.family (decomp_sort env sigma (type_of env t)) + in sort_family_of env t let get_sort_of ?(polyprop=true) env sigma t = - let _,f,_,_ = retype ~polyprop sigma in anomaly_on_error (f env) t -let get_sort_family_of ?(polyprop=true) env sigma c = - let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c + let _,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) t let type_of_global_reference_knowing_parameters env sigma c args = - let _,_,_,f = retype sigma in anomaly_on_error (f env c) args + let _,_,f = retype sigma in anomaly_on_error (f env c) args let type_of_global_reference_knowing_conclusion env sigma c conclty = match EConstr.kind sigma c with @@ -225,14 +227,14 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = (* let f,_,_,_ = retype ~polyprop sigma in *) (* if lax then f env c else anomaly_on_error (f env) c *) -(* let get_type_of_key = Profile.declare_profile "get_type_of" *) -(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *) +(* let get_type_of_key = CProfile.declare_profile "get_type_of" *) +(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *) (* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) (* get_type_of polyprop lax env sigma c *) let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = - let f,_,_,_ = retype ~polyprop sigma in + let f,_,_ = retype ~polyprop sigma in if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index af86df499..6fdde9046 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -31,8 +31,11 @@ val get_type_of : val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> Sorts.t +(* When [truncation_style] is [true], tells if the type has been explicitly + truncated to Prop or (impredicative) Set; in particular, singleton type and + small inductive types, which have all eliminations to Type, are in Type *) val get_sort_family_of : - ?polyprop:bool -> env -> evar_map -> types -> Sorts.family + ?truncation_style:bool -> ?polyprop:bool -> env -> evar_map -> types -> Sorts.family (** Makes an unsafe judgment from a constr *) val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 85383ba39..9b9408698 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -60,9 +60,7 @@ let value_of_evaluable_ref env evref u = match evref with | EvalConstRef con -> let u = Unsafe.to_instance u in - EConstr.of_constr (try constant_value_in env (con,u) - with NotEvaluableConst IsProj -> - raise (Invalid_argument "value_of_evaluable_ref")) + EConstr.of_constr (constant_value_in env (con, u)) | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get let evaluable_of_global_reference env = function @@ -476,7 +474,7 @@ let contract_fix_use_function env sigma f let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in - substl_checking_arity env (List.rev lbodies) sigma (nf_beta sigma bodies.(bodynum)) + substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) let reduce_fix_use_function env sigma f whfun fix stack = match fix_recarg fix (Stack.append_app_list stack Stack.empty) with @@ -500,7 +498,7 @@ let contract_cofix_use_function env sigma f let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in substl_checking_arity env (List.rev subbodies) - sigma (nf_beta sigma bodies.(bodynum)) + sigma (nf_beta env sigma bodies.(bodynum)) let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with @@ -697,7 +695,7 @@ let rec red_elim_const env sigma ref u largs = let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) + | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in @@ -712,7 +710,7 @@ let rec red_elim_const env sigma ref u largs = let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) + | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in (whd_betaiotazeta sigma (applist (c, largs)), []), nocase @@ -927,8 +925,8 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_stack = if Flags.profile then - let key = Profile.declare_profile "whd_simpl_stack" in - Profile.profile3 key whd_simpl_stack + let key = CProfile.declare_profile "whd_simpl_stack" in + CProfile.profile3 key whd_simpl_stack else whd_simpl_stack (* Same as [whd_simpl] but also reduces constants that do not hide a @@ -1103,7 +1101,7 @@ let unfoldoccs env sigma (occs,name) c = | [] -> () | _ -> error_invalid_occurrence rest in - nf_betaiotazeta sigma uc + nf_betaiotazeta env sigma uc in match occs with | NoOccurrences -> c @@ -1284,7 +1282,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = else raise Not_found with Not_found -> try - let t' = nf_betaiota sigma (one_step_reduce env sigma t) in + let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 2e213a51d..3f947fd23 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -65,7 +65,7 @@ type typeclass = { cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : (global_reference * bool) option list * Context.Rel.t; + cl_context : global_reference option list * Context.Rel.t; (* Context of definitions and properties on defs, will not be shared *) cl_props : Context.Rel.t; @@ -87,7 +87,6 @@ type instance = { (* Sections where the instance should be redeclared, None for discard, Some 0 for none. *) is_global: int option; - is_poly: bool; is_impl: global_reference; } @@ -97,7 +96,7 @@ let instance_impl is = is.is_impl let hint_priority is = is.is_info.Vernacexpr.hint_priority -let new_instance cl info glob poly impl = +let new_instance cl info glob impl = let global = if glob then Some (Lib.sections_depth ()) else None @@ -107,7 +106,6 @@ let new_instance cl info glob poly impl = { is_class = cl.cl_impl; is_info = info ; is_global = global ; - is_poly = poly; is_impl = impl } (* @@ -175,7 +173,7 @@ let subst_class (subst,cl) = and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx = List.smartmap (RelDecl.map_constr do_subst) in let do_subst_context (grs,ctx) = - List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, + List.smartmap (Option.smartmap do_subst_gr) grs, do_subst_ctx ctx in let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in @@ -213,15 +211,16 @@ let discharge_class (_,cl) = let newgrs = List.map (fun decl -> match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr Evd.empty with | None -> None - | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) + | Some (_, ((tc,_), _)) -> Some tc.cl_impl) ctx' in - List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + List.smartmap (Option.smartmap Lib.discharge_global) grs @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx, _, _ as info = abs_context cl in + let info = abs_context cl in + let ctx = info.Lib.abstr_ctx in let ctx, subst = rel_of_variable_context ctx in let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in let context = discharge_context ctx (subst, usubst) cl.cl_context in @@ -420,7 +419,7 @@ let declare_instance info local glob = match class_of_constr Evd.empty (EConstr.of_constr ty) with | Some (rels, ((tc,_), args) as _cl) -> assert (not (isVarRef glob) || local); - add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob) + add_instance (new_instance tc info (not local) glob) | None -> () let add_class cl = @@ -442,19 +441,20 @@ let add_class cl = let instance_constructor (cl,u) args = let lenpars = List.count is_local_assum (snd cl.cl_context) in + let open EConstr in let pars = fst (List.chop lenpars args) in match cl.cl_impl with | IndRef ind -> let ind = ind, u in - (Some (applistc (mkConstructUi (ind, 1)) args), - applistc (mkIndU ind) pars) + (Some (applist (mkConstructUi (ind, 1), args)), + applist (mkIndU ind, pars)) | ConstRef cst -> let cst = cst, u in let term = match args with | [] -> None | _ -> Some (List.last args) in - (term, applistc (mkConstU cst) pars) + (term, applist (mkConstU cst, pars)) | _ -> assert false let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] @@ -552,8 +552,8 @@ let solve_all_instances env evd filter unique split fail = Hook.get get_solve_all_instances env evd filter unique split fail (** Profiling resolution of typeclasses *) -(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *) -(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *) +(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *) +(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *) let resolve_typeclasses ?(fast_path = true) ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ()) ?(split=true) ?(fail=true) env evd = diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 618826f3d..ee28ec173 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -25,9 +25,8 @@ type typeclass = { cl_impl : global_reference; (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. - The boolean indicates if the typeclass argument is a direct superclass and the global reference - gives a direct link to the class itself. *) - cl_context : (global_reference * bool) option list * Context.Rel.t; + The global reference gives a direct link to the class itself. *) + cl_context : global_reference option list * Context.Rel.t; (** Context of definitions and properties on defs, will not be shared *) cl_props : Context.Rel.t; @@ -54,7 +53,7 @@ val all_instances : unit -> instance list val add_class : typeclass -> unit -val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic -> +val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit @@ -83,8 +82,8 @@ val is_instance : global_reference -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass Univ.puniverses -> constr list -> - constr option * types +val instance_constructor : typeclass EConstr.puniverses -> EConstr.t list -> + EConstr.t option * EConstr.t (** Filter which evars to consider for resolution. *) type evar_filter = Evar.t -> Evar_kinds.t -> bool diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 43066c809..3132d2ad5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -23,11 +23,6 @@ open Arguments_renaming open Pretype_errors open Context.Rel.Declaration -let push_rec_types pfix env = - let (i, c, t) = pfix in - let inj c = EConstr.Unsafe.to_constr c in - push_rec_types (i, Array.map inj c, Array.map inj t) env - let meta_type evd mv = let ty = try Evd.meta_ftype evd mv diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 9f084ae8d..153a48a71 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -53,3 +53,4 @@ val judge_of_abstraction : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment val judge_of_product : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment +val judge_of_projection : env -> evar_map -> projection -> unsafe_judgment -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 84ffab426..e1720ec95 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module CVars = Vars - open CErrors open Pp open Util @@ -196,7 +194,7 @@ let pose_all_metas_as_evars env evd t = let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let ty = if Flags.version_strictly_greater Flags.V8_6 || Flags.version_less_or_equal Flags.VOld - then nf_betaiota evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *) + then nf_betaiota env evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *) else ty (* some beta-iota-normalization "regression" in 8.5 and 8.6 *) in let src = Evd.evar_source_of_meta mv !evdref in let ev = Evarutil.e_new_evar env evdref ~src ty in @@ -666,7 +664,7 @@ let is_eta_constructor_app env sigma ts f l1 term = | Construct (((_, i as ind), j), u) when i == 0 && j == 1 -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with - | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite && + | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Declarations.BiFinite && Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (** Check that the other term is neutral *) is_neutral env sigma ts term @@ -1077,13 +1075,13 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e in try let opt' = {opt with with_types = false} in - let (substn,_,_) = Reductionops.Stack.fold2 + let substn = Reductionops.Stack.fold2 (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) (evd,ms,es) us2 us in - let (substn,_,_) = Reductionops.Stack.fold2 + let substn = Reductionops.Stack.fold2 (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) substn params1 params in - let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in + let substn = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in let app = mkApp (c, Array.rev_of_list ks) in (* let substn = unirec_rec curenvnb pb b false substn t cN in *) unirec_rec curenvnb pb opt' substn c1 app @@ -1279,7 +1277,7 @@ let w_coerce env evd mv c = let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in let t = get_type_of env sigma (nf_meta sigma c) in - let t = nf_betaiota sigma (nf_meta sigma t) in + let t = nf_betaiota env sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = @@ -1527,7 +1525,7 @@ let indirectly_dependent sigma c d decls = let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - (sigma, EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c)))) + (sigma, EConstr.of_constr (Universes.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c)))) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1617,7 +1615,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = | Some (sigma,_,l) -> let c = applist (nf_evar sigma (local_strong whd_meta sigma c), l) in let univs, subst = nf_univ_variables sigma in - Some (sigma,EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) + Some (sigma,EConstr.of_constr (Universes.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) let make_eq_test env evd c = let out cstr = @@ -2015,8 +2013,8 @@ let w_unify env evd cv_pb flags ty1 ty2 = let w_unify = if Flags.profile then - let wunifkey = Profile.declare_profile "w_unify" in - Profile.profile6 wunifkey w_unify + let wunifkey = CProfile.declare_profile "w_unify" in + CProfile.profile6 wunifkey w_unify else w_unify let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b5b8987e3..c93b41786 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -15,6 +15,7 @@ open Vars open Environ open Inductive open Reduction +open Vmvalues open Vm open Context.Rel.Declaration @@ -134,7 +135,7 @@ let build_case_type dep p realargs c = (* La fonction de normalisation *) -let rec nf_val env sigma v t = nf_whd env sigma (whd_val v) t +let rec nf_val env sigma v t = nf_whd env sigma (Vmvalues.whd_val v) t and nf_vtype env sigma v = nf_val env sigma v crazy_type @@ -144,7 +145,7 @@ and nf_whd env sigma whd typ = | Vprod p -> let dom = nf_vtype env sigma (dom p) in let name = Name (Id.of_string "x") in - let vc = body_of_vfun (nb_rel env) (codom p) in + let vc = reduce_fun (nb_rel env) (codom p) in let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env sigma f typ @@ -191,7 +192,7 @@ and nf_univ_args ~nb_univs mk env sigma stk = else match stk with | Zapp args :: _ -> let inst = - Array.init nb_univs (fun i -> Vm.uni_lvl_val (arg args i)) + Array.init nb_univs (fun i -> uni_lvl_val (arg args i)) in Univ.Instance.of_array inst | _ -> assert false @@ -239,8 +240,9 @@ and nf_stk ?from:(from=0) env sigma c t stk = let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.Array.chop nparams allargs in + let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = - hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in + hnf_prod_applist_assum env nparamdecls (type_of_ind env (ind,u)) (Array.to_list params) in let pT = whd_all env pT in let dep, p = nf_predicate env sigma (ind,u) mip params (type_of_switch sw) pT in (* Calcul du type des branches *) @@ -254,7 +256,7 @@ and nf_stk ?from:(from=0) env sigma c t stk = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type dep p realargs c in - let ci = case_info sw in + let ci = sw.sw_annot.Cbytecodes.ci in nf_stk env sigma (mkCase(ci, p, c, branchs)) tcase stk | Zproj p :: stk -> assert (from = 0) ; @@ -266,14 +268,14 @@ and nf_predicate env sigma ind mip params v pT = match whd_val v, kind pT with | Vfun f, Prod _ -> let k = nb_rel env in - let vb = body_of_vfun k f in + let vb = reduce_fun k f in let name,dom,codom = decompose_prod env pT in let dep,body = nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in - let vb = body_of_vfun k f in + let vb = reduce_fun k f in let name = Name (Id.of_string "c") in let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in @@ -307,7 +309,7 @@ and nf_bargs env sigma b ofs t = and nf_fun env sigma f typ = let k = nb_rel env in - let vb = body_of_vfun k f in + let vb = reduce_fun k f in let name,dom,codom = try decompose_prod env typ with DestKO -> @@ -365,4 +367,4 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) ~catch_incon:true ~pb env sigma t1 t2 -let _ = Reductionops.set_vm_infer_conv vm_infer_conv +let _ = if Coq_config.bytecode_compiler then Reductionops.set_vm_infer_conv vm_infer_conv diff --git a/printing/genprint.ml b/printing/genprint.ml index 776a212b5..37a94fe21 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -16,21 +16,27 @@ open Geninterp (* Printing generic values *) -type printer_with_level = +type 'a with_level = { default_already_surrounded : Notation_term.tolerability; default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) -| PrinterNeedsContextAndLevel of printer_with_level +| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level -type 'a printer = 'a -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t -type 'a top_printer = 'a -> printer_result +type top_printer_result = +| TopPrinterBasic of (unit -> Pp.t) +| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level -module ValMap = ValTMap (struct type 'a t = 'a -> printer_result end) +type 'a printer = 'a -> printer_result + +type 'a top_printer = 'a -> top_printer_result + +module ValMap = ValTMap (struct type 'a t = 'a -> top_printer_result end) let print0_val_map = ref ValMap.empty @@ -48,32 +54,32 @@ let register_val_print0 s pr = print0_val_map := ValMap.add s pr !print0_val_map let combine_dont_needs pr_pair pr1 = function - | PrinterBasic pr2 -> - PrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ())) - | PrinterNeedsContext pr2 -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterBasic pr2 -> + TopPrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ())) + | TopPrinterNeedsContext pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 ()) (pr2 env sigma)) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 ()) (printer env sigma default_ensure_surrounded)) let combine_needs pr_pair pr1 = function - | PrinterBasic pr2 -> - PrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ())) - | PrinterNeedsContext pr2 -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterBasic pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ())) + | TopPrinterNeedsContext pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 env sigma)) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (printer env sigma default_ensure_surrounded)) let combine pr_pair pr1 v2 = match pr1 with - | PrinterBasic pr1 -> + | TopPrinterBasic pr1 -> combine_dont_needs pr_pair pr1 (generic_val_print v2) - | PrinterNeedsContext pr1 -> + | TopPrinterNeedsContext pr1 -> combine_needs pr_pair pr1 (generic_val_print v2) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> combine_needs pr_pair (fun env sigma -> printer env sigma default_ensure_surrounded) (generic_val_print v2) @@ -81,14 +87,14 @@ let _ = let pr_cons a b = Pp.(a ++ spc () ++ b) in register_val_print0 Val.typ_list (function - | [] -> PrinterBasic mt + | [] -> TopPrinterBasic mt | a::l -> List.fold_left (combine pr_cons) (generic_val_print a) l) let _ = register_val_print0 Val.typ_opt (function - | None -> PrinterBasic Pp.mt + | None -> TopPrinterBasic Pp.mt | Some v -> generic_val_print v) let _ = @@ -99,9 +105,9 @@ let _ = (* Printing generic arguments *) type ('raw, 'glb, 'top) genprinter = { - raw : 'raw printer; - glb : 'glb printer; - top : 'top -> printer_result; + raw : 'raw -> printer_result; + glb : 'glb -> printer_result; + top : 'top -> top_printer_result; } module PrintObj = @@ -112,9 +118,9 @@ struct | ExtraArg tag -> let name = ArgT.repr tag in let printer = { - raw = (fun _ -> str "<genarg:" ++ str name ++ str ">"); - glb = (fun _ -> str "<genarg:" ++ str name ++ str ">"); - top = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + raw = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + glb = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + top = (fun _ -> TopPrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); } in Some printer | _ -> assert false diff --git a/printing/genprint.mli b/printing/genprint.mli index 2da9bbc36..baa60fcb2 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -10,19 +10,25 @@ open Genarg -type printer_with_level = +type 'a with_level = { default_already_surrounded : Notation_term.tolerability; default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) -| PrinterNeedsContextAndLevel of printer_with_level +| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level -type 'a printer = 'a -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t -type 'a top_printer = 'a -> printer_result +type top_printer_result = +| TopPrinterBasic of (unit -> Pp.t) +| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level + +type 'a printer = 'a -> printer_result + +type 'a top_printer = 'a -> top_printer_result val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw printer (** Printer for raw level generic arguments. *) @@ -34,7 +40,7 @@ val top_print : ('raw, 'glb, 'top) genarg_type -> 'top top_printer (** Printer for top level generic arguments. *) val register_print0 : ('raw, 'glb, 'top) genarg_type -> - 'raw printer -> 'glb printer -> ('top -> printer_result) -> unit + 'raw printer -> 'glb printer -> 'top top_printer -> unit val register_val_print0 : 'top Geninterp.Val.typ -> 'top top_printer -> unit val register_vernac_print0 : ('raw, 'glb, 'top) genarg_type -> diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index bce5710d6..873505940 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -86,8 +86,8 @@ let tag_var = tag Tag.variable open Notation - let print_hunks n pr pr_binders (terms, termlists, binders) unps = - let env = ref terms and envlist = ref termlists and bll = ref binders in + let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = + let env = ref terms and envlist = ref termlists and bl = ref binders and bll = ref binderlists in let pop r = let a = List.hd !r in r := List.tl !r; a in let return unp pp1 pp2 = (tag_unparsing unp pp1) ++ pp2 in (* Warning: @@ -102,6 +102,11 @@ let tag_var = tag Tag.variable let pp2 = aux l in let pp1 = pr (n, prec) c in return unp pp1 pp2 + | UnpBinderMetaVar (_, prec) as unp :: l -> + let c = pop bl in + let pp2 = aux l in + let pp1 = pr_patt (n, prec) c in + return unp pp1 pp2 | UnpListMetaVar (_, prec, sl) as unp :: l -> let cl = pop envlist in let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in @@ -127,9 +132,9 @@ let tag_var = tag Tag.variable in aux unps - let pr_notation pr pr_binders s env = + let pr_notation pr pr_patt pr_binders s env = let unpl, level = find_notation_printing_rule s in - print_hunks level pr pr_binders env unpl, level + print_hunks level pr pr_patt pr_binders env unpl, level let pr_delimiters key strm = strm ++ str ("%"^key) @@ -150,10 +155,15 @@ let tag_var = tag Tag.variable let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) + let pr_univ_expr = function + | Some (x,n) -> + pr_reference x ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) + | None -> str"_" + let pr_univ l = match l with - | [_,x] -> Name.print x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> Name.print (snd x)) l ++ str")" + | [x] -> pr_univ_expr x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") pr_univ_expr l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -166,8 +176,9 @@ let tag_var = tag Tag.variable let pr_glob_level = function | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") - | GType None -> tag_type (str "Type") - | GType (Some (_, u)) -> tag_type (Name.print u) + | GType UUnknown -> tag_type (str "Type") + | GType UAnonymous -> tag_type (str "_") + | GType (UNamed u) -> tag_type (pr_reference u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -192,8 +203,9 @@ let tag_var = tag Tag.variable tag_type (str "Set") | GType u -> (match u with - | Some (_,u) -> Name.print u - | None -> tag_type (str "Type")) + | UNamed u -> pr_reference u + | UAnonymous -> tag_type (str "Type") + | UUnknown -> tag_type (str "_")) let pr_universe_instance l = pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l @@ -256,8 +268,8 @@ let tag_var = tag Tag.variable in str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec - | CPatAlias (p, id) -> - pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las + | CPatAlias (p, na) -> + pr_patt mt (las,E) p ++ str " as " ++ pr_lname na, las | CPatCstr (c, None, []) -> pr_reference c, latom @@ -279,13 +291,13 @@ let tag_var = tag Tag.variable pr_reference r, latom | CPatOr pl -> - hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator + hov 0 (prlist_with_sep pr_spcbar (pr_patt mt (lpator,L)) pl), lpator | CPatNotation ("( _ )",([p],[]),[]) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom | CPatNotation (s,(l,ll),args) -> - let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) in + let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ -> mt ()) (fun _ _ _ -> mt()) s (l,ll,[],[]) in (if List.is_empty args||prec_less l_not (lapp,L) then strm_not else surround strm_not) ++ prlist (pr_patt spc (lapp,L)) args, if not (List.is_empty args) then lapp else l_not @@ -304,11 +316,10 @@ let tag_var = tag Tag.variable let pr_patt = pr_patt mt let pr_eqn pr (loc,(pl,rhs)) = - let pl = List.map snd pl in spc() ++ hov 4 (pr_with_comments ?loc (str "| " ++ - hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl + hov 0 (prlist_with_sep pr_spcbar (prlist_with_sep sep_v (pr_patt ltop)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) @@ -388,68 +399,6 @@ let tag_var = tag Tag.variable if is_open then pr_delimited_binders pr_com_at sep pr_c else pr_undelimited_binders sep pr_c - let rec extract_prod_binders = let open CAst in function - (* | CLetIn (loc,na,b,c) as x -> - let bl,c = extract_prod_binders c in - if bl = [] then [], x else CLocalDef (na,b) :: bl, c*) - | { v = CProdN ([],c) } -> - extract_prod_binders c - | { loc; v = CProdN ([[_,Name id],bk,t], - { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) } - when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> - let bl,c = extract_prod_binders b in - CLocalPattern (loc, (p,None)) :: bl, c - | { loc; v = CProdN ((nal,bk,t)::bl,c) } -> - let bl,c = extract_prod_binders (CAst.make ?loc @@ CProdN(bl,c)) in - CLocalAssum (nal,bk,t) :: bl, c - | c -> [], c - - let rec extract_lam_binders ce = let open CAst in match ce.v with - (* | CLetIn (loc,na,b,c) as x -> - let bl,c = extract_lam_binders c in - if bl = [] then [], x else CLocalDef (na,b) :: bl, c*) - | CLambdaN ([],c) -> - extract_lam_binders c - | CLambdaN ([[_,Name id],bk,t], - { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) - when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> - let bl,c = extract_lam_binders b in - CLocalPattern (ce.loc,(p,None)) :: bl, c - | CLambdaN ((nal,bk,t)::bl,c) -> - let bl,c = extract_lam_binders (CAst.make ?loc:ce.loc @@ CLambdaN(bl,c)) in - CLocalAssum (nal,bk,t) :: bl, c - | _ -> [], ce - - let split_lambda = CAst.with_loc_val (fun ?loc -> function - | CLambdaN ([[na],bk,t],c) -> (na,t,c) - | CLambdaN (([na],bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN(bl,c)) - | CLambdaN ((na::nal,bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN((nal,bk,t)::bl,c)) - | _ -> anomaly (Pp.str "ill-formed fixpoint body.") - ) - - let rename na na' t c = - match (na,na') with - | (_,Name id), (_,Name id') -> - (na',t,replace_vars_constr_expr (Id.Map.singleton id id') c) - | (_,Name id), (_,Anonymous) -> (na,t,c) - | _ -> (na',t,c) - - let split_product na' = CAst.with_loc_val (fun ?loc -> function - | CProdN ([[na],bk,t],c) -> rename na na' t c - | CProdN (([na],bk,t)::bl,c) -> rename na na' t (CAst.make ?loc @@ CProdN(bl,c)) - | CProdN ((na::nal,bk,t)::bl,c) -> - rename na na' t (CAst.make ?loc @@ CProdN((nal,bk,t)::bl,c)) - | _ -> anomaly (Pp.str "ill-formed fixpoint body.") - ) - - let rec split_fix n typ def = - if Int.equal n 0 then ([],typ,def) - else - let (na,_,def) = split_lambda def in - let (na,t,typ) = split_product na typ in - let (bl,typ,def) = split_fix (n-1) typ def in - (CLocalAssum ([na],default_binder_kind,t)::bl,typ,def) - let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = let pr_body = if dangling_with_for then pr_dangling else pr in @@ -568,8 +517,7 @@ let tag_var = tag Tag.variable (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix), lfix ) - | CProdN _ -> - let (bl,a) = extract_prod_binders a in + | CProdN (bl,a) -> return ( hov 0 ( hov 2 (pr_delimited_binders pr_forall spc @@ -577,8 +525,7 @@ let tag_var = tag Tag.variable str "," ++ pr spc ltop a), lprod ) - | CLambdaN _ -> - let (bl,a) = extract_lam_binders a in + | CLambdaN (bl,a) -> return ( hov 0 ( hov 2 (pr_delimited_binders pr_fun spc @@ -643,7 +590,7 @@ let tag_var = tag Tag.variable hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"), latom ) - | CCases (LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,([(loc,[p])],b))]) -> + | CCases (LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,([[p]],b))]) -> return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ @@ -716,16 +663,19 @@ let tag_var = tag Tag.variable | CastCoerce -> str ":>"), lcast ) - | CNotation ("( _ )",([t],[],[])) -> + | CNotation ("( _ )",([t],[],[],[])) -> return (pr (fun()->str"(") (max_int,L) t ++ str")", latom) | CNotation (s,env) -> - pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env + pr_notation (pr mt) pr_patt (pr_binders_gen (pr mt ltop)) s env | CGeneralization (bk,ak,c) -> return (pr_generalization bk ak (pr mt ltop c), latom) | CPrim p -> return (pr_prim_token p, prec_of_prim_token p) | CDelimiters (sc,a) -> return (pr_delimiters sc (pr mt (ldelim,E) a), ldelim) + | CProj (p,c) -> + let p = pr_proj (pr mt) pr_app c (CAst.make (CRef (p,None))) [] in + return (p, lproj) in let loc = constr_loc a in pr_with_comments ?loc diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1320cce9b..158906dd2 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -17,14 +17,6 @@ open Names open Misctypes open Notation_term -val extract_lam_binders : - constr_expr -> local_binder_expr list * constr_expr -val extract_prod_binders : - constr_expr -> local_binder_expr list * constr_expr -val split_fix : - int -> constr_expr -> constr_expr -> - local_binder_expr list * constr_expr * constr_expr - val prec_less : precedence -> tolerability -> bool val pr_tight_coma : unit -> Pp.t diff --git a/printing/pputils.ml b/printing/pputils.ml index 12d5338ad..a544b4762 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -130,7 +130,10 @@ let rec pr_raw_generic env (GenArg (Rawwit wit, x)) = let q = in_gen (rawwit wit2) q in hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q]) | ExtraArg s -> - Genprint.generic_raw_print (in_gen (rawwit wit) x) + let open Genprint in + match generic_raw_print (in_gen (rawwit wit) x) with + | PrinterBasic pp -> pp () + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = @@ -152,4 +155,7 @@ let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = let ans = pr_sequence (pr_glb_generic env) [p; q] in hov_if_not_empty 0 ans | ExtraArg s -> - Genprint.generic_glb_print (in_gen (glbwit wit) x) + let open Genprint in + match generic_glb_print (in_gen (glbwit wit) x) with + | PrinterBasic pp -> pp () + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 1a74538aa..31c0d20f3 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -31,12 +31,6 @@ open Decl_kinds let pr_lconstr = pr_lconstr_expr let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr - let pr_lident (loc,id) = - match loc with - | None -> pr_id id - | Some loc -> let (b,_) = Loc.unloc loc in - pr_located pr_id @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (Id.to_string id))) id - let pr_uconstraint (l, d, r) = pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_glob_level r @@ -77,9 +71,8 @@ open Decl_kinds | Some loc -> let (b,_) = Loc.unloc loc in pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid - let pr_lname = function - | (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located Name.print lna + let pr_lname_decl (n, u) = + pr_lname n ++ pr_universe_decl u let pr_smart_global = Pputils.pr_or_by_notation pr_reference @@ -91,7 +84,7 @@ open Decl_kinds let sep_end = function | VernacBullet _ - | VernacSubproof None + | VernacSubproof _ | VernacEndSubproof -> str"" | _ -> str"." @@ -100,16 +93,35 @@ open Decl_kinds let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() - let pr_set_entry_type = function + let pr_at_level = function + | NumLevel n -> keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n + | NextLevel -> keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level" + + let pr_constr_as_binder_kind = function + | AsIdent -> keyword "as ident" + | AsIdentOrPattern -> keyword "as pattern" + | AsStrictPattern -> keyword "as strict pattern" + + let pr_strict b = if b then str "strict " else mt () + + let pr_set_entry_type pr = function | ETName -> str"ident" | ETReference -> str"global" - | ETPattern -> str"pattern" - | ETConstr _ -> str"constr" + | ETPattern (b,None) -> pr_strict b ++ str"pattern" + | ETPattern (b,Some n) -> pr_strict b ++ str"pattern" ++ spc () ++ pr_at_level (NumLevel n) + | ETConstr lev -> str"constr" ++ pr lev | ETOther (_,e) -> str e + | ETConstrAsBinder (bk,lev) -> pr lev ++ spc () ++ pr_constr_as_binder_kind bk | ETBigint -> str "bigint" | ETBinder true -> str "binder" | ETBinder false -> str "closed binder" - | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type" + + let pr_at_level_opt = function + | None -> mt () + | Some n -> spc () ++ pr_at_level n + + let pr_set_simple_entry_type = + pr_set_entry_type pr_at_level_opt let pr_comment pr_c = function | CommentConstr c -> pr_c c @@ -324,23 +336,18 @@ open Decl_kinds | SortClass -> keyword "Sortclass" | RefClass qid -> pr_smart_global qid - let pr_assumption_token many (l,a) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - match l, a with - | (Discharge,Logical) -> - keyword (if many then "Hypotheses" else "Hypothesis") - | (Discharge,Definitional) -> - keyword (if many then "Variables" else "Variable") - | (Global,Logical) -> + let pr_assumption_token many discharge kind = + match discharge, kind with + | (NoDischarge,Logical) -> keyword (if many then "Axioms" else "Axiom") - | (Global,Definitional) -> + | (NoDischarge,Definitional) -> keyword (if many then "Parameters" else "Parameter") - | (Local, Logical) -> - keyword (if many then "Local Axioms" else "Local Axiom") - | (Local,Definitional) -> - keyword (if many then "Local Parameters" else "Local Parameter") - | (Global,Conjectural) -> str"Conjecture" - | ((Discharge | Local),Conjectural) -> + | (NoDischarge,Conjectural) -> str"Conjecture" + | (DoDischarge,Logical) -> + keyword (if many then "Hypotheses" else "Hypothesis") + | (DoDischarge,Definitional) -> + keyword (if many then "Variables" else "Variable") + | (DoDischarge,Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") let pr_params pr_c (xl,(c,t)) = @@ -372,17 +379,16 @@ open Decl_kinds let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k) let pr_syntax_modifier = function - | SetItemLevel (l,NextLevel) -> - prlist_with_sep sep_v2 str l ++ - spc() ++ keyword "at next level" - | SetItemLevel (l,NumLevel n) -> + | SetItemLevel (l,n) -> + prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level n + | SetItemLevelAsBinder (l,bk,n) -> prlist_with_sep sep_v2 str l ++ - spc() ++ keyword "at level" ++ spc() ++ int n - | SetLevel n -> keyword "at level" ++ spc() ++ int n + spc() ++ pr_at_level_opt n ++ spc() ++ pr_constr_as_binder_kind bk + | SetLevel n -> pr_at_level (NumLevel n) | SetAssoc LeftA -> keyword "left associativity" | SetAssoc RightA -> keyword "right associativity" | SetAssoc NonA -> keyword "no associativity" - | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ + | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_simple_entry_type typ | SetOnlyPrinting -> keyword "only printing" | SetOnlyParsing -> keyword "only parsing" | SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"") @@ -403,8 +409,6 @@ open Decl_kinds ++ prlist (pr_decl_notation pr_constr) ntn let pr_statement head (idpl,(bl,c)) = - assert (not (Option.is_empty idpl)); - let idpl = Option.get idpl in hov 2 (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ @@ -540,16 +544,33 @@ open Decl_kinds | SsFwdClose e -> "("^aux e^")*" in Pp.str (aux e) - let rec pr_vernac_body v = + let pr_extend s cl = + let pr_arg a = + try pr_gen a + with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in + try + let rl = Egramml.get_extend_vernac_rule s in + let rec aux rl cl = + match rl, cl with + | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl + | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl + | [], [] -> [] + | _ -> assert false in + hov 1 (pr_sequence identity (aux rl cl)) + with Not_found -> + hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") + + let pr_vernac_expr v = let return = tag_vernac v in match v with - | VernacPolymorphic (poly, v) -> - let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in - return (s ++ spc () ++ pr_vernac_body v) - | VernacProgram v -> - return (keyword "Program" ++ spc() ++ pr_vernac_body v) - | VernacLocal (local, v) -> - return (pr_locality local ++ spc() ++ pr_vernac_body v) + | VernacLoad (f,s) -> + return ( + keyword "Load" + ++ if f then + (spc() ++ keyword "Verbose" ++ spc()) + else + spc() ++ qs s + ) (* Proof management *) | VernacAbortAll -> @@ -560,8 +581,6 @@ open Decl_kinds return (keyword "Unfocus") | VernacUnfocused -> return (keyword "Unfocused") - | VernacGoal c -> - return (keyword "Goal" ++ pr_lconstrarg c) | VernacAbort id -> return (keyword "Abort" ++ pr_opt pr_lident id) | VernacUndo i -> @@ -612,26 +631,8 @@ open Decl_kinds | VernacRestoreState s -> return (keyword "Restore State" ++ spc() ++ qs s) - (* Control *) - | VernacLoad (f,s) -> - return ( - keyword "Load" - ++ if f then - (spc() ++ keyword "Verbose" ++ spc()) - else - spc() ++ qs s - ) - | VernacTime (_,v) -> - return (keyword "Time" ++ spc() ++ pr_vernac_body v) - | VernacRedirect (s, (_,v)) -> - return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_body v) - | VernacTimeout(n,v) -> - return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_body v) - | VernacFail v -> - return (keyword "Fail" ++ spc() ++ pr_vernac_body v) - (* Syntax *) - | VernacOpenCloseScope (_,(opening,sc)) -> + | VernacOpenCloseScope (opening,sc) -> return ( keyword (if opening then "Open " else "Close ") ++ keyword "Scope" ++ spc() ++ str sc @@ -660,7 +661,7 @@ open Decl_kinds ++ spc() ++ pr_smart_global q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" ) - | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *) + | VernacInfix (((_,s),mv),q,sn) -> (* A Verifier *) return ( hov 0 (hov 0 (keyword "Infix " ++ qs s ++ str " :=" ++ pr_constrarg q) ++ @@ -669,7 +670,7 @@ open Decl_kinds | None -> mt() | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) ) - | VernacNotation (_,c,((_,s),l),opt) -> + | VernacNotation (c,((_,s),l),opt) -> return ( hov 2 (keyword "Notation" ++ spc() ++ qs s ++ str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ @@ -677,7 +678,7 @@ open Decl_kinds | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) ) - | VernacSyntaxExtension (_, _,(s,l)) -> + | VernacSyntaxExtension (_, (s, l)) -> return ( keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++ pr_syntax_modifiers l @@ -688,10 +689,12 @@ open Decl_kinds ) (* Gallina *) - | VernacDefinition (d,id,b) -> (* A verifier... *) - let pr_def_token (l,dk) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - keyword (Kindops.string_of_definition_kind (l,false,dk)) + | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) + let pr_def_token dk = + keyword ( + if Name.is_anonymous (snd (fst id)) + then "Goal" + else Kindops.string_of_definition_object_kind dk) in let pr_reduce = function | None -> mt() @@ -708,12 +711,13 @@ open Decl_kinds in (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) | ProveBody (bl,t) -> - (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in + let typ u = if snd (fst id) = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in + (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in let (binds,typ,c) = pr_def_body b in return ( hov 2 ( - pr_def_token d ++ spc() - ++ pr_ident_decl id ++ binds ++ typ + pr_def_token kind ++ spc() + ++ pr_lname_decl id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) @@ -737,13 +741,13 @@ open Decl_kinds ) | VernacExactProof c -> return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) - | VernacAssumption (stre,t,l) -> + | VernacAssumption ((discharge,kind),t,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in - return (hov 2 (pr_assumption_token (n > 1) stre ++ + return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) | VernacInductive (cum, p,f,l) -> let pr_constructor (coe,(id,c)) = @@ -793,9 +797,8 @@ open Decl_kinds | VernacFixpoint (local, recs) -> let local = match local with - | Some Discharge -> "Let " - | Some Local -> "Local " - | None | Some Global -> "" + | DoDischarge -> "Let " + | NoDischarge -> "" in return ( hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++ @@ -805,9 +808,8 @@ open Decl_kinds | VernacCoFixpoint (local, corecs) -> let local = match local with - | Some Discharge -> keyword "Let" ++ spc () - | Some Local -> keyword "Local" ++ spc () - | None | Some Global -> str "" + | DoDischarge -> keyword "Let" ++ spc () + | NoDischarge -> str "" in let pr_onecorec ((iddecl,bl,c,def),ntn) = pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ @@ -868,14 +870,14 @@ open Decl_kinds return ( keyword "Canonical Structure" ++ spc() ++ pr_smart_global q ) - | VernacCoercion (_,id,c1,c2) -> + | VernacCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Coercion" ++ spc() ++ pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) ) - | VernacIdentityCoercion (_,id,c1,c2) -> + | VernacIdentityCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Identity Coercion" ++ spc() ++ pr_lident id ++ @@ -999,9 +1001,9 @@ open Decl_kinds prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ pr_opt_hintbases dbnames) ) - | VernacHints (_, dbnames,h) -> + | VernacHints (dbnames,h) -> return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) - | VernacSyntacticDefinition (id,(ids,c),_,compat) -> + | VernacSyntacticDefinition (id,(ids,c),compat) -> return ( hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ @@ -1216,26 +1218,34 @@ open Decl_kinds | VernacSubproof None -> return (str "{") | VernacSubproof (Some i) -> - return (keyword "BeginSubproof" ++ spc () ++ int i) + return (Proof_bullet.pr_goal_selector i ++ str ":" ++ spc () ++ str "{") | VernacEndSubproof -> return (str "}") - and pr_extend s cl = - let pr_arg a = - try pr_gen a - with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in - try - let rl = Egramml.get_extend_vernac_rule s in - let rec aux rl cl = - match rl, cl with - | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl - | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl - | [], [] -> [] - | _ -> assert false in - hov 1 (pr_sequence identity (aux rl cl)) - with Not_found -> - hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") +let pr_vernac_flag = + function + | VernacPolymorphic true -> keyword "Polymorphic" + | VernacPolymorphic false -> keyword "Monomorphic" + | VernacProgram -> keyword "Program" + | VernacLocal local -> pr_locality local - let pr_vernac v = - try pr_vernac_body v ++ sep_end v - with e -> CErrors.print e + let rec pr_vernac_control v = + let return = tag_vernac v in + match v with + | VernacExpr (f, v') -> + List.fold_right + (fun f a -> pr_vernac_flag f ++ spc() ++ a) + f + (pr_vernac_expr v' ++ sep_end v') + | VernacTime (_,(_,v)) -> + return (keyword "Time" ++ spc() ++ pr_vernac_control v) + | VernacRedirect (s, (_,v)) -> + return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) + | VernacTimeout(n,v) -> + return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) + | VernacFail v -> + return (keyword "Fail" ++ spc() ++ pr_vernac_control v) + + let pr_vernac v = + try pr_vernac_control v + with e -> CErrors.print e diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index cf27b413c..603be6308 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -9,14 +9,16 @@ (** This module implements pretty-printers for vernac_expr syntactic objects and their subcomponents. *) +val pr_set_entry_type : ('a -> Pp.t) -> 'a Extend.constr_entry_key_gen -> Pp.t + (** Prints a fixpoint body *) val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t -(** Prints a vernac expression *) -val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.t +(** Prints a vernac expression without dot *) +val pr_vernac_expr : Vernacexpr.vernac_expr -> Pp.t (** Prints a "proof using X" clause. *) val pr_using : Vernacexpr.section_subset_expr -> Pp.t (** Prints a vernac expression and closes it with a dot. *) -val pr_vernac : Vernacexpr.vernac_expr -> Pp.t +val pr_vernac : Vernacexpr.vernac_control -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 602b7a496..114a071ee 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -78,6 +78,15 @@ let print_ref reduce ref udecl = in EConstr.it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in + let variance = match ref with + | VarRef _ | ConstRef _ -> None + | IndRef (ind,_) | ConstructRef ((ind,_),_) -> + let mind = Environ.lookup_mind ind (Global.env ()) in + begin match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> None + | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) + end + in let inst = Univ.AUContext.instance univs in let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in @@ -89,7 +98,7 @@ let print_ref reduce ref udecl = else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ - Printer.pr_universe_ctx sigma univs) + Printer.pr_universe_ctx sigma ?variance univs) (********************************) (** Printing implicit arguments *) @@ -235,8 +244,8 @@ let print_type_in_type ref = let print_primitive_record recflag mipv = function | Some (Some (_, ps,_)) -> let eta = match recflag with - | Decl_kinds.CoFinite | Decl_kinds.Finite -> str" without eta conversion" - | Decl_kinds.BiFinite -> str " with eta conversion" + | CoFinite | Finite -> str" without eta conversion" + | BiFinite -> str " with eta conversion" in [Id.print mipv.(0).mind_typename ++ str" has primitive projections" ++ eta ++ str"."] | _ -> [] @@ -360,10 +369,10 @@ let pr_located_qualid = function str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) | Dir dir -> let s,dir = match dir with - | DirOpenModule (dir,_) -> "Open Module", dir - | DirOpenModtype (dir,_) -> "Open Module Type", dir - | DirOpenSection (dir,_) -> "Open Section", dir - | DirModule (dir,_) -> "Module", dir + | DirOpenModule { obj_dir ; _ } -> "Open Module", obj_dir + | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir + | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir + | DirModule { obj_dir ; _ } -> "Module", obj_dir | DirClosedSection dir -> "Closed Section", dir in str s ++ spc () ++ DirPath.print dir @@ -410,7 +419,7 @@ let locate_term qid = let locate_module qid = let all = Nametab.locate_extended_all_dir qid in let map dir = match dir with - | DirModule (_, (mp, _)) -> Some (Dir dir, Nametab.shortest_qualid_of_module mp) + | DirModule { obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp) | DirOpenModule _ -> Some (Dir dir, qid) | _ -> None in @@ -649,8 +658,8 @@ let gallina_print_library_entry env sigma with_values ent = Some (str " >>>>>>> Section " ++ pr_name oname) | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) - | (_,Lib.CompilingLibrary (dir,_)) -> - Some (str " >>>>>>> Library " ++ DirPath.print dir) + | (_,Lib.CompilingLibrary { obj_dir; _ }) -> + Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> @@ -779,8 +788,8 @@ let read_sec_context r = with Not_found -> user_err ?loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function - | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> - if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest + | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> + if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | (_,Lib.ClosedSection _)::rest -> user_err Pp.(str "Cannot print the contents of a closed section.") (* LEM: Actually, we could if we wanted to. *) @@ -811,7 +820,7 @@ let print_any_name env sigma na udecl = | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp | Syntactic kn -> print_syntactic_def env kn - | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp + | Dir (DirModule { obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp | Other (obj, info) -> info.print obj @@ -903,18 +912,16 @@ let print_class i = let cl,_ = class_info_from_index i in pr_class cl -let print_path ((i,j),p) = - let sigma, env = Pfedit.get_current_context () in +let print_path env sigma ((i,j),p) = hov 2 ( str"[" ++ hov 0 (prlist_with_sep pr_semicolon (print_coercion_value env sigma) p) ++ str"] : ") ++ print_class i ++ str" >-> " ++ print_class j -(* XXX: This is suspicious!!! *) let _ = Classops.install_path_printer print_path -let print_graph () = - prlist_with_sep fnl print_path (inheritance_graph()) +let print_graph env sigma = + prlist_with_sep fnl (print_path env sigma) (inheritance_graph()) let print_classes () = pr_sequence pr_class (classes()) @@ -929,7 +936,7 @@ let index_of_class cl = user_err ~hdr:"index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") -let print_path_between cls clt = +let print_path_between env sigma cls clt = let i = index_of_class cls in let j = index_of_class clt in let p = @@ -940,7 +947,7 @@ let print_path_between cls clt = (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in - print_path ((i,j),p) + print_path env sigma ((i,j),p) let print_canonical_projections env sigma = prlist_with_sep fnl diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 8f3a6ddc4..fd7f1f92b 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -12,6 +12,7 @@ open Reductionops open Libnames open Globnames open Misctypes +open Evd (** A Pretty-Printer for the Calculus of Inductive Constructions. *) @@ -39,10 +40,10 @@ val print_about : env -> Evd.evar_map -> reference or_by_notation -> val print_impargs : reference or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) -val print_graph : unit -> Pp.t +val print_graph : env -> evar_map -> Pp.t val print_classes : unit -> Pp.t val print_coercions : env -> Evd.evar_map -> Pp.t -val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t +val print_path_between : env -> evar_map -> Classops.cl_typ -> Classops.cl_typ -> Pp.t val print_canonical_projections : env -> Evd.evar_map -> Pp.t (** Pretty-printing functions for type classes and instances *) diff --git a/printing/printer.ml b/printing/printer.ml index 6a0597860..d720bc2f8 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -263,10 +263,10 @@ let pr_universe_ctx_set sigma c = else mt() -let pr_universe_ctx sigma c = +let pr_universe_ctx sigma ?variance c = if !Detyping.print_universes && not (Univ.UContext.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_universe_context (Termops.pr_evd_level sigma) c)) c + (Univ.pr_universe_context (Termops.pr_evd_level sigma) ?variance c)) c else mt() @@ -905,7 +905,7 @@ end module ContextObjectSet = Set.Make (OrderedContextObject) module ContextObjectMap = Map.Make (OrderedContextObject) -let pr_assumptionset env s = +let pr_assumptionset env sigma s = if ContextObjectMap.is_empty s && engagement env = PredicativeSet then str "Closed under the global context" @@ -921,7 +921,6 @@ let pr_assumptionset env s = with e when CErrors.noncritical e -> mt () in let safe_pr_ltype_relctx (rctx, typ) = - let sigma, env = Pfedit.get_current_context () in let env = Environ.push_rel_context rctx env in try str " " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () diff --git a/printing/printer.mli b/printing/printer.mli index 9e8622c6e..a3427920a 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -120,7 +120,8 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t -val pr_universe_ctx : evar_map -> Univ.UContext.t -> Pp.t +val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> + Univ.UContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t val pr_constant_universes : evar_map -> Entries.constant_universes_entry -> Pp.t val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t @@ -186,8 +187,8 @@ val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t -val pr_open_subgoals : proof:Proof.proof -> Pp.t -val pr_nth_open_subgoal : proof:Proof.proof -> int -> Pp.t +val pr_open_subgoals : proof:Proof.t -> Pp.t +val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t @@ -217,10 +218,9 @@ module ContextObjectSet : Set.S with type elt = context_object module ContextObjectMap : CMap.ExtS with type key = context_object and module Set := ContextObjectSet -val pr_assumptionset : - env -> types ContextObjectMap.t -> Pp.t +val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t -val pr_goal_by_id : proof:Proof.proof -> Id.t -> Pp.t +val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t type printer_pr = { pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; diff --git a/printing/printmod.ml b/printing/printmod.ml index c34543bbd..2cdb9be3f 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -93,10 +93,11 @@ let print_one_inductive env sigma mib ((_,i) as ind) = else Univ.Instance.empty in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in + let nparamdecls = Context.Rel.length params in let args = Context.Rel.to_extended_list mkRel 0 params in - let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in + let arity = hnf_prod_applist_assum env nparamdecls (build_ind_type env ((mib,mip),u)) args in let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in - let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in + let cstrtypes = Array.map (fun c -> hnf_prod_applist_assum env nparamdecls c args) cstrtypes in let envpar = push_rel_context params env in let inst = if Declareops.inductive_is_polymorphic mib then @@ -113,19 +114,18 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let instantiate_cumulativity_info cumi = let open Univ in let univs = ACumulativityInfo.univ_context cumi in - let subtyp = ACumulativityInfo.subtyp_context cumi in let expose ctx = let inst = AUContext.instance ctx in let cst = AUContext.instantiate inst ctx in UContext.make (inst, cst) in - CumulativityInfo.make (expose univs, expose subtyp) + CumulativityInfo.make (expose univs, ACumulativityInfo.variance cumi) let print_mutual_inductive env mind mib udecl = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in let keyword = - let open Decl_kinds in + let open Declarations in match mib.mind_finite with | Finite -> "Inductive" | BiFinite -> "Variant" @@ -174,17 +174,18 @@ let print_record env mind mib udecl = in let mip = mib.mind_packets.(0) in let params = Inductive.inductive_paramdecls (mib,u) in + let nparamdecls = Context.Rel.length params in let args = Context.Rel.to_extended_list mkRel 0 params in - let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in + let arity = hnf_prod_applist_assum env nparamdecls (build_ind_type env ((mib,mip),u)) args in let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in - let cstrtype = hnf_prod_applist env cstrtypes.(0) args in + let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in let bl = Universes.universe_binders_with_opt_names (IndRef (mind,0)) (Array.to_list (Univ.Instance.to_array u)) udecl in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let keyword = - let open Decl_kinds in + let open Declarations in match mib.mind_finite with | BiFinite -> "Record" | Finite -> "Inductive" @@ -245,10 +246,10 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn -let nametab_register_dir mp = +let nametab_register_dir obj_mp = let id = mk_fake_top () in - let dir = DirPath.make [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,DirPath.empty))) + let obj_dir = DirPath.make [id] in + Nametab.push_dir (Nametab.Until 1) obj_dir (DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty }) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here @@ -346,7 +347,7 @@ let print_body is_impl env mp (l,body) = pr_mutual_inductive_body env (MutInd.make2 mp l) mib None with e when CErrors.noncritical e -> let keyword = - let open Decl_kinds in + let open Declarations in match mib.mind_finite with | Finite -> def "Inductive" | BiFinite -> def "Variant" diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 16798a1d5..9e06d913b 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -498,7 +498,7 @@ let clenv_unify_binding_type clenv c t u = 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.evd (clenv_get_type_of clenv c) 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 let c = EConstr.Unsafe.to_constr c in { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd } diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 9a2026dd3..c894b9dc9 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -41,10 +41,10 @@ val clenv_nf_meta : clausenv -> EConstr.constr -> EConstr.constr (** type of a meta in clenv context *) val clenv_meta_type : clausenv -> metavariable -> types -val mk_clenv_from : 'a Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_from : Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_n : - 'a Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv -val mk_clenv_type_of : 'a Proofview.Goal.t -> EConstr.constr -> clausenv + Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_type_of : Proofview.Goal.t -> EConstr.constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv (** Refresh the universes in a clenv *) @@ -66,7 +66,7 @@ val old_clenv_unique_resolver : ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv val clenv_unique_resolver : - ?flags:unify_flags -> clausenv -> 'a Proofview.Goal.t -> clausenv + ?flags:unify_flags -> clausenv -> Proofview.Goal.t -> clausenv val clenv_dependent : clausenv -> metavariable list diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 4a92c3856..373d60e69 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -54,9 +54,10 @@ let clenv_value_cast_meta clenv = let clenv_pose_dependent_evars with_evars clenv = let dep_mvs = clenv_dependent clenv in + let env, sigma = clenv.env, clenv.evd in if not (List.is_empty dep_mvs) && not with_evars then raise - (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs))); + (RefinerError (env, sigma, UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs))); clenv_pose_metas_as_evars clenv dep_mvs (** Use our own fast path, more informative than from Typeclasses *) @@ -140,7 +141,7 @@ let fail_quick_unif_flags = { let unify ?(flags=fail_quick_unif_flags) m = Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in - let n = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in + let n = Tacmach.New.pf_concl gl in let evd = clear_metas (Tacmach.New.project gl) in try let evd' = w_unify env evd CONV ~flags m n in diff --git a/proofs/goal.mli b/proofs/goal.mli index ad968cdfb..37dd9d3c0 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -58,7 +58,7 @@ module V82 : sig (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool - + (* Principal part of tclNOTSAMEGOAL *) val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool diff --git a/proofs/logic.ml b/proofs/logic.ml index a9ad606a0..5ff5fa38a 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -40,7 +40,7 @@ type refiner_error = | DoesNotOccurIn of constr * Id.t | NoSuchHyp of Id.t -exception RefinerError of refiner_error +exception RefinerError of Environ.env * Evd.evar_map * refiner_error open Pretype_errors @@ -69,7 +69,7 @@ let catchable_exception = function | PretypeError(_,_, e) -> is_unification_error e || is_typing_error e | _ -> false -let error_no_such_hypothesis id = raise (RefinerError (NoSuchHyp id)) +let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoSuchHyp id)) (* Tells if the refiner should check that the submitted rules do not produce invalid subgoals *) @@ -78,10 +78,10 @@ let with_check = Flags.with_option check (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and returns [tail::(f head (id,_,_) (rev tail))] *) -let apply_to_hyp check sign id f = +let apply_to_hyp env sigma check sign id f = try apply_to_hyp sign id f with Hyp_not_found -> - if check then error_no_such_hypothesis id + if check then error_no_such_hypothesis env sigma id else sign let check_typability env sigma c = @@ -147,7 +147,7 @@ let reorder_context env sigma sign ord = step ord' expected ctxt_head mh (d::ctxt_tail) | _ -> (match ctxt_head with - | [] -> error_no_such_hypothesis (List.hd ord) + | [] -> error_no_such_hypothesis env sigma (List.hd ord) | d :: ctxt -> let x = NamedDecl.get_id d in if Id.Set.mem x expected then @@ -190,9 +190,9 @@ let move_location_eq m1 m2 = match m1, m2 with | MoveFirst, MoveFirst -> true | _ -> false -let split_sign hfrom hto l = +let split_sign env sigma hfrom hto l = let rec splitrec left toleft = function - | [] -> error_no_such_hypothesis hfrom + | [] -> error_no_such_hypothesis env sigma hfrom | d :: right -> let hyp = NamedDecl.get_id d in if Id.equal hyp hfrom then @@ -222,7 +222,7 @@ let move_hyp sigma toleft (left,declfrom,right) hto = let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then - error_no_such_hypothesis (hyp_of_move_location hto); + error_no_such_hypothesis env sigma (hyp_of_move_location hto); List.rev first @ List.rev middle | d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) -> List.rev first @ List.rev middle @ right @@ -258,10 +258,10 @@ let move_hyp sigma toleft (left,declfrom,right) hto = List.fold_left (fun sign d -> push_named_context_val d sign) right left -let move_hyp_in_named_context sigma hfrom hto sign = +let move_hyp_in_named_context env sigma hfrom hto sign = let open EConstr in let (left,right,declfrom,toleft) = - split_sign hfrom hto (named_context_of_val sign) in + split_sign env sigma hfrom hto (named_context_of_val sign) in move_hyp sigma toleft (left,declfrom,right) hto let insert_decl_in_named_context sigma decl hto sign = @@ -293,15 +293,15 @@ let collect_meta_variables c = in List.rev (collrec false [] c) -let check_meta_variables c = +let check_meta_variables env sigma c = if not (List.distinct_f Int.compare (collect_meta_variables c)) then - raise (RefinerError (NonLinearProof c)) + raise (RefinerError (env, sigma, NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = if !check then let evm, b = Reductionops.infer_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr conclty) in if b then evm - else raise (RefinerError (BadType (arg,ty,conclty))) + else raise (RefinerError (env, sigma, BadType (arg,ty,conclty))) else sigma exception Stop of EConstr.t list @@ -334,9 +334,9 @@ let rec mk_refgoals sigma goal goalacc conclty trm = else match kind trm with | Meta _ -> - let conclty = nf_betaiota sigma (EConstr.of_constr conclty) in + let conclty = nf_betaiota env sigma (EConstr.of_constr conclty) in if !check && occur_meta sigma conclty then - raise (RefinerError (MetaInType conclty)); + raise (RefinerError (env, sigma, MetaInType conclty)); let (gl,ev,sigma) = mk_goal hyps conclty in let ev = EConstr.Unsafe.to_constr ev in let conclty = EConstr.Unsafe.to_constr conclty in @@ -416,7 +416,7 @@ and mk_hdgoals sigma goal goalacc trm = match kind trm with | Cast (c,_, ty) when isMeta c -> check_typability env sigma ty; - let (gl,ev,sigma) = mk_goal hyps (nf_betaiota sigma (EConstr.of_constr ty)) in + let (gl,ev,sigma) = mk_goal hyps (nf_betaiota env sigma (EConstr.of_constr ty)) in let ev = EConstr.Unsafe.to_constr ev in gl::goalacc,ty,sigma,ev @@ -477,7 +477,9 @@ and mk_arggoals sigma goal goalacc funty allargs = | Prod (_, c1, b) -> let (acc, hargty, sigma, arg) = mk_refgoals sigma goal goalacc c1 harg in (acc, subst1 harg b, sigma), arg - | _ -> raise (RefinerError (CannotApply (t, harg))) + | _ -> + let env = Goal.V82.env sigma goal in + raise (RefinerError (env,sigma,CannotApply (t, harg))) in Array.smartfoldmap foldmap (goalacc, funty, sigma) allargs @@ -497,10 +499,10 @@ and mk_casegoals sigma goal goalacc p c = let convert_hyp check sign sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in - let env = Global.env() in + let env = Global.env () in let reorder = ref [] in let sign' = - apply_to_hyp check sign id + apply_to_hyp env sigma check sign id (fun _ d' _ -> let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in let env = Global.env_of_context sign in @@ -514,19 +516,18 @@ let convert_hyp check sign sigma d = map_named_decl EConstr.Unsafe.to_constr d) in reorder_val_context env sigma sign' !reorder - - (************************************************************************) (************************************************************************) (* Primitive tactics are handled here *) let prim_refiner r sigma goal = + let env = Goal.V82.env sigma goal in let cl = Goal.V82.concl sigma goal in match r with (* Logical rules *) | Refine c -> let cl = EConstr.Unsafe.to_constr cl in - check_meta_variables c; + check_meta_variables env sigma c; let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in let sgl = List.rev sgl in let sigma = Goal.V82.partial_solution sigma goal (EConstr.of_constr oterm) in diff --git a/proofs/logic.mli b/proofs/logic.mli index 7df7fd66b..afd1ecf70 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -50,16 +50,16 @@ type refiner_error = | DoesNotOccurIn of constr * Id.t | NoSuchHyp of Id.t -exception RefinerError of refiner_error +exception RefinerError of Environ.env * evar_map * refiner_error -val error_no_such_hypothesis : Id.t -> 'a +val error_no_such_hypothesis : Environ.env -> evar_map -> Id.t -> 'a val catchable_exception : exn -> bool val convert_hyp : bool -> Environ.named_context_val -> evar_map -> EConstr.named_declaration -> Environ.named_context_val -val move_hyp_in_named_context : Evd.evar_map -> Id.t -> Id.t Misctypes.move_location -> +val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t Misctypes.move_location -> Environ.named_context_val -> Environ.named_context_val val insert_decl_in_named_context : Evd.evar_map -> diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index c526ae000..6b503a011 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -140,7 +140,8 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in Proof_global.discard_current (); - const, status, fst univs + let univs = UState.demote_seff_univs const univs in + const, status, univs with reraise -> let reraise = CErrors.push reraise in Proof_global.discard_current (); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index d676a0874..5a317a956 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -35,11 +35,11 @@ val start_proof : val cook_this_proof : Proof_global.proof_object -> (Id.t * - (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) val cook_proof : unit -> (Id.t * - (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) (** {6 ... } *) (** [get_goal_context n] returns the context of the [n]th subgoal of @@ -74,7 +74,7 @@ val current_proof_statement : val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof*bool + Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof or raises a UserError if there is no focused proof or diff --git a/proofs/proof.ml b/proofs/proof.ml index 413b5fdd7..04e707cd6 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -98,7 +98,7 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k) (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) -type proof = { +type t = { (* Current focused proofview *) proofview: Proofview.proofview; (* Entry for the proofview *) @@ -115,6 +115,8 @@ type proof = { initial_euctx : UState.t } +type proof = t + (*** General proof functions ***) let proof p = diff --git a/proofs/proof.mli b/proofs/proof.mli index 83777fc96..0b5e771ef 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -30,7 +30,9 @@ *) (* Type of a proof. *) -type proof +type t +type proof = t +[@@ocaml.deprecated "please use [Proof.t]"] (* Returns a stylised view of a proof for use by, for instance, ide-s. *) @@ -42,7 +44,7 @@ type proof shelf (the list of goals on the shelf), a representation of the given up goals (the list of the given up goals) and the underlying evar_map *) -val proof : proof -> +val proof : t -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Goal.goal list @@ -61,26 +63,26 @@ type 'a pre_goals = { (** List of the goals that have been given up *) } -val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) +val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> proof -val dependent_start : Proofview.telescope -> proof -val initial_goals : proof -> (EConstr.constr * EConstr.types) list -val initial_euctx : proof -> UState.t +val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t +val dependent_start : Proofview.telescope -> t +val initial_goals : t -> (EConstr.constr * EConstr.types) list +val initial_euctx : t -> UState.t (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) -val is_done : proof -> bool +val is_done : t -> bool (* Like is_done, but this time it really means done (i.e. nothing left to do) *) -val is_complete : proof -> bool +val is_complete : t -> bool (* Returns the list of partial proofs to initial goals. *) -val partial_proof : proof -> EConstr.constr list +val partial_proof : t -> EConstr.constr list -val compact : proof -> proof +val compact : t -> t (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. @@ -91,7 +93,7 @@ exception UnfinishedProof exception HasShelvedGoals exception HasGivenUpGoals exception HasUnresolvedEvar -val return : proof -> Evd.evar_map +val return : t -> Evd.evar_map (*** Focusing actions ***) @@ -131,7 +133,7 @@ val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* focus command (focuses on the [i]th subgoal) *) (* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) -val focus : 'a focus_condition -> 'a -> int -> proof -> proof +val focus : 'a focus_condition -> 'a -> int -> t -> t exception FullyUnfocused exception CannotUnfocusThisWay @@ -147,59 +149,59 @@ exception NoSuchGoals of int * int Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition is not met. *) -val unfocus : 'a focus_kind -> proof -> unit -> proof +val unfocus : 'a focus_kind -> t -> unit -> t (* [unfocused p] returns [true] when [p] is fully unfocused. *) -val unfocused : proof -> bool +val unfocused : t -> bool (* [get_at_focus k] gets the information stored at the closest focus point of kind [k]. Raises [NoSuchFocus] if there is no focus point of kind [k]. *) exception NoSuchFocus -val get_at_focus : 'a focus_kind -> proof -> 'a +val get_at_focus : 'a focus_kind -> t -> 'a (* [is_last_focus k] check if the most recent focus is of kind [k] *) -val is_last_focus : 'a focus_kind -> proof -> bool +val is_last_focus : 'a focus_kind -> t -> bool (* returns [true] if there is no goal under focus. *) -val no_focused_goal : proof -> bool +val no_focused_goal : t -> bool (*** Tactics ***) (* the returned boolean signal whether an unsafe tactic has been used. In which case it is [false]. *) val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof*(bool*Proofview_monad.Info.tree) + unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) -val maximal_unfocus : 'a focus_kind -> proof -> proof +val maximal_unfocus : 'a focus_kind -> t -> t (*** Commands ***) -val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a +val in_proof : t -> (Evd.evar_map -> 'a) -> 'a (* Remove all the goals from the shelf and adds them at the end of the focused goals. *) -val unshelve : proof -> proof +val unshelve : t -> t -val pr_proof : proof -> Pp.t +val pr_proof : t -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig - val subgoals : proof -> Goal.goal list Evd.sigma + val subgoals : t -> Goal.goal list Evd.sigma [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] (* All the subgoals of the proof, including those which are not focused. *) - val background_subgoals : proof -> Goal.goal list Evd.sigma + val background_subgoals : t -> Goal.goal list Evd.sigma - val top_goal : proof -> Goal.goal Evd.sigma + val top_goal : t -> Goal.goal Evd.sigma (* returns the existential variable used to start the proof *) - val top_evars : proof -> Evar.t list + val top_evars : t -> Evar.t list (* Turns the unresolved evars into goals. Raises [UnfinishedProof] if there are still unsolved goals. *) - val grab_evars : proof -> proof + val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proof -> proof + val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t end diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 4f575ab4b..214916331 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -25,8 +25,8 @@ let pr_bullet b = type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } let behaviors = Hashtbl.create 4 @@ -110,7 +110,7 @@ module Strict = struct let push (b:t) pr = focus bullet_cond (b::get_bullets pr) 1 pr - let suggest_bullet (prf : proof): suggestion = + let suggest_bullet (prf : Proof.t): suggestion = if is_done prf then ProofFinished else if not (no_focused_goal prf) then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *) @@ -137,7 +137,7 @@ module Strict = struct in loop prf - let rec pop_until (prf : proof) bul : proof = + let rec pop_until (prf : Proof.t) bul : Proof.t = let prf', b = pop prf in if bullet_eq bul b then prf' else pop_until prf' bul diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 9e924fec9..09fcabf50 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -12,8 +12,6 @@ (* *) (**********************************************************) -open Proof - type t = Vernacexpr.bullet (** A [behavior] is the data of a put function which @@ -22,8 +20,8 @@ type t = Vernacexpr.bullet with a name to identify the behavior. *) type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } (** A registered behavior can then be accessed in Coq @@ -39,8 +37,8 @@ val register_behavior : behavior -> unit (** Handles focusing/defocusing with bullets: *) -val put : proof -> t -> proof -val suggest : proof -> Pp.t +val put : Proof.t -> t -> Proof.t +val suggest : Proof.t -> Pp.t (**********************************************************) (* *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index aa5621770..833e34c33 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -68,17 +68,16 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list -type proof_universes = UState.t * Universes.universe_binders option type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; - universes: proof_universes; + universes: UState.t; } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object @@ -90,12 +89,15 @@ type pstate = { terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Context.Named.t option; - proof : Proof.proof; + proof : Proof.t; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; universe_decl: Univdecls.universe_decl; } +type t = pstate list +type state = t + let make_terminator f = f let apply_terminator f = f @@ -144,6 +146,7 @@ let cur_pstate () = | [] -> raise NoCurrentProof let give_me_the_proof () = (cur_pstate ()).proof +let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None let get_current_proof_name () = (cur_pstate ()).pid let with_current_proof f = @@ -330,7 +333,6 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now in let fpl, univs = Future.split2 fpl in let universes = if poly || now then Future.force univs else initial_euctx in - let binders = if poly then Some (UState.universe_binders universes) else None in (* Because of dependent subgoals at the beginning of proofs, we could have existential variables in the initial types of goals, we need to normalise them for the kernel. *) @@ -342,26 +344,21 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now if poly || now then let make_body t (c, eff) = let body = c in - let typ = - if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then - nf t - else t - in - let used_univs_body = Univops.universes_of_constr body in - let used_univs_typ = Univops.universes_of_constr typ in - (* Universes for private constants are relevant to the body *) - let used_univs_body = - List.fold_left (fun acc (us,_) -> Univ.LSet.union acc us) - used_univs_body (Safe_typing.universes_of_private eff) + let allow_deferred = + not poly && (keep_body_ucst_separate || + not (Safe_typing.empty_private_constants = eff)) in - if keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff) then + let typ = if allow_deferred then t else nf t in + let env = Global.env () in + let used_univs_body = Univops.universes_of_constr env body in + let used_univs_typ = Univops.universes_of_constr env typ in + if allow_deferred then let initunivs = UState.const_univ_entry ~poly initial_euctx in let ctx = constrain_variables universes in (* For vi2vo compilation proofs are computed now but we need to complement the univ constraints of the typ with the ones of the body. So we keep the two sets distinct. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in let ctx_body = UState.restrict ctx used_univs in let univs = UState.check_mono_univ_decl ctx_body universe_decl in (initunivs, typ), ((body, univs), eff) @@ -406,7 +403,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now in let entries = Future.map2 entry_fn fpl initial_goals in { id = pid; entries = entries; persistence = strength; - universes = (universes, binders) }, + universes }, fun pr_ending -> CEphemeron.get terminator pr_ending let return_proof ?(allow_partial=false) () = @@ -467,8 +464,6 @@ module V82 = struct pid, (goals, strength) end -type state = pstate list - let freeze ~marshallable = match marshallable with | `Yes -> @@ -491,7 +486,10 @@ let update_global_env () = (* XXX: Bullet hook, should be really moved elsewhere *) let _ = let hook n = - let prf = give_me_the_proof () in - (Proof_bullet.suggest prf) in + try + let prf = give_me_the_proof () in + (Proof_bullet.suggest prf) + with NoCurrentProof -> mt () + in Proofview.set_nosuchgoals_hook hook diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index eed62f912..29445a746 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -10,6 +10,10 @@ toplevel. In particular it defines the global proof environment. *) +type t +type state = t +[@@ocaml.deprecated "please use [Proof_global.t]"] + val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -20,8 +24,9 @@ val discard : Names.Id.t Loc.located -> unit val discard_current : unit -> unit val discard_all : unit -> unit +val give_me_the_proof_opt : unit -> Proof.t option exception NoCurrentProof -val give_me_the_proof : unit -> Proof.proof +val give_me_the_proof : unit -> Proof.t (** @raise NoCurrentProof when outside proof mode. *) val compact_the_proof : unit -> unit @@ -33,18 +38,17 @@ val compact_the_proof : unit -> unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = UState.t * Universes.universe_binders option type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; - universes: proof_universes; + universes: UState.t; } type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - proof_universes + UState.t | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object @@ -107,9 +111,9 @@ val get_open_goals : unit -> int no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof*'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> unit @@ -129,11 +133,10 @@ module V82 : sig Decl_kinds.goal_kind) end -type state -val freeze : marshallable:[`Yes | `No | `Shallow] -> state -val unfreeze : state -> unit -val proof_of_state : state -> Proof.proof -val copy_terminators : src:state -> tgt:state -> state +val freeze : marshallable:[`Yes | `No | `Shallow] -> t +val unfreeze : t -> unit +val proof_of_state : t -> Proof.t +val copy_terminators : src:t -> tgt:t -> t (**********************************************************) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 6052ba367..9a5d4e154 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -25,8 +25,11 @@ open Misctypes (* call by value normalisation function using the virtual machine *) let cbv_vm env sigma c = - let ctyp = Retyping.get_type_of env sigma c in - Vnorm.cbv_vm env sigma c ctyp + if Coq_config.bytecode_compiler then + let ctyp = Retyping.get_type_of env sigma c in + Vnorm.cbv_vm env sigma c ctyp + else + compute env sigma c let warn_native_compute_disabled = CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler" @@ -34,12 +37,12 @@ let warn_native_compute_disabled = strbrk "native_compute disabled at configure time; falling back to vm_compute.") let cbv_native env sigma c = - if Coq_config.no_native_compiler then - (warn_native_compute_disabled (); - cbv_vm env sigma c) - else + if Coq_config.native_compiler then let ctyp = Retyping.get_type_of env sigma c in Nativenorm.native_norm env sigma c ctyp + else + (warn_native_compute_disabled (); + cbv_vm env sigma c) let whd_cbn flags env sigma t = let (state,_) = diff --git a/proofs/refine.ml b/proofs/refine.ml index e3f650848..90276951b 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -70,7 +70,6 @@ let add_side_effects env effects = List.fold_left (fun env eff -> add_side_effect env eff) env effects let generic_refine ~typecheck f gl = - let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in @@ -159,7 +158,6 @@ let with_type env evd c t = evd , j'.Environ.uj_val let refine_casted ~typecheck f = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let f h = diff --git a/proofs/refine.mli b/proofs/refine.mli index cfdcde36e..1932a306c 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -33,7 +33,7 @@ val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr (** A variant of [refine] which assumes exactly one goal under focus *) val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> - [ `NF ] Proofview.Goal.t -> 'a tactic + Proofview.Goal.t -> 'a tactic (** The general version of refine. *) (** {7 Helper functions} *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 3e3313eb5..cd2b10906 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -30,8 +30,8 @@ let refiner pr goal_sigma = (* Profiling refiner *) let refiner = if Flags.profile then - let refiner_key = Profile.declare_profile "refiner" in - Profile.profile2 refiner_key refiner + let refiner_key = CProfile.declare_profile "refiner" in + CProfile.profile2 refiner_key refiner else refiner (*********************) diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 34e517aed..52dc8bfd8 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -40,7 +40,7 @@ val tclEVARUNIVCONTEXT : UState.t -> tactic val tclPUSHCONTEXT : Evd.rigid -> Univ.ContextSet.t -> tactic -> tactic val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic -val tclPUSHCONSTRAINTS : Univ.constraints -> tactic +val tclPUSHCONSTRAINTS : Univ.Constraint.t -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a8ec4d8ca..d3405b892 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -55,10 +55,11 @@ let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> NamedDecl.get_id let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = + let env, sigma = pf_env gls, project gls in try Context.Named.lookup id (pf_hyps gls) with Not_found -> - raise (RefinerError (NoSuchHyp id)) + raise (RefinerError (env, sigma, NoSuchHyp id)) let pf_get_hyp_typ gls id = id |> pf_get_hyp gls |> NamedDecl.get_type @@ -86,7 +87,7 @@ let pf_e_reduce = pf_apply let pf_whd_all = pf_reduce whd_all let pf_hnf_constr = pf_reduce hnf_constr let pf_nf = pf_reduce simpl -let pf_nf_betaiota = pf_reduce (fun _ -> nf_betaiota) +let pf_nf_betaiota = pf_reduce nf_betaiota let pf_compute = pf_reduce compute let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds) let pf_unsafe_type_of = pf_reduce unsafe_type_of @@ -102,9 +103,6 @@ let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls -let pf_is_matching gl p c = pf_apply Constr_matching.is_matching_conv gl p c -let pf_matches gl p c = pf_apply Constr_matching.matches_conv gl p c - (********************************************) (* Definition of the most primitive tactics *) (********************************************) @@ -152,7 +150,6 @@ module New = struct let pf_global id gl = (** We only check for the existence of an [id] in [hyps] *) - let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in Constrintern.construct_reference hyps id @@ -169,13 +166,11 @@ module New = struct let pf_ids_of_hyps gl = (** We only get the identifiers in [hyps] *) - let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in ids_of_named_context hyps let pf_ids_set_of_hyps gl = (** We only get the identifiers in [hyps] *) - let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in Environ.ids_of_named_context_val (Environ.named_context_val env) @@ -185,9 +180,10 @@ module New = struct let pf_get_hyp id gl = let hyps = Proofview.Goal.env gl in + let sigma = project gl in let sign = try EConstr.lookup_named id hyps - with Not_found -> raise (RefinerError (NoSuchHyp id)) + with Not_found -> raise (RefinerError (hyps, sigma, NoSuchHyp id)) in sign @@ -205,9 +201,8 @@ module New = struct let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) = + let pf_nf_concl (gl : Proofview.Goal.t) = (** We normalize the conclusion just after *) - let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = project gl in nf_evar sigma concl @@ -223,8 +218,6 @@ module New = struct let pf_hnf_type_of gl t = pf_whd_all gl (pf_get_type_of gl t) - let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t - let pf_whd_all gl t = pf_apply whd_all gl t let pf_compute gl t = pf_apply compute gl t diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index d9496d2b4..8f69358d4 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -12,9 +12,7 @@ open Environ open EConstr open Proof_type open Redexpr -open Pattern open Locus -open Ltac_pretype (** Operations for handling terms under a local typing context. *) @@ -79,10 +77,6 @@ val pf_const_value : goal sigma -> pconstant -> constr val pf_conv_x : goal sigma -> constr -> constr -> bool val pf_conv_x_leq : goal sigma -> constr -> constr -> bool -val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map -val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool - - (** {6 The most primitive tactics. } *) val refiner : rule -> tactic @@ -98,48 +92,46 @@ val pr_glls : goal list sigma -> Pp.t (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig - val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val pf_global : Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference + val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a + val pf_global : Id.t -> Proofview.Goal.t -> Globnames.global_reference (** FIXME: encapsulate the level in an existential type. *) - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a + val of_old : (Proof_type.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a - val project : 'a Proofview.Goal.t -> Evd.evar_map - val pf_env : 'a Proofview.Goal.t -> Environ.env - val pf_concl : 'a Proofview.Goal.t -> types + val project : Proofview.Goal.t -> Evd.evar_map + val pf_env : Proofview.Goal.t -> Environ.env + val pf_concl : Proofview.Goal.t -> types (** WRONG: To be avoided at all costs, it typechecks the term entirely but forgets the universe constraints necessary to retypecheck it *) - val pf_unsafe_type_of : 'a Proofview.Goal.t -> constr -> types + val pf_unsafe_type_of : Proofview.Goal.t -> constr -> types (** This function does no type inference and expects an already well-typed term. It recomputes its type in the fastest way possible (no conversion is ever involved) *) - val pf_get_type_of : 'a Proofview.Goal.t -> constr -> types + val pf_get_type_of : Proofview.Goal.t -> constr -> types (** This function entirely type-checks the term and computes its type and the implied universe constraints. *) - val pf_type_of : 'a Proofview.Goal.t -> constr -> evar_map * types - val pf_conv_x : 'a Proofview.Goal.t -> t -> t -> bool - - val pf_get_new_id : Id.t -> 'a Proofview.Goal.t -> Id.t - val pf_ids_of_hyps : 'a Proofview.Goal.t -> Id.t list - val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Id.Set.t - val pf_hyps_types : 'a Proofview.Goal.t -> (Id.t * types) list + val pf_type_of : Proofview.Goal.t -> constr -> evar_map * types + val pf_conv_x : Proofview.Goal.t -> t -> t -> bool - val pf_get_hyp : Id.t -> 'a Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : Id.t -> 'a Proofview.Goal.t -> types - val pf_last_hyp : 'a Proofview.Goal.t -> named_declaration + val pf_get_new_id : Id.t -> Proofview.Goal.t -> Id.t + val pf_ids_of_hyps : Proofview.Goal.t -> Id.t list + val pf_ids_set_of_hyps : Proofview.Goal.t -> Id.Set.t + val pf_hyps_types : Proofview.Goal.t -> (Id.t * types) list - val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> (inductive * EInstance.t) * types + val pf_get_hyp : Id.t -> Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : Id.t -> Proofview.Goal.t -> types + val pf_last_hyp : Proofview.Goal.t -> named_declaration - val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types - val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types + val pf_nf_concl : Proofview.Goal.t -> types + val pf_reduce_to_quantified_ind : Proofview.Goal.t -> types -> (inductive * EInstance.t) * types - val pf_whd_all : 'a Proofview.Goal.t -> constr -> constr - val pf_compute : 'a Proofview.Goal.t -> constr -> constr + val pf_hnf_constr : Proofview.Goal.t -> constr -> types + val pf_hnf_type_of : Proofview.Goal.t -> constr -> types - val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map + val pf_whd_all : Proofview.Goal.t -> constr -> constr + val pf_compute : Proofview.Goal.t -> constr -> constr - val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr + val pf_nf_evar : Proofview.Goal.t -> constr -> constr end diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 4662c5543..26aef5355 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -10,11 +10,11 @@ open CErrors open Pp open Util -let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp - +let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.pp_with pp let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () type cancel_switch = bool ref +let async_proofs_flags_for_workers = ref [] module type Task = sig @@ -58,7 +58,7 @@ module Make(T : Task) () = struct type request = Request of T.request type more_data = - | MoreDataUnivLevel of Univ.Level.t list + | MoreDataUnivLevel of Universes.universe_id list let slave_respond (Request r) = let res = T.perform r in @@ -117,12 +117,12 @@ module Make(T : Task) () = struct let name = Printf.sprintf "%s:%d" !T.name id in let proc, ic, oc = let rec set_slave_opt = function - | [] -> !Flags.async_proofs_flags_for_workers @ + | [] -> !async_proofs_flags_for_workers @ ["-toploop"; !T.name^"top"; "-worker-id"; name; "-async-proofs-worker-priority"; - Flags.string_of_priority !Flags.async_proofs_worker_priority] - | ("-ideslave"|"-emacs"|"-batch")::tl -> set_slave_opt tl + CoqworkmgrApi.(string_of_priority !WorkerLoop.async_proofs_worker_priority)] + | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl | ("-async-proofs" |"-toploop" |"-vio2vo" |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" |"-compile" |"-compile-verbose" @@ -169,8 +169,7 @@ module Make(T : Task) () = struct | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in let more_univs n = - CList.init n (fun _ -> - Universes.new_univ_level (Global.current_dirpath ())) in + CList.init n (fun _ -> Universes.new_univ_id ()) in let rec kill_if () = if not (Worker.is_alive proc) then () @@ -296,7 +295,7 @@ module Make(T : Task) () = struct let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) - let pp_pid pp = Pp.(str (System.process_id () ^ " ") ++ pp) + let pp_pid pp = Pp.(str (Spawned.process_id () ^ " ") ++ pp) let debug_with_pid = Feedback.(function | { contents = Message(Debug, loc, pp) } as fb -> @@ -309,7 +308,7 @@ module Make(T : Task) () = struct Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); (* We ask master to allocate universe identifiers *) - Universes.set_remote_new_univ_level (bufferize (fun () -> + Universes.set_remote_new_univ_id (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with | MoreDataUnivLevel l -> l)); diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index ccd643deb..706d36e1d 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* Default flags for workers *) +val async_proofs_flags_for_workers : string list ref + (** This file provides an API for defining and managing a queue of tasks to be done by external workers. @@ -68,7 +71,7 @@ module type Task = sig (** Extra arguments of the task kind, for -toploop *) val extra_env : unit -> string array - (** {5} Master API, it is run by the master, on a thread *) + (** {5 Master API, it is run by the master, on a thread} *) (** [request_of_task status t] takes the [status] of the worker and a task [t] and creates the corresponding [Some request] to be @@ -113,8 +116,8 @@ module type Task = sig (** [forward_feedback fb] sends fb to all the workers. *) val forward_feedback : Feedback.feedback -> unit - (** {5} Worker API, it is run by worker, on a different fresh - process *) + (** {5 Worker API, it is run by worker, on a different fresh + process} *) (** [perform in] synchronously processes a request [in] *) val perform : request -> response diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml index 6d6a198c5..14fd97a6d 100644 --- a/stm/coqworkmgrApi.ml +++ b/stm/coqworkmgrApi.ml @@ -8,8 +8,15 @@ let debug = false +type priority = Low | High +let string_of_priority = function Low -> "low" | High -> "high" +let priority_of_string = function + | "low" -> Low + | "high" -> High + | _ -> raise (Invalid_argument "priority_of_string") + type request = - | Hello of Flags.priority + | Hello of priority | Get of int | TryGet of int | GiveBack of int @@ -36,8 +43,8 @@ let positive_int_of_string n = let parse_request s = if debug then Printf.eprintf "parsing '%s'\n" s; match Str.split (Str.regexp " ") (strip_r s) with - | [ "HELLO"; "LOW" ] -> Hello Flags.Low - | [ "HELLO"; "HIGH" ] -> Hello Flags.High + | [ "HELLO"; "LOW" ] -> Hello Low + | [ "HELLO"; "HIGH" ] -> Hello High | [ "GET"; n ] -> Get (positive_int_of_string n) | [ "TRYGET"; n ] -> TryGet (positive_int_of_string n) | [ "GIVEBACK"; n ] -> GiveBack (positive_int_of_string n) @@ -57,8 +64,8 @@ let parse_response s = | _ -> raise ParseError let print_request = function - | Hello Flags.Low -> "HELLO LOW\n" - | Hello Flags.High -> "HELLO HIGH\n" + | Hello Low -> "HELLO LOW\n" + | Hello High -> "HELLO HIGH\n" | Get n -> Printf.sprintf "GET %d\n" n | TryGet n -> Printf.sprintf "TRYGET %d\n" n | GiveBack n -> Printf.sprintf "GIVEBACK %d\n" n @@ -106,8 +113,7 @@ let with_manager f g = let get n = with_manager - (fun () -> - min n (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers)) + (fun () -> n) (fun cin cout -> output_string cout (print_request (Get n)); flush cout; @@ -118,10 +124,7 @@ let get n = let tryget n = with_manager - (fun () -> - Some - (min n - (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers))) + (fun () -> Some n) (fun cin cout -> output_string cout (print_request (TryGet n)); flush cout; diff --git a/stm/coqworkmgrApi.mli b/stm/coqworkmgrApi.mli index 70d4173ae..953903810 100644 --- a/stm/coqworkmgrApi.mli +++ b/stm/coqworkmgrApi.mli @@ -8,9 +8,13 @@ (* High level api for clients of the service (like coqtop) *) +type priority = Low | High +val string_of_priority : priority -> string +val priority_of_string : string -> priority + (* Connects to a work manager if any. If no worker manager, then -async-proofs-j and -async-proofs-tac-j are used *) -val init : Flags.priority -> unit +val init : priority -> unit (* blocking *) val get : int -> int @@ -21,7 +25,7 @@ val giveback : int -> unit (* Low level *) type request = - | Hello of Flags.priority + | Hello of priority | Get of int | TryGet of int | GiveBack of int diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 77642946c..bebc4d5d5 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -23,8 +23,8 @@ val crawl : val unit_val : Stm.DynBlockData.t val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet -val of_vernac_expr_val : Vernacexpr.vernac_expr -> Stm.DynBlockData.t -val to_vernac_expr_val : Stm.DynBlockData.t -> Vernacexpr.vernac_expr +val of_vernac_control_val : Vernacexpr.vernac_control -> Stm.DynBlockData.t +val to_vernac_control_val : Stm.DynBlockData.t -> Vernacexpr.vernac_control end = struct @@ -32,7 +32,7 @@ let unit_tag = DynBlockData.create "unit" let unit_val = DynBlockData.Easy.inj () unit_tag let of_bullet_val, to_bullet_val = DynBlockData.Easy.make_dyn "bullet" -let of_vernac_expr_val, to_vernac_expr_val = DynBlockData.Easy.make_dyn "vernac_expr" +let of_vernac_control_val, to_vernac_control_val = DynBlockData.Easy.make_dyn "vernac_control" let simple_goal sigma g gs = let open Evar in @@ -74,14 +74,16 @@ include Util (* ****************** - foo - bar - baz *********************************** *) let static_bullet ({ entry_point; prev_node } as view) = - match entry_point.ast with + assert (not (Vernacprop.has_Fail entry_point.ast)); + match Vernacprop.under_control entry_point.ast with | Vernacexpr.VernacBullet b -> let base = entry_point.indentation in let last_tac = prev_node entry_point in crawl view ~init:last_tac (fun prev node -> if node.indentation < base then `Stop else if node.indentation > base then `Cont node else - match node.ast with + if Vernacprop.has_Fail node.ast then `Stop + else match Vernacprop.under_control node.ast with | Vernacexpr.VernacBullet b' when b = b' -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = of_bullet_val b } @@ -94,7 +96,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacBullet (to_bullet_val b)) + recovery_command = Some (Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) } | `Not -> `Leaks @@ -104,9 +106,10 @@ let () = register_proof_block_delimiter (* ******************** { block } ***************************************** *) let static_curly_brace ({ entry_point; prev_node } as view) = - assert(entry_point.ast = Vernacexpr.VernacEndSubproof); + assert(Vernacprop.under_control entry_point.ast = Vernacexpr.VernacEndSubproof); crawl view (fun (nesting,prev) node -> - match node.ast with + if Vernacprop.has_Fail node.ast then `Cont (nesting,node) + else match Vernacprop.under_control node.ast with | Vernacexpr.VernacSubproof _ when nesting = 0 -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = unit_val } @@ -122,7 +125,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some Vernacexpr.VernacEndSubproof + recovery_command = Some (Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) } | `Not -> `Leaks @@ -164,7 +167,7 @@ let static_indent ({ entry_point; prev_node } as view) = else `Found { block_stop = entry_point.id; block_start = node.id; dynamic_switch = node.id; - carry_on_data = of_vernac_expr_val entry_point.ast } + carry_on_data = of_vernac_control_val entry_point.ast } ) last_tac let dynamic_indent doc { dynamic_switch = id; carry_on_data = e } = @@ -176,7 +179,7 @@ let dynamic_indent doc { dynamic_switch = id; carry_on_data = e } = `ValidBlock { base_state = id; goals_to_admit = but_last; - recovery_command = Some (to_vernac_expr_val e); + recovery_command = Some (to_vernac_control_val e); } | `Not -> `Leaks diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 10b42f7e9..81637f143 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) +let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index a1fe50c63..7862f2f44 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) +let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) diff --git a/stm/spawned.ml b/stm/spawned.ml index 6ab096abf..fb5708f3a 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -73,3 +73,9 @@ let get_channels () = Printf.eprintf "Fatal error: ideslave communication channels not set.\n"; exit 1 | Some(ic, oc) -> ic, oc + +let process_id () = + Printf.sprintf "%d:%s:%d" (Unix.getpid ()) + (if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id + else "master") + (Thread.id (Thread.self ())) diff --git a/stm/spawned.mli b/stm/spawned.mli index c3cf4d67b..7f463c6a6 100644 --- a/stm/spawned.mli +++ b/stm/spawned.mli @@ -20,3 +20,5 @@ val init_channels : unit -> unit (* Once initialized, these are the channels to talk with our master *) val get_channels : unit -> CThread.thread_ic * out_channel +(** {6 Name of current process.} *) +val process_id : unit -> string diff --git a/stm/stm.ml b/stm/stm.ml index ab44cc98b..92587b8ea 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -8,21 +8,70 @@ (* enable in case of stm problems *) (* let stm_debug () = !Flags.debug *) -let stm_debug () = !Flags.stm_debug +let stm_debug = ref false -let stm_pr_err s = Format.eprintf "%s] %s\n%!" (System.process_id ()) s -let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp +let stm_pr_err s = Format.eprintf "%s] %s\n%!" (Spawned.process_id ()) s +let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.pp_with pp -let stm_prerr_endline s = if stm_debug () then begin stm_pr_err (s ()) end else () -let stm_pperr_endline s = if stm_debug () then begin stm_pp_err (s ()) end else () +let stm_prerr_endline s = if !stm_debug then begin stm_pr_err (s ()) end else () +let stm_pperr_endline s = if !stm_debug then begin stm_pp_err (s ()) end else () let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () open Pp open CErrors +open Names open Feedback open Vernacexpr +module AsyncOpts = struct + + type cache = Force + type async_proofs = APoff | APonLazy | APon + type tac_error_filter = [ `None | `Only of string list | `All ] + + type stm_opt = { + async_proofs_n_workers : int; + async_proofs_n_tacworkers : int; + + async_proofs_cache : cache option; + async_proofs_mode : async_proofs; + + async_proofs_private_flags : string option; + async_proofs_full : bool; + async_proofs_never_reopen_branch : bool; + + async_proofs_tac_error_resilience : tac_error_filter; + async_proofs_cmd_error_resilience : bool; + async_proofs_delegation_threshold : float; + } + + let default_opts = { + async_proofs_n_workers = 1; + async_proofs_n_tacworkers = 2; + + async_proofs_cache = None; + + async_proofs_mode = APoff; + + async_proofs_private_flags = None; + async_proofs_full = false; + async_proofs_never_reopen_branch = false; + + async_proofs_tac_error_resilience = `Only [ "curly" ]; + async_proofs_cmd_error_resilience = true; + async_proofs_delegation_threshold = 0.03; + } + + let cur_opt = ref default_opts +end + +open AsyncOpts + +let async_proofs_is_master opt = + opt.async_proofs_mode = APon && + !Flags.async_proofs_worker_id = "master" + (* Protect against state changes *) let stm_purify f x = let st = Vernacstate.freeze_interp_state `No in @@ -36,8 +85,7 @@ let stm_purify f x = Exninfo.iraise e let execution_error ?loc state_id msg = - feedback ~id:state_id - (Message (Error, loc, msg)) + feedback ~id:state_id (Message (Error, loc, msg)) module Hooks = struct @@ -82,7 +130,7 @@ type aast = { loc : Loc.t option; indentation : int; strlen : int; - mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *) + mutable expr : vernac_control; (* mutable: Proof using hinted by aux file *) } let pr_ast { expr; indentation } = Pp.(int indentation ++ str " " ++ Ppvernac.pr_vernac expr) @@ -90,14 +138,14 @@ let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml. (* Commands piercing opaque *) let may_pierce_opaque = function - | { expr = VernacPrint _ } -> true - | { expr = VernacExtend (("Extraction",_), _) } -> true - | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true - | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true - | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true - | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true - | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true - | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true + | VernacPrint _ + | VernacExtend (("Extraction",_), _) + | VernacExtend (("SeparateExtraction",_), _) + | VernacExtend (("ExtractionLibrary",_), _) + | VernacExtend (("RecursiveExtractionLibrary",_), _) + | VernacExtend (("ExtractionConstant",_), _) + | VernacExtend (("ExtractionInlinedConstant",_), _) + | VernacExtend (("ExtractionInductive",_), _) -> true | _ -> false let update_global_env () = @@ -158,9 +206,10 @@ let mkTransCmd cast cids ceff cqueue = Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } (* Parts of the system state that are morally part of the proof state *) -let summary_pstate = [ Evarutil.meta_counter_summary_name; - Evd.evar_counter_summary_name; - "program-tcc-table" ] +let summary_pstate = Evarutil.meta_counter_summary_tag, + Evd.evar_counter_summary_tag, + Obligations.program_tcc_summary_tag + type cached_state = | Empty | Error of Exninfo.iexn @@ -352,10 +401,10 @@ end = struct (* {{{ *) In case you are hitting the race enable stm_debug. *) - if stm_debug () then Flags.we_are_parsing := false; + if !stm_debug then Flags.we_are_parsing := false; let fname = - "stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in + "stm_" ^ Str.global_replace (Str.regexp " ") "_" (Spawned.process_id ()) in let string_of_transaction = function | Cmd { cast = t } | Fork (t, _,_,_) -> (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") @@ -515,12 +564,10 @@ end = struct (* {{{ *) vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make - (let rec aux x = match x with - | VernacDefinition (_,((_,i),_),_) -> Names.Id.to_string i - | VernacStartTheoremProof (_,[Some ((_,i),_),_]) -> Names.Id.to_string i - | VernacTime (_, e) - | VernacTimeout (_, e) -> aux e - | _ -> "branch" in aux x) + (match Vernacprop.under_control x with + | VernacDefinition (_,((_, Name i),_),_) -> Id.to_string i + | VernacStartTheoremProof (_,[((_,i),_),_]) -> Id.to_string i + | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind let get_info id = @@ -529,7 +576,7 @@ end = struct (* {{{ *) | None -> raise Vcs_aux.Expired let set_state id s = (get_info id).state <- s; - if Flags.async_proofs_is_master () then Hooks.(call state_ready id) + if async_proofs_is_master !cur_opt then Hooks.(call state_ready id) let get_state id = (get_info id).state let reached id = let info = get_info id in @@ -762,15 +809,21 @@ end = struct (* {{{ *) let fix_exn_ref = ref (fun x -> x) type proof_part = - Proof_global.state * Summary.frozen_bits (* only meta counters *) + Proof_global.t * + int * (* Evarutil.meta_counter_summary_tag *) + int * (* Evd.evar_counter_summary_tag *) + Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) type partial_state = [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] let proof_part_of_frozen { Vernacstate.proof; system } = + let st = States.summary_of_state system in proof, - Summary.project_summary (States.summary_of_state system) summary_pstate + Summary.project_from_summary st Util.(pi1 summary_pstate), + Summary.project_from_summary st Util.(pi2 summary_pstate), + Summary.project_from_summary st Util.(pi3 summary_pstate) let freeze marshallable id = VCS.set_state id (Valid (Vernacstate.freeze_interp_state marshallable)) @@ -830,16 +883,21 @@ end = struct (* {{{ *) else s with VCS.Expired -> s in VCS.set_state id (Valid s) - | `ProofOnly(ontop,(pstate,counters)) -> + | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system - (Summary.surgery_summary - (States.summary_of_state s.system) - counters) } in + begin + let st = States.summary_of_state s.system in + let st = Summary.modify_summary st Util.(pi1 summary_pstate) c1 in + let st = Summary.modify_summary st Util.(pi2 summary_pstate) c2 in + let st = Summary.modify_summary st Util.(pi3 summary_pstate) c3 in + st + end + } in VCS.set_state id (Valid s) with VCS.Expired -> () @@ -854,10 +912,10 @@ end = struct (* {{{ *) let same_env { Vernacstate.system = s1 } { Vernacstate.system = s2 } = let s1 = States.summary_of_state s1 in - let e1 = Summary.project_summary s1 [Global.global_env_summary_name] in + let e1 = Summary.project_from_summary s1 Global.global_env_summary_tag in let s2 = States.summary_of_state s2 in - let e2 = Summary.project_summary s2 [Global.global_env_summary_name] in - Summary.pointer_equal e1 e2 + let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in + e1 == e2 let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) f id @@ -943,7 +1001,7 @@ let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = in (* Some special handling of bullets and { }, to get a nicer display *) let pred n = max 0 (n-1) in - let ind, nl, new_beginend = match cmd with + let ind, nl, new_beginend = match Vernacprop.under_control cmd with | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend | VernacEndSubproof -> List.hd beginend, false, List.tl beginend | VernacBullet _ -> pred ind, nl, beginend @@ -1008,25 +1066,26 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in * future refactorings. - *) - let rec is_filtered_command = function - | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ - | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e - | _ -> false + *) + let is_filtered_command = function + | VernacResetName _ | VernacResetInitial | VernacBack _ + | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ + | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true + | _ -> false in - let aux_interp st cmd = - if is_filtered_command cmd then - (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) - else match cmd with - | VernacShow ShowScript -> ShowScript.show_script (); st - | expr -> - stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (Loc.tag ?loc expr) - with e -> - let e = CErrors.push e in - Exninfo.iraise Hooks.(call_process_error_once e) + let aux_interp st expr = + let cmd = Vernacprop.under_control expr in + if is_filtered_command cmd then + (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) + else + match cmd with + | VernacShow ShowScript -> ShowScript.show_script (); st (** XX we are ignoring control here *) + | _ -> + stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (Loc.tag ?loc expr) + with e -> + let e = CErrors.push e in + Exninfo.iraise Hooks.(call_process_error_once e) in aux_interp st expr (****************************** CRUFT *****************************************) @@ -1042,7 +1101,7 @@ module Backtrack : sig val branches_of : Stateid.t -> backup (* Returns the state that the command should backtract to *) - val undo_vernac_classifier : vernac_expr -> Stateid.t * vernac_when + val undo_vernac_classifier : vernac_control -> Stateid.t * vernac_when end = struct (* {{{ *) @@ -1090,7 +1149,11 @@ end = struct (* {{{ *) match VCS.visit id with | { step = `Fork ((_,_,_,l),_) } -> l, false,0 | { step = `Cmd { cids = l; ctac } } -> l, ctac,0 - | { step = `Alias (_,{ expr = VernacUndo n}) } -> [], false, n + | { step = `Alias (_,{ expr }) } when not (Vernacprop.has_Fail expr) -> + begin match Vernacprop.under_control expr with + | VernacUndo n -> [], false, n + | _ -> [],false,0 + end | _ -> [],false,0 in match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x @@ -1105,10 +1168,10 @@ end = struct (* {{{ *) " the \"-async-proofs-cache force\" option to Coq.")) let undo_vernac_classifier v = - if VCS.is_interactive () = `No && !Flags.async_proofs_cache <> Some Flags.Force + if VCS.is_interactive () = `No && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try - match v with + match Vernacprop.under_control v with | VernacResetInitial -> Stateid.initial, VtNow | VernacResetName (_,name) -> @@ -1201,7 +1264,7 @@ let _ = CErrors.register_handler (function type document_node = { indentation : int; - ast : Vernacexpr.vernac_expr; + ast : Vernacexpr.vernac_control; id : Stateid.t; } @@ -1216,7 +1279,7 @@ type static_block_detection = type recovery_action = { base_state : Stateid.t; goals_to_admit : Goal.goal list; - recovery_command : Vernacexpr.vernac_expr option; + recovery_command : Vernacexpr.vernac_control option; } type dynamic_block_error_recovery = @@ -1241,7 +1304,7 @@ let prev_node { id } = let cur_node id = mk_doc_node id (VCS.visit id) let is_block_name_enabled name = - match !Flags.async_proofs_tac_error_resilience with + match !cur_opt.async_proofs_tac_error_resilience with | `None -> false | `All -> true | `Only l -> List.mem name l @@ -1249,7 +1312,7 @@ let is_block_name_enabled name = let detect_proof_block id name = let name = match name with None -> "indent" | Some x -> x in if is_block_name_enabled name && - (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ()) + (async_proofs_is_master !cur_opt || Flags.async_proofs_is_worker ()) then ( match cur_node id with | None -> () @@ -1351,7 +1414,7 @@ end = struct (* {{{ *) let task_match age t = match age, t with | Fresh, BuildProof { t_states } -> - not !Flags.async_proofs_full || + not !cur_opt.async_proofs_full || List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states | Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l @@ -1388,7 +1451,7 @@ end = struct (* {{{ *) feedback (InProgress ~-1); t_assign (`Val pl); record_pb_time ?loc:t_loc t_name time; - if !Flags.async_proofs_full || t_drop + if !cur_opt.async_proofs_full || t_drop then `Stay(t_states,[States t_states]) else `End | Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, @@ -1453,7 +1516,7 @@ end = struct (* {{{ *) stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque,None))) }) in + expr = VernacExpr ([], VernacEndProof (Proved (Opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1515,12 +1578,13 @@ end = struct (* {{{ *) | ReqStates sl -> RespStates (perform_states sl) let on_marshal_error s = function - | States _ -> msg_error(Pp.strbrk("Marshalling error: "^s^". "^ - "The system state could not be sent to the master process.")) + | States _ -> + msg_warning Pp.(strbrk("Marshalling error: "^s^". "^ + "The system state could not be sent to the master process.")) | BuildProof { t_exn_info; t_stop; t_assign; t_loc; t_drop = drop_pt } -> - msg_error(Pp.strbrk("Marshalling error: "^s^". "^ - "The system state could not be sent to the worker process. "^ - "Falling back to local, lazy, evaluation.")); + msg_warning Pp.(strbrk("Marshalling error: "^s^". "^ + "The system state could not be sent to the worker process. "^ + "Falling back to local, lazy, evaluation.")); t_assign(`Comp(build_proof_here ?loc:t_loc ~drop_pt t_exn_info t_stop)); feedback (InProgress ~-1) @@ -1562,8 +1626,8 @@ end = struct (* {{{ *) let queue = ref None let init () = - if Flags.async_proofs_is_master () then - queue := Some (TaskQueue.create !Flags.async_proofs_n_workers) + if async_proofs_is_master !cur_opt then + queue := Some (TaskQueue.create !cur_opt.async_proofs_n_workers) else queue := Some (TaskQueue.create 0) @@ -1601,14 +1665,14 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque,None))) }); + expr = VernacExpr ([], VernacEndProof (Proved (Opaque,None))) }); `OK proof end with e -> let (e, info) = CErrors.push e in (try match Stateid.get info with | None -> - msg_error Pp.( + msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) | Some (_, cur) -> @@ -1618,17 +1682,17 @@ end = struct (* {{{ *) | { step = `Qed ( { qast = { loc } }, _) } | { step = `Sideff (ReplayCommand { loc }, _) } -> let start, stop = Option.cata Loc.unloc (0,0) loc in - msg_error Pp.( + msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ str ": chars " ++ int start ++ str "-" ++ int stop ++ spc () ++ iprint (e, info)) | _ -> - msg_error Pp.( + msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) with e -> - msg_error Pp.(str"unable to print error message: " ++ - str (Printexc.to_string e))); + msg_warning Pp.(str"unable to print error message: " ++ + str (Printexc.to_string e))); if drop then `ERROR_ADMITTED else `ERROR let finish_task name (u,cst,_) d p l i = @@ -1890,15 +1954,16 @@ end = struct (* {{{ *) let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id { indentation; verbose; loc; expr = e; strlen } = - let e, time, fail = - let rec find ~time ~fail = function - | VernacTime (_,e) -> find ~time:true ~fail e - | VernacRedirect (_,(_,e)) -> find ~time ~fail e - | VernacFail e -> find ~time ~fail:true e - | e -> e, time, fail in find ~time:false ~fail:false e in + let e, time, batch, fail = + let rec find ~time ~batch ~fail = function + | VernacTime (batch,(_,e)) -> find ~time:true ~batch ~fail e + | VernacRedirect (_,(_,e)) -> find ~time ~batch ~fail e + | VernacFail e -> find ~time ~batch ~fail:true e + | e -> e, time, batch, fail in + find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state `No in Vernacentries.with_fail st fail (fun () -> - (if time then System.with_time !Flags.time else (fun x -> x)) (fun () -> + (if time then System.with_time ~batch else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> let goals, _, _, _, _ = Proof.proof p in @@ -2028,7 +2093,7 @@ end = struct (* {{{ *) QueryTask.({ t_where = prev; t_for = id; t_what = q }) ~cancel_switch let init () = queue := Some (TaskQueue.create - (if !Flags.async_proofs_full then 1 else 0)) + (if !cur_opt.async_proofs_full then 1 else 0)) end (* }}} *) @@ -2040,20 +2105,17 @@ and Reach : sig end = struct (* {{{ *) -let pstate = summary_pstate - let async_policy () = - let open Flags in - if is_universe_polymorphism () then false + if Flags.is_universe_polymorphism () then false else if VCS.is_interactive () = `Yes then - (async_proofs_is_master () || !async_proofs_mode = APonLazy) + (async_proofs_is_master !cur_opt || !cur_opt.async_proofs_mode = APonLazy) else - (VCS.is_vio_doc () || !async_proofs_mode <> APoff) + (VCS.is_vio_doc () || !cur_opt.async_proofs_mode <> APoff) let delegate name = - get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold + get_hint_bp_time name >= !cur_opt.async_proofs_delegation_threshold || VCS.is_vio_doc () - || !Flags.async_proofs_full + || !cur_opt.async_proofs_full let warn_deprecated_nested_proofs = CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated" @@ -2068,30 +2130,43 @@ let collect_proof keep cur hd brkind id = | [] -> no_name | id :: _ -> Names.Id.to_string id in let loc = (snd cur).loc in - let rec is_defined_expr = function + let is_defined_expr = function | VernacEndProof (Proved (Transparent,_)) -> true - | VernacTime (_, e) -> is_defined_expr e - | VernacRedirect (_, (_, e)) -> is_defined_expr e - | VernacTimeout (_, e) -> is_defined_expr e | _ -> false in let is_defined = function - | _, { expr = e } -> is_defined_expr e in + | _, { expr = e } -> is_defined_expr (Vernacprop.under_control e) + && (not (Vernacprop.has_Fail e)) in + let proof_using_ast = function + | VernacProof(_,Some _) -> true + | _ -> false + in let proof_using_ast = function - | Some (_, ({ expr = VernacProof(_,Some _) } as v)) -> Some v + | Some (_, v) when proof_using_ast (Vernacprop.under_control v.expr) + && (not (Vernacprop.has_Fail v.expr)) -> Some v | _ -> None in let has_proof_using x = proof_using_ast x <> None in let proof_no_using = function - | Some (_, ({ expr = VernacProof(t,None) } as v)) -> t,v + | VernacProof(t,None) -> t + | _ -> assert false + in + let proof_no_using = function + | Some (_, v) -> proof_no_using (Vernacprop.under_control v.expr), v | _ -> assert false in let has_proof_no_using = function - | Some (_, { expr = VernacProof(_,None) }) -> true + | VernacProof(_,None) -> true + | _ -> false + in + let has_proof_no_using = function + | Some (_, v) -> has_proof_no_using (Vernacprop.under_control v.expr) + && (not (Vernacprop.has_Fail v.expr)) | _ -> false in let too_complex_to_delegate = function - | { expr = (VernacDeclareModule _ - | VernacDefineModule _ - | VernacDeclareModuleType _ - | VernacInclude _) } -> true - | { expr = (VernacRequire _ | VernacImport _) } -> true + | VernacDeclareModule _ + | VernacDefineModule _ + | VernacDeclareModuleType _ + | VernacInclude _ + | VernacRequire _ + | VernacImport _ -> true | ast -> may_pierce_opaque ast in let parent = function Some (p, _) -> p | None -> assert false in let is_empty = function `Async(_,[],_,_) | `MaybeASync(_,[],_,_) -> true | _ -> false in @@ -2099,7 +2174,8 @@ let collect_proof keep cur hd brkind id = let view = VCS.visit id in match view.step with | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x }) - when too_complex_to_delegate x -> `Sync(no_name,`Print) + when too_complex_to_delegate (Vernacprop.under_control x.expr) -> + `Sync(no_name,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) @@ -2119,7 +2195,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- VernacProof(t, Some hint); + v.expr <- VernacExpr([], VernacProof(t, Some hint)); `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2138,9 +2214,13 @@ let collect_proof keep cur hd brkind id = | `ASync(_,_,name,_) -> `Sync (name,why) in let check_policy rc = if async_policy () then rc else make_sync `Policy rc in + let is_vernac_exact = function + | VernacExactProof _ -> true + | _ -> false + in match cur, (VCS.visit id).step, brkind with - | (parent, { expr = VernacExactProof _ }), `Fork _, _ - | (parent, { expr = VernacTime (_, VernacExactProof _) }), `Fork _, _ -> + | (parent, x), `Fork _, _ when is_vernac_exact (Vernacprop.under_control x.expr) + && (not (Vernacprop.has_Fail x.expr)) -> `Sync (no_name,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) | _ -> @@ -2150,7 +2230,7 @@ let collect_proof keep cur hd brkind id = let rc = collect (Some cur) [] id in if is_empty rc then make_sync `AlreadyEvaluated rc else if (keep == VtKeep || keep == VtKeepAsAxiom) && - (not(State.is_cached_and_valid id) || !Flags.async_proofs_full) + (not(State.is_cached_and_valid id) || !cur_opt.async_proofs_full) then check_policy rc else make_sync `AlreadyEvaluated rc @@ -2232,9 +2312,9 @@ let known_state ?(redefine_qed=false) ~cache id = (* Absorb tactic errors from f () *) let resilient_tactic id blockname f = - if !Flags.async_proofs_tac_error_resilience = `None || - (Flags.async_proofs_is_master () && - !Flags.async_proofs_mode = Flags.APoff) + if !cur_opt.async_proofs_tac_error_resilience = `None || + (async_proofs_is_master !cur_opt && + !cur_opt.async_proofs_mode = APoff) then f () else try f () @@ -2243,9 +2323,9 @@ let known_state ?(redefine_qed=false) ~cache id = error_absorbing_tactic id blockname ie in (* Absorb errors from f x *) let resilient_command f x = - if not !Flags.async_proofs_cmd_error_resilience || - (Flags.async_proofs_is_master () && - !Flags.async_proofs_mode = Flags.APoff) + if not !cur_opt.async_proofs_cmd_error_resilience || + (async_proofs_is_master !cur_opt && + !cur_opt.async_proofs_mode = APoff) then f x else try f x @@ -2254,10 +2334,14 @@ let known_state ?(redefine_qed=false) ~cache id = (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let cherry_pick_non_pstate () = - Summary.freeze_summary ~marshallable:`No ~complement:true pstate, - Lib.freeze ~marshallable:`No in + let st = Summary.freeze_summaries ~marshallable:`No in + let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in + let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in + let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in + st, Lib.freeze ~marshallable:`No in + let inject_non_pstate (s,l) = - Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () + Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = stm_purify (fun id -> @@ -2287,10 +2371,10 @@ let known_state ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach ~cache:`Shallow view.next; Partac.vernac_interp ~solve ~abstract ~cancel_switch - !Flags.async_proofs_n_tacworkers view.next id x) + !cur_opt.async_proofs_n_tacworkers view.next id x) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel_switch } - when Flags.async_proofs_is_master () -> (fun () -> + when async_proofs_is_master !cur_opt -> (fun () -> reach view.next; Query.vernac_interp ~cancel_switch view.next id x ), cache, false @@ -2304,10 +2388,10 @@ let known_state ?(redefine_qed=false) ~cache id = if eff then update_global_env () ), (if eff then `Yes else cache), true | `Cmd { cast = x; ceff = eff } -> (fun () -> - (match !Flags.async_proofs_mode with - | Flags.APon | Flags.APonLazy -> + (match !cur_opt.async_proofs_mode with + | APon | APonLazy -> resilient_command reach view.next - | Flags.APoff -> reach view.next); + | APoff -> reach view.next); let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); if eff then update_global_env () @@ -2344,7 +2428,7 @@ let known_state ?(redefine_qed=false) ~cache id = | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); if okeep != keep then - msg_error(strbrk("The command closing the proof changed. " + msg_warning(strbrk("The command closing the proof changed. " ^"The kernel cannot take this into account and will " ^(if keep == VtKeep then "not check " else "reject ") ^"the "^(if keep == VtKeep then "new" else "incomplete") @@ -2434,7 +2518,7 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true in let cache_step = - if !Flags.async_proofs_cache = Some Flags.Force then `Yes + if !cur_opt.async_proofs_cache = Some Force then `Yes else cache_step in State.define ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; @@ -2447,15 +2531,28 @@ end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) +(* Main initalization routine *) type stm_init_options = { + (* The STM will set some internal flags differently depending on the + specified [doc_type]. This distinction should dissappear at some + some point. *) doc_type : stm_doc_type; + + (* Initial load path in scope for the document. Usually extracted + from -R options / _CoqProject *) + iload_path : Mltop.coq_path list; + + (* Require [require_libs] before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) require_libs : (string * string option * bool option) list; -(* - fb_handler : Feedback.feedback -> unit; - iload_path : (string list * string * bool) list; - implicit_std : bool; -*) + + (* STM options that apply to the current document. *) + stm_options : AsyncOpts.stm_opt; } +(* fb_handler : Feedback.feedback -> unit; *) (* let doc_type_module_name (std : stm_doc_type) = @@ -2465,9 +2562,11 @@ let doc_type_module_name (std : stm_doc_type) = *) let init_core () = + if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; State.register_root_state () -let new_doc { doc_type ; require_libs } = +let new_doc { doc_type ; iload_path; require_libs; stm_options } = + let load_objs libs = let rq_file (dir, from, exp) = let mp = Libnames.(Qualid (Loc.tag @@ qualid_of_string dir)) in @@ -2476,11 +2575,19 @@ let new_doc { doc_type ; require_libs } = List.(iter rq_file (rev libs)) in + (* Set the options from the new documents *) + AsyncOpts.cur_opt := stm_options; + (* We must reset the whole state before creating a document! *) State.restore_root_state (); let doc = VCS.init doc_type Stateid.initial in + (* Set load path; important, this has to happen before we declare + the library below as [Declaremods/Library] will infer the module + name by looking at the load path! *) + List.iter Mltop.add_coq_path iload_path; + begin match doc_type with | Interactive ln -> Safe_typing.allow_delayed_constants := true; @@ -2497,16 +2604,18 @@ let new_doc { doc_type ; require_libs } = VCS.set_ldir ldir; set_compilation_hints ln end; + + (* Import initial libraries. *) load_objs require_libs; - (* We record the state here! *) + (* We record the state at this point! *) State.define ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); - if Flags.async_proofs_is_master () then begin + if async_proofs_is_master !cur_opt then begin stm_prerr_endline (fun () -> "Initializing workers"); Query.init (); - let opts = match !Flags.async_proofs_private_flags with + let opts = match !cur_opt.async_proofs_private_flags with | None -> [] | Some s -> Str.split_delim (Str.regexp ",") s in begin try @@ -2592,7 +2701,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = (u,a,true), p with e -> let e = CErrors.push e in - msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); + msg_warning (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 let merge_proof_branch ~valid ?id qast keep brname = @@ -2705,10 +2814,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) | VtQuery (true, route), w -> let id = VCS.new_node ~id:newtip () in let queue = - if !Flags.async_proofs_full then `QueryQueue (ref false) + if !cur_opt.async_proofs_full then `QueryQueue (ref false) else if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && - may_pierce_opaque x + may_pierce_opaque (Vernacprop.under_control x.expr) then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); @@ -2770,7 +2879,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) rc (* Side effect on all branches *) - | VtUnknown, _ when expr = VernacToplevelControl Drop -> + | VtUnknown, _ when Vernacprop.under_control expr = VernacToplevelControl Drop -> let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp (VCS.get_branch_pos head) st x); `Ok @@ -2782,7 +2891,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) VCS.commit id (mkTransCmd x l in_proof `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) - let action = match x.expr with + let action = match Vernacprop.under_control x.expr with | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv | _ -> ReplayCommand x in VCS.propagate_sideff ~action; @@ -2805,12 +2914,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) if not in_proof && Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in - let rec opacity_of_produced_term = function + let opacity_of_produced_term = function (* This AST is ambiguous, hence we check it dynamically *) | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity - | VernacLocal (_,e) -> opacity_of_produced_term e | _ -> Doesn'tGuaranteeOpacity in - VCS.commit id (Fork (x,bname,opacity_of_produced_term x.expr,[])); + VCS.commit id (Fork (x,bname,opacity_of_produced_term (Vernacprop.under_control x.expr),[])); let proof_mode = default_proof_mode () in VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; @@ -2870,7 +2978,7 @@ let parse_sentence ~doc sid pa = (str "Currently, the parsing api only supports parsing at the tip of the document." ++ fnl () ++ str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ str " but the current tip is: " ++ str (Stateid.to_string cur_tip)) ; - if not (Stateid.equal sid real_tip) && !Flags.debug && stm_debug () then + if not (Stateid.equal sid real_tip) && !Flags.debug && !stm_debug then Feedback.msg_debug (str "Warning, the real tip doesn't match the current tip." ++ str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ @@ -2950,16 +3058,25 @@ let query ~doc ~at ~route s = stm_purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) else Reach.known_state ~cache:`Yes at; - let loc, ast = parse_sentence ~doc at s in - let indentation, strlen = compute_indentation ?loc at in - CWarnings.set_current_loc loc; - let clas = Vernac_classifier.classify_vernac ast in - let aast = { verbose = true; indentation; strlen; loc; expr = ast } in - match clas with - | VtMeta , _ -> (* TODO: can this still happen ? *) - ignore(process_transaction ~part_of_script:false aast (VtMeta,VtNow)) - | _ -> - ignore(process_transaction aast (VtQuery (false, route), VtNow))) + try + while true do + let loc, ast = parse_sentence ~doc at s in + let indentation, strlen = compute_indentation ?loc at in + CWarnings.set_current_loc loc; + let clas = Vernac_classifier.classify_vernac ast in + let aast = { verbose = true; indentation; strlen; loc; expr = ast } in + match clas with + | VtMeta , _ -> (* TODO: can this still happen ? *) + ignore(process_transaction ~part_of_script:false aast (VtMeta,VtNow)) + | _ -> + ignore(process_transaction aast (VtQuery (false,route), VtNow)) + done; + with + | End_of_input -> () + | exn -> + let iexn = CErrors.push exn in + Exninfo.iraise iexn + ) s let edit_at ~doc id = @@ -3029,7 +3146,7 @@ let edit_at ~doc id = VCS.delete_boxes_of id; VCS.gc (); VCS.print (); - if not !Flags.async_proofs_full then + if not !cur_opt.async_proofs_full then Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in @@ -3045,7 +3162,7 @@ let edit_at ~doc id = | _, Some _, None -> assert false | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) -> let tip = VCS.cur_tip () in - if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch + if has_failed qed_id && is_pure qed_id && not !cur_opt.async_proofs_never_reopen_branch then reopen_branch start id mode qed_id tip bn else backto id (Some bn) | true, Some { qed = qed_id }, Some(mode,bn) -> diff --git a/stm/stm.mli b/stm/stm.mli index 9fd35a0d3..8a4de34b4 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -10,6 +10,33 @@ open Names (** state-transaction-machine interface *) +(* Flags *) +module AsyncOpts : sig + + type cache = Force + type async_proofs = APoff | APonLazy | APon + type tac_error_filter = [ `None | `Only of string list | `All ] + + type stm_opt = { + async_proofs_n_workers : int; + async_proofs_n_tacworkers : int; + + async_proofs_cache : cache option; + async_proofs_mode : async_proofs; + + async_proofs_private_flags : string option; + async_proofs_full : bool; + async_proofs_never_reopen_branch : bool; + + async_proofs_tac_error_resilience : tac_error_filter; + async_proofs_cmd_error_resilience : bool; + async_proofs_delegation_threshold : float; + } + + val default_opts : stm_opt + +end + (** The STM doc type determines some properties such as what uncompleted proofs are allowed and recording of aux files. *) type stm_doc_type = @@ -19,14 +46,26 @@ type stm_doc_type = (* Main initalization routine *) type stm_init_options = { + (* The STM will set some internal flags differently depending on the + specified [doc_type]. This distinction should dissappear at some + some point. *) doc_type : stm_doc_type; + + (* Initial load path in scope for the document. Usually extracted + from -R options / _CoqProject *) + iload_path : Mltop.coq_path list; + + (* Require [require_libs] before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) require_libs : (string * string option * bool option) list; -(* - fb_handler : Feedback.feedback -> unit; - iload_path : (string list * string * bool) list; - implicit_std : bool; -*) + + (* STM options that apply to the current document. *) + stm_options : AsyncOpts.stm_opt; } +(* fb_handler : Feedback.feedback -> unit; *) (** The type of a STM document *) type doc @@ -39,7 +78,7 @@ val new_doc : stm_init_options -> doc * Stateid.t (* [parse_sentence sid pa] Reads a sentence from [pa] with parsing state [sid] Returns [End_of_input] if the stream ends *) val parse_sentence : doc:doc -> Stateid.t -> Pcoq.Gram.coq_parsable -> - Vernacexpr.vernac_expr Loc.located + Vernacexpr.vernac_control Loc.located (* Reminder: A parsable [pa] is constructed using [Pcoq.Gram.coq_parsable stream], where [stream : char Stream.t]. *) @@ -53,7 +92,7 @@ exception End_of_input If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> - bool -> Vernacexpr.vernac_expr Loc.located -> + bool -> Vernacexpr.vernac_control Loc.located -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* [query at ?report_with cmd] Executes [cmd] at a given state [at], @@ -111,7 +150,7 @@ val get_current_state : doc:doc -> Stateid.t val get_ldir : doc:doc -> Names.DirPath.t (* This returns the node at that position *) -val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option +val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_control Loc.located) option (* Filename *) val set_compilation_hints : string -> unit @@ -174,7 +213,7 @@ type static_block_declaration = { type document_node = { indentation : int; - ast : Vernacexpr.vernac_expr; + ast : Vernacexpr.vernac_control; id : Stateid.t; } @@ -189,7 +228,7 @@ type static_block_detection = type recovery_action = { base_state : Stateid.t; goals_to_admit : Goal.goal list; - recovery_command : Vernacexpr.vernac_expr option; + recovery_command : Vernacexpr.vernac_control option; } type dynamic_block_error_recovery = @@ -225,3 +264,6 @@ val state_of_id : doc:doc -> (* Queries for backward compatibility *) val current_proof_depth : doc:doc -> int val get_all_proof_names : doc:doc -> Id.t list + +(** Enable STM debugging *) +val stm_debug : bool ref diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index 17f90b7b1..22b45a9be 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) +let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 3aa2cd707..cbbb54e45 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -8,6 +8,7 @@ open Vernacexpr open CErrors +open Util open Pp let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] @@ -47,36 +48,19 @@ let declare_vernac_classifier = classifiers := !classifiers @ [s,f] -let make_polymorphic (a, b as x) = - match a with - | VtStartProof (x, _, ids) -> - VtStartProof (x, Doesn'tGuaranteeOpacity, ids), b - | _ -> x +let idents_of_name : Names.Name.t -> Names.Id.t list = + function + | Names.Anonymous -> [] + | Names.Name n -> [n] -let rec classify_vernac e = - let static_classifier e = match e with +let classify_vernac e = + let static_classifier ~poly e = match e with (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) - | VernacSetOption (["Universe"; "Polymorphism"],_) - | VernacUnsetOption (["Universe"; "Polymorphism"]) -> VtSideff [], VtNow - (* Nested vernac exprs *) - | VernacProgram e -> classify_vernac e - | VernacLocal (_,e) -> classify_vernac e - | VernacPolymorphic (b, e) -> - if b || Flags.is_universe_polymorphism () (* Ok or not? *) then - make_polymorphic (classify_vernac e) - else classify_vernac e - | VernacTimeout (_,e) -> classify_vernac e - | VernacTime (_,e) | VernacRedirect (_, (_,e)) -> classify_vernac e - | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) - (match classify_vernac e with - | ( VtQuery _ | VtProofStep _ | VtSideff _ - | VtProofMode _ | VtMeta), _ as x -> x - | VtQed _, _ -> - VtProofStep { parallel = `No; proof_block_detection = None }, - VtNow - | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) + | ( VernacSetOption (l,_) | VernacUnsetOption l) + when CList.equal String.equal l Vernacentries.universe_polymorphism_option_name -> + VtSideff [], VtNow (* Qed *) | VernacAbort _ -> VtQed VtDrop, VtLater | VernacEndProof Admitted -> VtQed VtKeepAsAxiom, VtLater @@ -103,35 +87,42 @@ let rec classify_vernac e = | VernacUnsetOption (["Default";"Proof";"Using"]) | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) - | VernacDefinition ( - (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> - VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater + | VernacDefinition ((Decl_kinds.DoDischarge,_),((_,i),_),ProveBody _) -> + VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity, idents_of_name i), VtLater | VernacDefinition (_,((_,i),_),ProveBody _) -> - VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater + let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof(default_proof_mode (),guarantee, idents_of_name i), VtLater | VernacStartTheoremProof (_,l) -> - let ids = - CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in - VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater - | VernacGoal _ -> VtStartProof (default_proof_mode (),GuaranteesOpacity,[]), VtLater - | VernacFixpoint (_,l) -> + let ids = List.map (fun (((_, i), _), _) -> i) l in + let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof (default_proof_mode (),guarantee,ids), VtLater + | VernacFixpoint (discharge,l) -> + let guarantee = + if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + else GuaranteesOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater - | VernacCoFixpoint (_,l) -> + | VernacCoFixpoint (discharge,l) -> + let guarantee = + if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + else GuaranteesOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> snd id) l) l) in VtSideff ids, VtLater - | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater + | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff (idents_of_name id), VtLater | VernacInductive (_, _,_,l) -> let ids = List.map (fun (((_,((_,id),_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l @@ -176,12 +167,12 @@ let rec classify_vernac e = (* These commands alter the parser *) | VernacOpenCloseScope _ | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ - | VernacSyntaxExtension _ + | VernacSyntaxExtension _ | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) - | VernacProofMode _ + | VernacProofMode _ -> VtSideff [], VtNow (* These are ambiguous *) | VernacInstance _ -> VtUnknown, VtNow (* Stm will install a new classifier to handle these *) @@ -192,16 +183,33 @@ let rec classify_vernac e = (* What are these? *) | VernacToplevelControl _ | VernacRestoreState _ - | VernacWriteState _ -> VtUnknown, VtNow + | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> try List.assoc s !classifiers l () with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let res = static_classifier e in - if Flags.is_universe_polymorphism () then - make_polymorphic res - else res + let rec static_control_classifier ~poly = function + | VernacExpr (f, e) -> + let poly = List.fold_left (fun poly f -> + match f with + | VernacPolymorphic b -> b + | (VernacProgram | VernacLocal _) -> poly + ) poly f in + static_classifier ~poly e + | VernacTimeout (_,e) -> static_control_classifier ~poly e + | VernacTime (_,(_,e)) | VernacRedirect (_, (_,e)) -> + static_control_classifier ~poly e + | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + (match static_control_classifier ~poly e with + | ( VtQuery _ | VtProofStep _ | VtSideff _ + | VtProofMode _ | VtMeta), _ as x -> x + | VtQed _, _ -> + VtProofStep { parallel = `No; proof_block_detection = None }, + VtNow + | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) + in + static_control_classifier ~poly:(Flags.is_universe_polymorphism ()) e let classify_as_query = VtQuery (true,Feedback.default_route), VtLater let classify_as_sideeff = VtSideff [], VtLater diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index fe42a03a3..c0571c1d6 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -12,7 +12,7 @@ open Genarg val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) -val classify_vernac : vernac_expr -> vernac_classification +val classify_vernac : vernac_control -> vernac_classification (** Install a vernacular classifier for VernacExtend *) val declare_vernac_classifier : diff --git a/stm/workerLoop.ml b/stm/workerLoop.ml index 64121eb3d..d606f19bf 100644 --- a/stm/workerLoop.ml +++ b/stm/workerLoop.ml @@ -6,14 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* Default priority *) +open CoqworkmgrApi +let async_proofs_worker_priority = ref Low + let rec parse = function | "--xml_format=Ppcmds" :: rest -> parse rest | x :: rest -> x :: parse rest | [] -> [] -let loop init args = - let args = parse args in +let loop init _coq_args extra_args = + let args = parse extra_args in Flags.quiet := true; init (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; + CoqworkmgrApi.init !async_proofs_worker_priority; args diff --git a/stm/workerLoop.mli b/stm/workerLoop.mli index 53f745935..c42b48a28 100644 --- a/stm/workerLoop.mli +++ b/stm/workerLoop.mli @@ -6,4 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -val loop : (unit -> unit) -> string list -> string list +(* Default priority *) +val async_proofs_worker_priority : CoqworkmgrApi.priority ref + +val loop : (unit -> unit) -> Coqargs.coq_cmdopts -> string list -> string list diff --git a/tactics/auto.ml b/tactics/auto.ml index fa8435d1f..eec7a5f2a 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -32,7 +32,7 @@ open Hints let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l let compute_secvars gl = - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let hyps = Proofview.Goal.hyps gl in secvars_of_hyps hyps (* tell auto not to reuse already instantiated metas in unification (for @@ -316,7 +316,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in - let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in + let decl = Tacmach.New.pf_last_hyp gl in let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list @@ -514,8 +514,8 @@ let delta_auto debug mod_delta n lems dbnames = let delta_auto = if Flags.profile then - let key = Profile.declare_profile "delta_auto" in - Profile.profile5 key delta_auto + let key = CProfile.declare_profile "delta_auto" in + CProfile.profile5 key delta_auto else delta_auto let auto ?(debug=Off) n = delta_auto debug false n diff --git a/tactics/auto.mli b/tactics/auto.mli index b9cd4932c..59809331e 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -16,14 +16,14 @@ open Decl_kinds open Hints open Tactypes -val compute_secvars : 'a Proofview.Goal.t -> Id.Pred.t +val compute_secvars : Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - 'a Proofview.Goal.t -> clausenv * constr + Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index cee6d4bea..a95e6b941 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -376,7 +376,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = Proofview.Goal.enter begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes - (project gl) (pf_concl gl) in + (pf_env gl) (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end in @@ -386,7 +386,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = in tclFIRST (List.map tclCOMPLETE tacl) -and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = +and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl = let open Proofview.Notations in let prods, concl = EConstr.decompose_prod_assum sigma concl in let nprods = List.length prods in @@ -464,7 +464,6 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co in let tac = run_hint t tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in - let _, env = Pfedit.get_current_context () in let pp = match p with | Some pat when get_typeclasses_filtered_unification () -> @@ -476,16 +475,16 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co | _ -> (tac, b, false, name, lazy (pr_hint env sigma t ++ pp)) in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db secvars only_classes sigma concl = +and e_trivial_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try - e_my_find_search db_list local_db secvars hd true only_classes sigma concl + e_my_find_search db_list local_db secvars hd true only_classes env sigma concl with Not_found -> [] -let e_possible_resolve db_list local_db secvars only_classes sigma concl = +let e_possible_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try - e_my_find_search db_list local_db secvars hd false only_classes sigma concl + e_my_find_search db_list local_db secvars hd false only_classes env sigma concl with Not_found -> [] let cut_of_hints h = @@ -719,7 +718,7 @@ module V85 = struct let concl = Goal.V82.concl s gl in let tacgl = {it = gl; sigma = s;} in let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in - let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in + let poss = e_possible_resolve hints info.hints secvars info.only_classes env s concl in let unique = is_unique env s concl in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> @@ -997,7 +996,7 @@ module Search = struct Hint_db.transparent_state cached_hints == st then cached_hints else - let hints = make_hints {it = Goal.goal (Proofview.Goal.assume g); sigma = project g} + let hints = make_hints {it = Goal.goal g; sigma = project g} st only_classes sign in autogoal_cache := (cwd, only_classes, sign, hints); hints @@ -1042,7 +1041,6 @@ module Search = struct let fail_if_nonclass info = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in if is_class_type sigma (Proofview.Goal.concl gl) then Proofview.tclUNIT () @@ -1072,7 +1070,7 @@ module Search = struct else str" without backtracking")); let secvars = compute_secvars gl in let poss = - e_possible_resolve hints info.search_hints secvars info.search_only_classes sigma concl in + e_possible_resolve hints info.search_hints secvars info.search_only_classes env sigma concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal @@ -1090,7 +1088,7 @@ module Search = struct pr_depth (idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then - str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) + str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl) else mt ()) in let msg = @@ -1111,7 +1109,7 @@ module Search = struct if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ - pr_ev sigma' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); + pr_ev sigma' (Proofview.Goal.goal gl')); let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in let hints' = if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) @@ -1120,7 +1118,7 @@ module Search = struct make_autogoal_hints info.search_only_classes ~st gl' else info.search_hints in - let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal (Proofview.Goal.assume gl')) gls in + let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; @@ -1137,7 +1135,7 @@ module Search = struct (if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) + ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k))); @@ -1262,7 +1260,7 @@ module Search = struct if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then Tacticals.New.tclZEROMSG (str"Not a subgoal for a class") else - let dep = dep || Proofview.unifiable sigma (Goal.goal (Proofview.Goal.assume gl)) gls in + let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info @@ -1570,7 +1568,7 @@ let _ = Hook.set Typeclasses.solve_all_instances_hook solve_inst let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = - let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env sigma gl in + let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env sigma gl in let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl Store.empty in let (ev, _) = destEvar sigma t in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 5e2006ccc..467754a84 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -53,7 +53,7 @@ let filter_hyp f tac = | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter begin fun gl -> - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let hyps = Proofview.Goal.hyps gl in seek hyps end @@ -98,7 +98,7 @@ let contradiction_context = end) | _ -> seek_neg rest in - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let hyps = Proofview.Goal.hyps gl in seek_neg hyps end diff --git a/tactics/eauto.ml b/tactics/eauto.ml index f5c6ab879..785d2f515 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -32,7 +32,7 @@ let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in + let t2 = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) @@ -148,12 +148,12 @@ let rec e_trivial_fail_db db_list local_db = let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) + (List.map fst (e_trivial_resolve (Tacmach.New.pf_env gl) (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end -and e_my_find_search sigma db_list local_db secvars hdc concl = +and e_my_find_search env sigma db_list local_db secvars hdc concl = let hint_of_db = hintmap_of sigma secvars hdc concl in let hintl = List.map_append (fun db -> @@ -178,20 +178,19 @@ and e_my_find_search sigma db_list local_db secvars hdc concl = | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in - let sigma, env = Pfedit.get_current_context () in (tac, lazy (pr_hint env sigma t))) in List.map tac_of_hint hintl -and e_trivial_resolve sigma db_list local_db secvars gl = +and e_trivial_resolve env sigma db_list local_db secvars gl = let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in - try priority (e_my_find_search sigma db_list local_db secvars hd gl) + try priority (e_my_find_search env sigma db_list local_db secvars hd gl) with Not_found -> [] -let e_possible_resolve sigma db_list local_db secvars gl = +let e_possible_resolve env sigma db_list local_db secvars gl = let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) - (e_my_find_search sigma db_list local_db secvars hd gl) + (e_my_find_search env sigma db_list local_db secvars hd gl) with Not_found -> [] let find_first_goal gls = @@ -291,7 +290,7 @@ module SearchProblem = struct let l = let concl = Reductionops.nf_evar (project g) (pf_concl g) in filter_tactics s.tacres - (e_possible_resolve (project g) s.dblist (List.hd s.localdb) secvars concl) + (e_possible_resolve (pf_env g) (project g) s.dblist (List.hd s.localdb) secvars concl) in List.map (fun (lgls, cost, pp) -> @@ -405,8 +404,8 @@ let e_search_auto debug (in_depth,p) lems db_list gl = pr_info_nop d; user_err Pp.(str "eauto: search failed") -(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) -(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) +(* let e_search_auto_key = CProfile.declare_profile "e_search_auto" *) +(* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) diff --git a/tactics/equality.ml b/tactics/equality.ml index c36ad980e..674d01777 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -266,7 +266,7 @@ let rewrite_elim with_evars frzevars cls c e = end let tclNOTSAMEGOAL tac = - let goal gl = Proofview.Goal.goal (Proofview.Goal.assume gl) in + let goal gl = Proofview.Goal.goal gl in Proofview.Goal.nf_enter begin fun gl -> let sigma = project gl in let ev = goal gl in @@ -324,7 +324,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = in let typ = match cls with | None -> pf_concl gl - | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) + | Some id -> pf_get_hyp_typ id gl in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) @@ -739,7 +739,7 @@ let keep_proof_equalities = function let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in - let s = get_sort_family_of env sigma ty1 in + let s = get_sort_family_of ~truncation_style:true env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in @@ -970,7 +970,7 @@ let rec build_discriminator env sigma true_0 false_0 dirn c = function let gen_absurdity id = Proofview.Goal.enter begin fun gl -> let sigma = project gl in - let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in + let hyp_typ = pf_get_hyp_typ id gl in if is_empty_type sigma hyp_typ then simplest_elim (mkVar id) @@ -1436,13 +1436,14 @@ let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = + let env, sigma = Proofview.Goal.(env gl, sigma gl) in let rec aux dest = function - | [] -> raise (RefinerError (NoSuchHyp id)) + | [] -> raise (RefinerError (env, sigma, NoSuchHyp id)) | d :: right -> let hyp = Context.Named.Declaration.get_id d in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in - aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) + aux MoveLast (Proofview.Goal.hyps gl) let injEq flags ?(old=false) with_evars clear_flag ipats = (* Decide which compatibility mode to use *) @@ -1582,7 +1583,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let body = mkApp (lambda_create env sigma (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) - let expected_goal = nf_betaiota sigma expected_goal in + let expected_goal = nf_betaiota env sigma expected_goal in (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in @@ -1715,8 +1716,8 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> @@ -1748,7 +1749,6 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) if is_local_def decl then tclTHEN (unfold_body x) (clear [x]) else @@ -1789,7 +1789,6 @@ let subst_all ?(flags=default_subst_tactic_flags) () = (* First step: find hypotheses to treat in linear time *) let find_equations gl = - let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in @@ -1815,7 +1814,6 @@ let subst_all ?(flags=default_subst_tactic_flags) () = (* Second step: treat equations *) let process hyp = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let sigma = project gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in diff --git a/tactics/hints.ml b/tactics/hints.ml index 70e84013b..7f9b5ef34 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1400,15 +1400,10 @@ let pr_hint env sigma h = match h.obj with | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt env sigma c) | Res_pf_THEN_trivial_fail (c, _) -> (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") - | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) + | Unfold_nth c -> + str"unfold " ++ pr_evaluable_reference c | Extern tac -> - let env = - try - let (_, env) = Pfedit.get_current_goal_context () in - env - with e when CErrors.noncritical e -> Global.env () - in - (str "(*external*) " ++ Pputils.pr_glb_generic env tac) + str "(*external*) " ++ Pputils.pr_glb_generic env tac let pr_id_hint env sigma (id, v) = let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in @@ -1507,6 +1502,7 @@ let pr_hint_db_env env sigma db = hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ content +(* Deprecated in the mli *) let pr_hint_db db = let sigma, env = Pfedit.get_current_context () in pr_hint_db_env env sigma db diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 8e851375a..2bb9be66b 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -39,7 +39,6 @@ type testing_function = Evd.evar_map -> EConstr.constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 let meta2 = mkmeta 2 -let meta3 = mkmeta 3 let op2bool = function Some _ -> true | None -> false @@ -49,7 +48,7 @@ let match_with_non_recursive_type sigma t = let (hdapp,args) = decompose_app sigma t in (match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then + if (Global.lookup_mind (fst ind)).mind_finite == CoFinite then Some (hdapp,args) else None @@ -89,6 +88,12 @@ let is_lax_conjunction = function let prod_assum sigma t = fst (decompose_prod_assum sigma t) +(* whd_beta normalize the types of arguments in a product *) +let rec whd_beta_prod sigma c = match EConstr.kind sigma c with + | Prod (n,t,c) -> mkProd (n,Reductionops.whd_beta sigma t,whd_beta_prod sigma c) + | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod sigma c) + | _ -> c + let match_with_one_constructor sigma style onlybinary allow_rec t = let (hdapp,args) = decompose_app sigma t in let res = match EConstr.kind sigma hdapp with @@ -112,7 +117,9 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = Some (hdapp,args) else None else - let ctyp = Termops.prod_applist sigma (EConstr.of_constr mip.mind_nf_lc.(0)) args in + let ctyp = whd_beta_prod sigma + (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) + (EConstr.of_constr mip.mind_nf_lc.(0)) args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) @@ -365,36 +372,39 @@ let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) let match_with_nodep_ind sigma t = let (hdapp,args) = decompose_app sigma t in - match EConstr.kind sigma hdapp with - | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in - if Array.length (mib.mind_packets)>1 then None else - let nodep_constr c = has_nodep_prod_after mib.mind_nparams sigma (EConstr.of_constr c) in - if Array.for_all nodep_constr mip.mind_nf_lc then - let params= - if Int.equal mip.mind_nrealargs 0 then args else - fst (List.chop mib.mind_nparams args) in - Some (hdapp,params,mip.mind_nrealargs) - else - None - | _ -> None + match EConstr.kind sigma hdapp with + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in + if Array.length (mib.mind_packets)>1 then None else + let nodep_constr c = + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma (EConstr.of_constr c) in + if Array.for_all nodep_constr mip.mind_nf_lc then + let params= + if Int.equal mip.mind_nrealargs 0 then args else + fst (List.chop mib.mind_nparams args) in + Some (hdapp,params,mip.mind_nrealargs) + else + None + | _ -> None let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) let match_with_sigma_type sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with - | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in - if Int.equal (Array.length (mib.mind_packets)) 1 && - (Int.equal mip.mind_nrealargs 0) && - (Int.equal (Array.length mip.mind_consnames)1) && - has_nodep_prod_after (mib.mind_nparams+1) sigma (EConstr.of_constr mip.mind_nf_lc.(0)) then - (*allowing only 1 existential*) - Some (hdapp,args) - else - None - | _ -> None + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in + if Int.equal (Array.length (mib.mind_packets)) 1 + && (Int.equal mip.mind_nrealargs 0) + && (Int.equal (Array.length mip.mind_consnames)1) + && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma + (EConstr.of_constr mip.mind_nf_lc.(0)) + then + (*allowing only 1 existential*) + Some (hdapp,args) + else + None + | _ -> None let is_sigma_type sigma t = op2bool (match_with_sigma_type sigma t) @@ -460,22 +470,6 @@ let find_this_eq_data_decompose gl eqn = user_err Pp.(str "Don't know what to do with JMeq on arguments not of same type.") in (lbeq,u,eq_args) -let match_eq_nf gls eqn (ref, hetero) = - let n = if hetero then 4 else 3 in - let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in - let pat = mkPattern (mkGAppRef ref args) in - match Id.Map.bindings (pf_matches gls pat eqn) with - | [(m1,t);(m2,x);(m3,y)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - (t,pf_whd_all gls x,pf_whd_all gls y) - | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms.") - -let dest_nf_eq gls eqn = - try - snd (first_match (match_eq_nf gls eqn) equalities) - with PatternMatchingFailure -> - user_err Pp.(str "Not an equality.") - (*** Sigma-types *) let match_sigma env sigma ex = diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 8ff6fe95c..01d916053 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -120,11 +120,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> +val find_eq_data_decompose : Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) @@ -144,9 +144,6 @@ val is_matching_sigma : Environ.env -> evar_map -> constr -> bool [t,u,T] and a boolean telling if equality is on the left side *) val match_eqdec : Environ.env -> evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr -(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : 'a Proofview.Goal.t -> constr -> (constr * constr * constr) - (** Match a negation *) val is_matching_not : Environ.env -> evar_map -> constr -> bool val is_matching_imp_False : Environ.env -> evar_map -> constr -> bool diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e1bf32f3c..bc2fea2bd 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -121,8 +121,7 @@ let define internal id c p univs = let fd = declare_constant ~internal in let id = compute_name internal id in let ctx = Evd.normalize_evar_universe_context univs in - let c = Vars.subst_univs_fn_constr - (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in + let c = Universes.subst_opt_univs_constr (Evd.evar_universe_context_subst ctx) c in let univs = if p then Polymorphic_const_entry (UState.context ctx) else Monomorphic_const_entry (UState.context_set ctx) diff --git a/tactics/inv.ml b/tactics/inv.ml index 46b10bf33..5435b63ce 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -334,6 +334,16 @@ let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id If it can discriminate then the goal is proved, if not tries to use it as a rewrite rule. It erases the clause which is given as input *) +let dest_nf_eq env sigma t = match EConstr.kind sigma t with +| App (r, [| t; x; y |]) -> + let open Reductionops in + let lazy eq = Coqlib.coq_eq_ref in + if EConstr.is_global sigma eq r then + (t, whd_all env sigma x, whd_all env sigma y) + else user_err Pp.(str "Not an equality.") +| _ -> + user_err Pp.(str "Not an equality.") + let projectAndApply as_mode thin avoid id eqname names depids = let subst_hyp l2r id = tclTHEN (tclTRY(rewriteInConcl l2r (EConstr.mkVar id))) @@ -343,8 +353,8 @@ let projectAndApply as_mode thin avoid id eqname names depids = Proofview.Goal.enter begin fun gl -> let sigma = project gl in (** We only look at the type of hypothesis "id" *) - let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in - let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in + let hyp = pf_nf_evar gl (pf_get_hyp_typ id gl) in + let (t,t1,t2) = dest_nf_eq (pf_env gl) sigma hyp in match (EConstr.kind sigma t1, EConstr.kind sigma t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 1ae3577ed..197b3030d 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -234,10 +234,9 @@ let inversion_scheme env sigma t sort dep_option inv_op = let p = Evarutil.nf_evars_universes sigma invProof in p, sigma -let add_inversion_lemma name env sigma t sort dep inv_op = +let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in let univs = - let poly = Flags.use_polymorphic_flag () in Evd.const_univ_entry ~poly sigma in let entry = definition_entry ~univs invProof in @@ -247,13 +246,13 @@ let add_inversion_lemma name env sigma t sort dep inv_op = (* inv_op = Inv (derives de complete inv. lemma) * inv_op = InvNoThining (derives de semi inversion lemma) *) -let add_inversion_lemma_exn na com comsort bool tac = +let add_inversion_lemma_exn ~poly na com comsort bool tac = let env = Global.env () in - let evd = ref (Evd.from_env env) in - let c = Constrintern.interp_type_evars env evd com in - let evd, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env !evd comsort in + let sigma = Evd.from_env env in + let sigma, c = Constrintern.interp_type_evars env sigma com in + let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env sigma comsort in try - add_inversion_lemma na env evd c sort bool tac + add_inversion_lemma ~poly na env sigma c sort bool tac with | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) user_err ~hdr:"Inv needs Nodep Prop Set" s diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 8745ad397..f221b1fd9 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -14,6 +14,6 @@ open Misctypes val lemInv_clause : quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic -val add_inversion_lemma_exn : +val add_inversion_lemma_exn : poly:bool -> Id.t -> constr_expr -> Sorts.family -> bool -> (Id.t -> unit Proofview.tactic) -> unit diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index cea6ccc30..e7da17cff 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -540,7 +540,6 @@ module New = struct let nthHypId m gl = (** We only use [id] *) - let gl = Proofview.Goal.assume gl in nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -572,7 +571,7 @@ module New = struct let afterHyp id tac = Proofview.Goal.enter begin fun gl -> - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let hyps = Proofview.Goal.hyps gl in let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem end @@ -658,12 +657,12 @@ module New = struct let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) - let c = Proofview.Goal.concl (Goal.assume gl) in + let c = Proofview.Goal.concl gl in pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_hyp id gl = (** Retyping will expand evars anyway. *) - let c = pf_get_hyp_typ id (Goal.assume gl) in + let c = pf_get_hyp_typ id gl in pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_clause id gl = match id with diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 169ac5c90..c5d5c8c12 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -23,7 +23,7 @@ val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic val tclTHENSEQ : tactic list -> tactic -[@@ocaml.deprecated "alias of API.Tacticals.tclTHENLIST"] +[@@ocaml.deprecated "alias of Tacticals.tclTHENLIST"] val tclTHENLIST : tactic list -> tactic val tclTHEN_i : tactic -> (int -> tactic) -> tactic val tclTHENFIRST : tactic -> tactic -> tactic @@ -225,7 +225,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : 'a Proofview.Goal.t -> int -> named_context + val nLastDecls : Proofview.Goal.t -> int -> named_context val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> unit Proofview.tactic) -> (Id.t -> unit Proofview.tactic) -> @@ -236,7 +236,7 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `LZ ] Proofview.Goal.t -> named_context) -> + val onHyps : (Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -244,9 +244,9 @@ module New : sig val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic - val elimination_sort_of_goal : 'a Proofview.Goal.t -> Sorts.family - val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> Sorts.family - val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> Sorts.family + val elimination_sort_of_goal : Proofview.Goal.t -> Sorts.family + val elimination_sort_of_hyp : Id.t -> Proofview.Goal.t -> Sorts.family + val elimination_sort_of_clause : Id.t option -> Proofview.Goal.t -> Sorts.family val elimination_then : (branch_args -> unit Proofview.tactic) -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e072bd95f..29a30b4a2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -59,28 +59,6 @@ let typ_of env sigma c = open Goptions -(* Option for 8.2 compatibility *) -let dependent_propositions_elimination = ref true - -let use_dependent_propositions_elimination () = - !dependent_propositions_elimination - -let _ = - declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "dependent-propositions-elimination tactic"; - optkey = ["Dependent";"Propositions";"Elimination"]; - optread = (fun () -> !dependent_propositions_elimination) ; - optwrite = (fun b -> dependent_propositions_elimination := b) } - -let _ = - declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "trigger bugged context matching compatibility"; - optkey = ["Tactic";"Compat";"Context"]; - optread = (fun () -> !Flags.tactic_context_compat) ; - optwrite = (fun b -> Flags.tactic_context_compat := b) } - let apply_solve_class_goals = ref false let _ = @@ -173,7 +151,6 @@ let unsafe_intro env store decl b = let introduction ?(check=true) id = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let hyps = named_context_val (Proofview.Goal.env gl) in @@ -187,7 +164,7 @@ let introduction ?(check=true) id = match EConstr.kind sigma concl with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b - | _ -> raise (RefinerError IntroNeedsProduct) + | _ -> raise (RefinerError (env, sigma, IntroNeedsProduct)) end let refine = Tacmach.refine @@ -280,7 +257,6 @@ let clear_gen fail = function Proofview.Goal.enter begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in (** clear_hyps_in_evi does not require nf terms *) - let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -319,7 +295,7 @@ let move_hyp id dest = let ty = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let sign = named_context_val env in - let sign' = move_hyp_in_named_context sigma id dest sign in + let sign' = move_hyp_in_named_context env sigma id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty @@ -344,17 +320,18 @@ let rename_hyp repl = | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in (** Check that we do not mess variables *) let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then let hyp = Id.Set.choose (Id.Set.diff src vars) in - raise (RefinerError (NoSuchHyp hyp)) + raise (RefinerError (env, sigma, NoSuchHyp hyp)) in let mods = Id.Set.diff vars src in let () = @@ -442,9 +419,9 @@ let find_name mayrepl decl naming gl = match naming with (* Computing position of hypotheses for replacing *) (**************************************************************) -let get_next_hyp_position id = +let get_next_hyp_position env sigma id = let rec aux = function - | [] -> error_no_such_hypothesis id + | [] -> error_no_such_hypothesis env sigma id | decl :: right -> if Id.equal (NamedDecl.get_id decl) id then match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveFirst @@ -453,9 +430,9 @@ let get_next_hyp_position id = in aux -let get_previous_hyp_position id = +let get_previous_hyp_position env sigma id = let rec aux dest = function - | [] -> error_no_such_hypothesis id + | [] -> error_no_such_hypothesis env sigma id | decl :: right -> let hyp = NamedDecl.get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right @@ -483,7 +460,7 @@ let internal_cut_gen ?(check=true) dir replace id t = let sign = named_context_val env in let sign',t,concl,sigma = if replace then - let nexthyp = get_next_hyp_position id (named_context_of_val sign) in + let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sign',t,concl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in let sign' = insert_decl_in_named_context sigma (LocalAssum (id,t)) nexthyp sign' in sign',t,concl,sigma @@ -491,7 +468,7 @@ let internal_cut_gen ?(check=true) dir replace id t = (if check && mem_named_context_val id sign then user_err (str "Variable " ++ Id.print id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,concl,sigma) in - let nf_t = nf_betaiota sigma t in + let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun sigma -> @@ -834,7 +811,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm let e_change_in_hyp redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in + let hyp = Tacmach.New.pf_get_hyp id gl in let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (convert_hyp c) @@ -1000,7 +977,8 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let env = Tacmach.New.pf_env gl in + let concl = Proofview.Goal.concl gl in match EConstr.kind sigma concl with | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> let name = find_name false (LocalAssum (name,t)) name_flag gl in @@ -1009,7 +987,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> - begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) + begin if not force_flag then Proofview.tclZERO (RefinerError (env, sigma, IntroNeedsProduct)) (* Note: red_in_concl includes betaiotazeta and this was like *) (* this since at least V6.3 (a pity *) (* that intro do betaiotazeta only when reduction is needed; and *) @@ -1020,7 +998,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = (Tacticals.New.tclTHEN hnf_in_concl (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with - | RefinerError IntroNeedsProduct -> + | RefinerError (env, sigma, IntroNeedsProduct) -> Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end @@ -1059,7 +1037,7 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = (fun id -> aux (n+1) (id::ids)) end begin function (e, info) -> match e with - | RefinerError IntroNeedsProduct -> + | RefinerError (env, sigma, IntroNeedsProduct) -> tac ids | e -> Proofview.tclZERO ~info e end @@ -1070,8 +1048,9 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = let intro_replacing id = Proofview.Goal.enter begin fun gl -> - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let next_hyp = get_next_hyp_position id hyps in + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let hyps = Proofview.Goal.hyps gl in + let next_hyp = get_next_hyp_position env sigma id hyps in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; @@ -1090,8 +1069,9 @@ let intro_replacing id = let intros_possibly_replacing ids = let suboptimal = true in Proofview.Goal.enter begin fun gl -> - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let posl = List.map (fun id -> (id, get_next_hyp_position id hyps)) ids in + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let hyps = Proofview.Goal.hyps gl in + let posl = List.map (fun id -> (id, get_next_hyp_position env sigma id hyps)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (clear_for_replacing [id])) @@ -1104,8 +1084,9 @@ let intros_possibly_replacing ids = (* This version assumes that replacement is actually possible *) let intros_replacing ids = Proofview.Goal.enter begin fun gl -> - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let posl = List.map (fun id -> (id, get_next_hyp_position id hyps)) ids in + let hyps = Proofview.Goal.hyps gl in + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let posl = List.map (fun id -> (id, get_next_hyp_position env sigma id hyps)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) @@ -1166,7 +1147,7 @@ let intros_until_n = intros_until_n_gen true let tclCHECKVAR id = Proofview.Goal.enter begin fun gl -> - let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in + let _ = Tacmach.New.pf_get_hyp id gl in Proofview.tclUNIT () end @@ -1508,7 +1489,7 @@ let simplest_ecase c = general_case_analysis true None (c,NoBindings) exception IsNonrec -let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.BiFinite +let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations.BiFinite let find_ind_eliminator ind s gl = let gr = lookup_eliminator ind s in @@ -1744,7 +1725,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in + let thm_ty0 = nf_betaiota env sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta sigma thm_ty - nprod in @@ -1880,7 +1861,7 @@ let explain_unable_to_apply_lemma ?loc env sigma thm innerclause = str ".")) let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = - let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in + let thm = nf_betaiota env sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -1976,11 +1957,11 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) -(* let convert_leqkey = Profile.declare_profile "convert_leq";; *) -(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) +(* let convert_leqkey = CProfile.declare_profile "convert_leq";; *) +(* let convert_leq = CProfile.profile3 convert_leqkey convert_leq *) -(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) -(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) +(* let refine_no_checkkey = CProfile.declare_profile "refine_no_check";; *) +(* let refine_no_check = CProfile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = Refine.refine ~typecheck:false (fun h -> (h,c)) @@ -1989,7 +1970,7 @@ let exact_check c = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma, ct = Typing.type_of env sigma c in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) @@ -1998,7 +1979,7 @@ let exact_check c = let cast_no_check cast c = Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = Proofview.Goal.concl gl in exact_no_check (mkCast (c, cast, concl)) end @@ -2082,7 +2063,7 @@ let clear_body ids = let open Context.Named.Declaration in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let ctx = named_context env in let map = function @@ -2173,12 +2154,12 @@ let keep hyps = and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], this generalizes [hyps |- goal] into [hyps |- T] *) -let apply_type newcl args = +let apply_type ~typecheck newcl args = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine ~typecheck:false begin fun sigma -> - let newcl = nf_betaiota sigma newcl (* As in former Logic.refine *) in + Refine.refine ~typecheck begin fun sigma -> + let newcl = nf_betaiota env sigma newcl (* As in former Logic.refine *) in let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in (sigma, applist (ev, args)) @@ -2207,7 +2188,6 @@ let bring_hyps hyps = let revert hyps = Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) end @@ -2633,8 +2613,10 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars Proofview.Goal.enter begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) - else - get_previous_hyp_position id (Proofview.Goal.hyps (Proofview.Goal.assume gl)) in + else ( + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + get_previous_hyp_position env sigma id (Proofview.Goal.hyps gl) + ) in let naming,ipat_tac = prepare_intros_opt with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = @@ -2907,7 +2889,7 @@ let generalize_dep ?(with_let=false) c = let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST [ Proofview.Unsafe.tclEVARS evd; - apply_type cl'' (if Option.is_empty body then c::args else args); + apply_type ~typecheck:false cl'' (if Option.is_empty body then c::args else args); clear (List.rev tothin')] end @@ -2921,13 +2903,12 @@ let generalize_gen_let lconstr = Proofview.Goal.enter begin fun gl -> let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) - (apply_type newcl (List.map_filter map lconstr)) + (apply_type ~typecheck:false newcl (List.map_filter map lconstr)) end let new_generalize_gen_let lconstr = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in @@ -3077,7 +3058,7 @@ let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter begin fun gl -> (** We normalize the given hypothesis immediately. *) - let env = Proofview.Goal.env (Proofview.Goal.assume gl) in + let env = Proofview.Goal.env gl in let xval = match Environ.lookup_named x env with | LocalAssum _ -> user_err ~hdr:"unfold_body" (Id.print x ++ str" is not a defined hypothesis.") @@ -3288,7 +3269,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in + let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in let prods, indtyp = decompose_prod_assum sigma typ0 in @@ -4141,8 +4122,7 @@ let guess_elim isrec dep s hyp0 gl = let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let u = EInstance.kind (Tacmach.New.project gl) u in - if use_dependent_propositions_elimination () && dep = Some true - then + if dep then let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in (sigma, ind) @@ -4174,11 +4154,10 @@ let find_induction_type isrec elim hyp0 gl = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in - let _, (elimc,elimt),_ = - guess_elim isrec None sort hyp0 gl in - let scheme = compute_elim_sig sigma ~elimc elimt in - (* We drop the scheme waiting to know if it is dependent *) - scheme, ElimOver (isrec,hyp0) + let _, (elimc,elimt),_ = guess_elim isrec false sort hyp0 gl in + let scheme = compute_elim_sig sigma ~elimc elimt in + (* We drop the scheme waiting to know if it is dependent *) + scheme, ElimOver (isrec,hyp0) | Some e -> let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig sigma ~elimc elimt in @@ -4209,7 +4188,7 @@ let get_eliminator elim dep s gl = | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let evd, (elimc,elimt),_ as elims = guess_elim isrec (Some dep) s id gl in + let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) (List.rev s.branches) @@ -4288,7 +4267,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let deps_cstr = List.fold_left (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in - let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in + let (sigma, isrec, elim, indsign) = get_eliminator elim dep s gl in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in Array.map (fun (_,l) -> List.map f l) indsign in @@ -4298,7 +4277,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) - if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; + if deps = [] then Proofview.tclUNIT () else apply_type ~typecheck:false tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; Tacticals.New.tclMAP expand_hyp toclear; @@ -4313,7 +4292,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = Proofview.Goal.enter begin fun gl -> - let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in + let elim_info = find_induction_type isrec elim hyp0 gl in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> induction_tac with_evars [] [hyp0] elim)) @@ -4448,8 +4427,11 @@ let check_enough_applied env sigma elim = check_expected_type env sigma elimc elimt let guard_no_unifiable = Proofview.guard_no_unifiable >>= function -| None -> Proofview.tclUNIT () -| Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l)) + | None -> Proofview.tclUNIT () + | Some l -> + Proofview.tclENV >>= function env -> + Proofview.tclEVARMAP >>= function sigma -> + Proofview.tclZERO (RefinerError (env, sigma, UnresolvedBindings l)) let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = @@ -4648,7 +4630,7 @@ let induction_destruct isrec with_evars (lc,elim) = (Tacticals.New.tclMAP (fun (a,b,cl) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a end) l) @@ -4673,7 +4655,7 @@ let induction_destruct isrec with_evars (lc,elim) = end let induction ev clr c l e = - induction_gen clr true ev e + induction_gen clr true ev e ((Evd.empty,(c,NoBindings)),(None,l)) None let destruct ev clr c l e = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 83fc655f1..74415f8d0 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -30,7 +30,7 @@ open Ltac_pretype (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> 'a Proofview.Goal.t -> bool +val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) @@ -76,7 +76,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> 'a Proofview.Goal.t -> int + bool -> quantified_hypothesis -> Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic @@ -185,7 +185,7 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) -val apply_type : constr -> constr list -> unit Proofview.tactic +val apply_type : typecheck:bool -> constr -> constr list -> unit Proofview.tactic val bring_hyps : named_context -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index 6865dcc76..16a56f440 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -40,6 +40,7 @@ coqtopload := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source coqtopcompile := $(coqtop) -compile coqdep := $(BIN)coqdep -coqlib $(LIB) +VERBOSE?= SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) @@ -174,10 +175,20 @@ summary.log: # if not on travis we can get the log files (they're just there for a # local build, and downloadable on GitLab) +PRINT_LOGS?= +TRAVIS?= # special because we want to print travis_fold directives +ifdef APPVEYOR +PRINT_LOGS:=APPVEYOR +else +ifdef CIRCLECI +PRINT_LOGS:=CIRCLECI +endif #CIRCLECI +endif #APPVEYOR + report: summary.log $(HIDE)bash save-logs.sh $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi - $(HIDE)if [ -n "${APPVEYOR}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi + $(HIDE)if [ -n "${PRINT_LOGS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi ####################################################################### @@ -312,6 +323,13 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) rm $$tmpoutput; \ } > "$@" +# the expected output for the MExtraction test is +# /plugins/micromega/micromega.ml except with additional newline +output/MExtraction.out: ../plugins/micromega/micromega.ml + $(SHOW) GEN $@ + $(HIDE) cp $< $@ + $(HIDE) echo >> $@ + $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ diff --git a/test-suite/README.md b/test-suite/README.md new file mode 100644 index 000000000..1d1195646 --- /dev/null +++ b/test-suite/README.md @@ -0,0 +1,75 @@ +# Coq Test Suite + +The test suite can be run from the Coq root directory by `make test-suite`. +This does a clean step first, so if you've already run it, then change something, +you'll have to do a lot of work again. + +If you run `make` from the `test-suite` directory, there is no clean step. +You can also run `make aaa/bbb/ccc.v.log` to build the log for one test, +or `make ddd` where `ddd` is on of the sub-directories of `test-suite` +to just build the logs for that directory. +In these cases, a summary is not printed, but can be generated by `make summary`. + +`make -B` can be used to rerun tests ( -B meaning always remake). + +From the `test-suite` directory, `make report` (included in `make +all`) prints a summary of which tests failed using the produced log +files (this still works when only some tests are built as described +above). Setting the `PRINT_LOGS` variable will make it print the logs +of the failing tests. + +For instance, running the following in the `test-suite` directory: + +```bash +$ echo Fail. > success/fail.v # make some failing test + +$ make +TEST prerequisite/make_local.v +... +TEST success/fail.v +... +BUILDING SUMMARY FILE +FAILURES + success/fail.v...Error! (should be accepted) +Makefile:189: recipe for target 'all failed +make: *** [report] Error 1 + +$ make report PRINT_LOGS=1 +BUILDING SUMMARY FILE +logs/success/fail.v.log +==========> TESTING success/fail.v <========== +Welcome to Coq (version information) +Skipping rcfile loading. +File "/path/to/success/fail.v", line 1, characters 4-5: +Error: +Syntax error: [vernac:Vernac.vernac_control] expected after 'Fail' (in [vernac:Vernac.vernac_control]). + +0m0.000000s 0m0.000000s +0m0.040000s 0m0.000000s +==========> FAILURE <========== + success/fail.v...Error! (should be accepted) + +FAILURES + success/fail.v...Error! (should be accepted) +Makefile:189: recipe for target 'report' failed +make: *** [report] Error 1 + +$ echo 'Comments "foo".' > success/fail.v + +$ make +TEST success/fail.v +BUILDING SUMMARY FILE +NO FAILURES +``` + +See [`test-suite/Makefile`](/test-suite/Makefile) for more information. + +## Adding a test + +Regression tests for closed bugs should be added to `test-suite/bugs/closed`, as `1234.v` where `1234` is the bug number. +Files in this directory are tested for successful compilation. +When you fix a bug, you should usually add a regression test here as well. + +The error "(bug seems to be opened, please check)" when running `make test-suite` means that a test in `bugs/closed` failed to compile. + +There are also output tests in `test-suite/output` which consist of a `.v` file and a `.out` file with the expected output. diff --git a/test-suite/bugs/closed/3125.v b/test-suite/bugs/closed/3125.v new file mode 100644 index 000000000..797146174 --- /dev/null +++ b/test-suite/bugs/closed/3125.v @@ -0,0 +1,27 @@ +(* Not considering singleton template-polymorphic inductive types as + propositions for injection/inversion *) + +(* This is also #4560 and #6273 *) + +Inductive foo := foo_1. + +Goal forall (a b : foo), Some a = Some b -> a = b. +Proof. + intros a b H. + inversion H. + reflexivity. +Qed. + +(* Check that Prop is not concerned *) + +Inductive bar : Prop := bar_1. + +Goal + forall (a b : bar), + Some a = Some b -> + a = b. +Proof. + intros a b H. + inversion H. + Fail reflexivity. +Abort. diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index da12b6868..5210b2703 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -65,6 +65,7 @@ Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A = B. Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V. +Existing Instance is0trunc_V. Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}. Axiom bisimulation_refl : forall (v : V), bisimulation v v. Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v. diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v index a96a13700..c069b2d9d 100644 --- a/test-suite/bugs/closed/4390.v +++ b/test-suite/bugs/closed/4390.v @@ -8,16 +8,16 @@ Universe i. End foo. End M. -Check Type@{i}. +Check Type@{M.i}. (* Succeeds *) Fail Check Type@{j}. (* Error: Undeclared universe: j *) -Definition foo@{j} : Type@{i} := Type@{j}. +Definition foo@{j} : Type@{M.i} := Type@{j}. (* ok *) End A. - +Import A. Import M. Set Universe Polymorphism. Fail Universes j. Monomorphic Universe j. diff --git a/test-suite/bugs/closed/5286.v b/test-suite/bugs/closed/5286.v new file mode 100644 index 000000000..98d4e5c96 --- /dev/null +++ b/test-suite/bugs/closed/5286.v @@ -0,0 +1,9 @@ +Set Primitive Projections. + +CoInductive R := mkR { p : unit }. + +CoFixpoint foo := mkR tt. + +Check (eq_refl tt : p foo = tt). +Check (eq_refl tt <: p foo = tt). +Check (eq_refl tt <<: p foo = tt). diff --git a/test-suite/bugs/closed/5368.v b/test-suite/bugs/closed/5368.v new file mode 100644 index 000000000..410fe1707 --- /dev/null +++ b/test-suite/bugs/closed/5368.v @@ -0,0 +1,6 @@ +Set Universe Polymorphism. + +Record cantype := {T:Type; op:T -> unit}. +Canonical Structure test (P:Type) := {| T := P -> Type; op := fun _ => tt|}. + +Check (op _ ((fun (_:unit) => Set):_)). diff --git a/test-suite/bugs/closed/5532.v b/test-suite/bugs/closed/5532.v new file mode 100644 index 000000000..ee5446e54 --- /dev/null +++ b/test-suite/bugs/closed/5532.v @@ -0,0 +1,15 @@ +(* A wish granted by the new support for patterns in notations *) + +Local Notation mkmatch0 e p + := match e with + | p => true + | _ => false + end. +Local Notation "'mkmatch' [[ e ]] [[ p ]]" + := match e with + | p => true + | _ => false + end + (at level 0, p pattern). +Check mkmatch0 _ ((0, 0)%core). +Check mkmatch [[ _ ]] [[ ((0, 0)%core) ]]. diff --git a/test-suite/bugs/closed/5726.v b/test-suite/bugs/closed/5726.v new file mode 100644 index 000000000..53ef47357 --- /dev/null +++ b/test-suite/bugs/closed/5726.v @@ -0,0 +1,34 @@ +Set Universe Polymorphism. +Set Printing Universes. + +Module GlobalReference. + + Definition type' := Type. + Notation type := type'. + Check type@{Set}. + +End GlobalReference. + +Module TypeLiteral. + + Notation type := Type. + Check type@{Set}. + Check type@{Prop}. + +End TypeLiteral. + +Module ExplicitSort. + Monomorphic Universe u. + Notation foo := Type@{u}. + Fail Check foo@{Set}. + Fail Check foo@{u}. + + Notation bar := Type. + Check bar@{u}. +End ExplicitSort. + +Module PropNotationUnsupported. + Notation foo := Prop. + Fail Check foo@{Set}. + Fail Check foo@{Type}. +End PropNotationUnsupported. diff --git a/test-suite/bugs/closed/6297.v b/test-suite/bugs/closed/6297.v new file mode 100644 index 000000000..a28607058 --- /dev/null +++ b/test-suite/bugs/closed/6297.v @@ -0,0 +1,8 @@ +Set Printing Universes. + +(* Error: Anomaly "Uncaught exception "Anomaly: Incorrect universe Set + declared for inductive type, inferred level is max(Prop, Set+1)."." + Please report at http://coq.inria.fr/bugs/. *) +Fail Record LTS: Set := + lts { St: Set; + init: St }. diff --git a/test-suite/bugs/closed/6323.v b/test-suite/bugs/closed/6323.v new file mode 100644 index 000000000..fdc33befc --- /dev/null +++ b/test-suite/bugs/closed/6323.v @@ -0,0 +1,9 @@ +Goal True. + simple refine (let X : Type := _ in _); + [ abstract exact Set using Set' + | let X' := (eval cbv delta [X] in X) in + clear X; + simple refine (let id' : { x : X' | True } -> X' := _ in _); + [ abstract refine (@proj1_sig _ _) | ] + ]. +Abort. diff --git a/test-suite/bugs/closed/6378.v b/test-suite/bugs/closed/6378.v new file mode 100644 index 000000000..68ae7961d --- /dev/null +++ b/test-suite/bugs/closed/6378.v @@ -0,0 +1,18 @@ +Require Import Coq.ZArith.ZArith. +Ltac profile_constr tac := + let dummy := match goal with _ => reset ltac profile; start ltac profiling end in + let ret := match goal with _ => tac () end in + let dummy := match goal with _ => stop ltac profiling; show ltac profile end in + pose 1. + +Ltac slow _ := eval vm_compute in (Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl). + +Goal True. + start ltac profiling. + reset ltac profile. + reset ltac profile. + stop ltac profiling. + time profile_constr slow. + show ltac profile cutoff 0. + show ltac profile "slow". +Abort. diff --git a/test-suite/bugs/closed/6490.v b/test-suite/bugs/closed/6490.v new file mode 100644 index 000000000..dcf9ff29e --- /dev/null +++ b/test-suite/bugs/closed/6490.v @@ -0,0 +1,4 @@ +Inductive Foo (A' := I) (B : Type) := foo : Foo B. + +Goal Foo True. dtauto. Qed. +Goal Foo True. firstorder. Qed. diff --git a/test-suite/bugs/closed/6529.v b/test-suite/bugs/closed/6529.v new file mode 100644 index 000000000..8d9081999 --- /dev/null +++ b/test-suite/bugs/closed/6529.v @@ -0,0 +1,16 @@ +Require Import Vector Program. + +Program Definition append_nil_def := + forall A n (ls: t A n), append ls (nil A) = ls. (* Works *) + +Lemma append_nil : append_nil_def. (* Works *) +Proof. +Admitted. + +Program Lemma append_nil' : + forall A n (ls: t A n), append ls (nil A) = ls. +Abort. + +Fail Program Lemma append_nil'' : + forall A B n (ls: t A n), append ls (nil A) = ls. +(* Error: Anomaly "Evar ?X25 was not declared." Please report at http://coq.inria.fr/bugs/. *) diff --git a/test-suite/bugs/closed/6534.v b/test-suite/bugs/closed/6534.v new file mode 100644 index 000000000..f5013994c --- /dev/null +++ b/test-suite/bugs/closed/6534.v @@ -0,0 +1,7 @@ +Goal forall x : nat, x = x. +Proof. +intros x. +refine ((fun x x => _ tt) tt tt). +let t := match goal with [ |- ?P ] => P end in +let _ := type of t in +idtac. diff --git a/test-suite/bugs/closed/6617.v b/test-suite/bugs/closed/6617.v new file mode 100644 index 000000000..9cabd62d4 --- /dev/null +++ b/test-suite/bugs/closed/6617.v @@ -0,0 +1,34 @@ +Definition MR {T M : Type} := +fun (R : M -> M -> Prop) (m : T -> M) (x y : T) => R (m x) (m y). + +Set Primitive Projections. + +Record sigma {A : Type} {B : A -> Type} : Type := sigmaI + { pr1 : A; pr2 : B pr1 }. + +Axiom F : forall {A : Type} {R : A -> A -> Prop}, + (forall x, (forall y, R y x -> unit) -> unit) -> forall (x : A), unit. + +Definition foo (A : Type) (l : list A) := + let y := {| pr1 := A; pr2 := l |} in + let bar := MR lt (fun p : sigma => + (fix Ffix (x : list (pr1 p)) : nat := + match x with + | nil => 0 + | cons _ x1 => S (Ffix x1) + end) (pr2 p)) in +fun (_ : bar y y) => +F (fun (r : sigma) + (X : forall q : sigma, bar q r -> unit) => tt). + +Definition fooT (A : Type) (l : list A) : Type := + ltac:(let ty := type of (foo A l) in exact ty). +Parameter P : forall A l, fooT A l -> Prop. + +Goal forall A l, P A l (foo A l). +Proof. + intros; unfold foo. + Fail match goal with + | [ |- context [False]] => idtac + end. +Admitted. diff --git a/test-suite/bugs/closed/6677.v b/test-suite/bugs/closed/6677.v new file mode 100644 index 000000000..99e47bb87 --- /dev/null +++ b/test-suite/bugs/closed/6677.v @@ -0,0 +1,5 @@ +Set Universe Polymorphism. + +Definition T@{i} := Type@{i}. +Fail Definition U@{i} := (T@{i} <: Type@{i}). +Fail Definition eqU@{i j} : @eq T@{j} U@{i} T@{i} := eq_refl. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v index b4c745375..d02a5f120 100644 --- a/test-suite/bugs/closed/HoTT_coq_064.v +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -178,6 +178,7 @@ Definition IsColimit `{Funext} C D (F : Functor D C) Generalizable All Variables. Axiom fs : Funext. +Existing Instance fs. Section bar. diff --git a/test-suite/bugs/closed/gh6384.v b/test-suite/bugs/closed/gh6384.v new file mode 100644 index 000000000..cec84642f --- /dev/null +++ b/test-suite/bugs/closed/gh6384.v @@ -0,0 +1,5 @@ +Theorem test (A:Prop) : A \/ A -> A. + Fail intro H; destruct H as H. + (* Error: Disjunctive/conjunctive introduction pattern expected. *) + Fail intros H; destruct H as H. +Abort. diff --git a/test-suite/bugs/closed/gh6385.v b/test-suite/bugs/closed/gh6385.v new file mode 100644 index 000000000..3bbb664f4 --- /dev/null +++ b/test-suite/bugs/closed/gh6385.v @@ -0,0 +1,5 @@ +Theorem test (A:Prop) : A \/ A -> A. + Fail let H := idtac in intros H; destruct H as H'. + (* Disjunctive/conjunctive introduction pattern expected. *) + Fail let H' := idtac in intros H; destruct H as H'. +Abort. diff --git a/test-suite/bugs/opened/6393.v b/test-suite/bugs/opened/6393.v new file mode 100644 index 000000000..8d5d09233 --- /dev/null +++ b/test-suite/bugs/opened/6393.v @@ -0,0 +1,11 @@ +(* These always worked. *) +Goal prod True True. firstorder. Qed. +Goal True -> @sigT True (fun _ => True). firstorder. Qed. +Goal prod True True. dtauto. Qed. +Goal prod True True. tauto. Qed. + +(* These should work. *) +Goal @sigT True (fun _ => True). dtauto. Qed. +(* These should work, but don't *) +(* Goal @sigT True (fun _ => True). firstorder. Qed. *) +(* Goal @sigT True (fun _ => True). tauto. Qed. *) diff --git a/test-suite/coq-makefile/emptyprefix/_CoqProject b/test-suite/coq-makefile/emptyprefix/_CoqProject new file mode 100644 index 000000000..5678a8edb --- /dev/null +++ b/test-suite/coq-makefile/emptyprefix/_CoqProject @@ -0,0 +1,11 @@ +-R theories "" +-R src "" +-I src +-arg "-w default" + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/emptyprefix/_CoqProject.sub b/test-suite/coq-makefile/emptyprefix/_CoqProject.sub new file mode 100644 index 000000000..90ac541e0 --- /dev/null +++ b/test-suite/coq-makefile/emptyprefix/_CoqProject.sub @@ -0,0 +1,3 @@ +-R ../theories "" +-I ../src +testsub.v diff --git a/test-suite/coq-makefile/emptyprefix/run.sh b/test-suite/coq-makefile/emptyprefix/run.sh new file mode 100755 index 000000000..a10e63b42 --- /dev/null +++ b/test-suite/coq-makefile/emptyprefix/run.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +set -e + +. ../template/init.sh + +mv theories/sub theories2 + +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +make + +cp ../_CoqProject.sub theories2/_CoqProject +cd theories2 +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +make diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh deleted file mode 100755 index e48f704a2..000000000 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env bash - -set -e - -cat > _CoqProject <<EOT --I src/ - -./src/test_plugin.mllib -./src/test.ml4 -./src/test.mli -EOT - -mkdir -p src - -cat > src/test_plugin.mllib <<EOT -Test -EOT - -touch src/test.mli - -cat > src/test.ml4 <<EOT -DECLARE PLUGIN "test" - -let _ = Pre_env.empty_env -EOT - -${COQBIN}coq_makefile -f _CoqProject -o Makefile -cat Makefile.conf - -if make VERBOSE=1; then - # make command should have failed (but didn't) - exit 1 -else - # make command should have failed (and it indeed did) - exit 0 -fi diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh deleted file mode 100755 index 4a8f58655..000000000 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/env bash - -set -e - -cat > _CoqProject <<EOT --bypass-API --I src/ - -./src/test_plugin.mllib -./src/test.ml4 -./src/test.mli -EOT - -mkdir -p src - -cat > src/test_plugin.mllib <<EOT -Test -EOT - -touch src/test.mli - -cat > src/test.ml4 <<EOT -DECLARE PLUGIN "test" - -let _ = Pre_env.empty_env -EOT - -${COQBIN}coq_makefile -f _CoqProject -o Makefile -cat Makefile.conf - -make VERBOSE=1 diff --git a/test-suite/coq-makefile/quick2vo/_CoqProject b/test-suite/coq-makefile/quick2vo/_CoqProject new file mode 100644 index 000000000..69f47302e --- /dev/null +++ b/test-suite/coq-makefile/quick2vo/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/quick2vo/run.sh b/test-suite/coq-makefile/quick2vo/run.sh new file mode 100755 index 000000000..9e681223b --- /dev/null +++ b/test-suite/coq-makefile/quick2vo/run.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash +a=`uname` + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +# vio2vo is broken on Windows (#6720) +if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then + make quick2vo J=2 + test -f theories/test.vo + make validate +fi diff --git a/test-suite/coq-makefile/template/src/test.ml4 b/test-suite/coq-makefile/template/src/test.ml4 index e7d0bfe1f..72765abe0 100644 --- a/test-suite/coq-makefile/template/src/test.ml4 +++ b/test-suite/coq-makefile/template/src/test.ml4 @@ -1,4 +1,3 @@ -open API open Ltac_plugin DECLARE PLUGIN "test_plugin" let () = Mltop.add_known_plugin (fun () -> ()) "test_plugin";; diff --git a/test-suite/coq-makefile/template/src/test_aux.ml b/test-suite/coq-makefile/template/src/test_aux.ml index e134abd84..a01d0865a 100644 --- a/test-suite/coq-makefile/template/src/test_aux.ml +++ b/test-suite/coq-makefile/template/src/test_aux.ml @@ -1 +1 @@ -let tac = API.Proofview.tclUNIT () +let tac = Proofview.tclUNIT () diff --git a/test-suite/coq-makefile/template/src/test_aux.mli b/test-suite/coq-makefile/template/src/test_aux.mli index 2e7ad1529..10020f27d 100644 --- a/test-suite/coq-makefile/template/src/test_aux.mli +++ b/test-suite/coq-makefile/template/src/test_aux.mli @@ -1 +1 @@ -val tac : unit API.Proofview.tactic +val tac : unit Proofview.tactic diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired index 729de2f36..7900c034d 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -1,7 +1,6 @@ Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' -COQDEP Fast.v -COQDEP Slow.v +COQDEP VFILES Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' Makefile:69: warning: undefined variable '*' diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired index b25bc3683..7ab0bc75d 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -1,7 +1,6 @@ Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' -COQDEP Fast.v -COQDEP Slow.v +COQDEP VFILES Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' Makefile:69: warning: undefined variable '*' diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 898af5590..2439d3f37 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -31,16 +31,16 @@ coq_makefile -f _CoqProject -o Makefile make cleanall make make-pretty-timed-after TGTS="all" -j1 || exit $? rm -f time-of-build-before.log -make print-pretty-timed-diff TIME_OF_BUILD_BEFORE_FILE=../before/time-of-build-before.log +make print-pretty-timed-diff TIMING_SORT_BY=diff TIME_OF_BUILD_BEFORE_FILE=../before/time-of-build-before.log cp ../before/time-of-build-before.log ./ -make print-pretty-timed-diff || exit $? +make print-pretty-timed-diff TIMING_SORT_BY=diff || exit $? INFINITY="∞" INFINITY_REPLACEMENT="+.%" # assume that if the before time is zero, we expected the time to increase for ext in "" .desired; do for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do - cat ${file}${ext} | grep -v 'warning: undefined variable' | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s'/[0-9]//g' | sed s'/ *$//g' | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/^-*$/------/g' | sed s'/ */ /g' | sed s'/\(Total.*\)-\(.*\)-/\1+\2+/g' > ${file}${ext}.processed + cat ${file}${ext} | grep -v 'warning: undefined variable' | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s'/[0-9]//g' | sed s'/ *$//g' | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/^-*$/------/g' | sed s'/ */ /g' | sed s'/\(Total.*\)-\(.*\)-/\1+\2+/g' > ${file}${ext}.processed done done for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do @@ -74,7 +74,7 @@ echo for ext in "" .desired; do for file in A.v.timing.diff; do - cat ${file}${ext} | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/[0-9]*\.[0-9]*//g' | sed s'/0//g' | sed s'/ */ /g' | sed s'/+/-/g' | sort > ${file}${ext}.processed + cat ${file}${ext} | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/[0-9]*\.[0-9]*//g' | sed s'/0//g' | sed s'/ */ /g' | sed s'/ *$//g' | sed s'/+/-/g' | sort > ${file}${ext}.processed done done for file in A.v.timing.diff; do diff --git a/test-suite/coq-makefile/vio2vo/_CoqProject b/test-suite/coq-makefile/vio2vo/_CoqProject new file mode 100644 index 000000000..69f47302e --- /dev/null +++ b/test-suite/coq-makefile/vio2vo/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/vio2vo/run.sh b/test-suite/coq-makefile/vio2vo/run.sh new file mode 100755 index 000000000..85656da41 --- /dev/null +++ b/test-suite/coq-makefile/vio2vo/run.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash +a=`uname` + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make quick +# vio2vo is broken on Windows (#6720) +if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then + make vio2vo J=2 + test -f theories/test.vo + make validate +fi diff --git a/test-suite/coqchk/include.v b/test-suite/coqchk/include.v new file mode 100644 index 000000000..6232c1b80 --- /dev/null +++ b/test-suite/coqchk/include.v @@ -0,0 +1,11 @@ +(* See https://github.com/coq/coq/issues/5747 *) +Module Type S. +End S. + +Module N. +Inductive I := . +End N. + +Module M : S. + Include N. +End M. diff --git a/test-suite/coqchk/primproj2.v b/test-suite/coqchk/primproj2.v new file mode 100644 index 000000000..f73c627ee --- /dev/null +++ b/test-suite/coqchk/primproj2.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +Record Pack (A : Type) := pack { unpack : A }. + +Definition p : Pack bool. +Proof. +refine (pack _ true). +Qed. + +Definition boom : unpack bool p = let u := unpack _ in u p := eq_refl. diff --git a/test-suite/modules/SeveralWith.v b/test-suite/modules/SeveralWith.v new file mode 100644 index 000000000..bbf72a764 --- /dev/null +++ b/test-suite/modules/SeveralWith.v @@ -0,0 +1,12 @@ +Module Type S. +Parameter A : Type. +End S. + +Module Type ES. +Parameter A : Type. +Parameter eq : A -> A -> Type. +End ES. + +Module Make + (AX : S) + (X : ES with Definition A := AX.A with Definition eq := @eq AX.A). diff --git a/test-suite/modules/cumpoly.v b/test-suite/modules/cumpoly.v new file mode 100644 index 000000000..654b86cb4 --- /dev/null +++ b/test-suite/modules/cumpoly.v @@ -0,0 +1,19 @@ +Set Universe Polymorphism. + +(** Check that variance subtyping is respected. The signature T is asking for + invariance, while M provide an irrelevant implementation, which is deemed + legit. + + There is currently no way to go the other way around, so it's not possible + to generate a counter-example that should fail with the wrong subtyping. +*) + +Module Type T. +Parameter t@{i|Set <= i} : Type@{i}. +Cumulative Inductive I@{i|Set <= i} : Type@{i} := C : t@{i} -> I. +End T. + +Module M : T. +Definition t@{i|Set <= i} : Type@{i} := nat. +Cumulative Inductive I@{i|Set <= i} : Type@{i} := C : t@{i} -> I. +End M. diff --git a/test-suite/output-modulo-time/ltacprof.out b/test-suite/output-modulo-time/ltacprof.out index cc04c2c9b..5553e1b38 100644 --- a/test-suite/output-modulo-time/ltacprof.out +++ b/test-suite/output-modulo-time/ltacprof.out @@ -1,12 +1,15 @@ -total time: 1.528s +total time: 1.032s - tactic local total calls max + tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep' -------------------------------- 100.0% 100.0% 1 1.528s +─sleep' -------------------------------- 100.0% 100.0% 1 1.032s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s ─constructor --------------------------- 0.0% 0.0% 1 0.000s - tactic local total calls max + tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep' -------------------------------- 100.0% 100.0% 1 1.528s +─sleep' -------------------------------- 100.0% 100.0% 1 1.032s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s +â””sleep' -------------------------------- 0.0% 0.0% 0 0.000s ─constructor --------------------------- 0.0% 0.0% 1 0.000s diff --git a/test-suite/output-modulo-time/ltacprof_abstract.out b/test-suite/output-modulo-time/ltacprof_abstract.out new file mode 100644 index 000000000..fef4fa248 --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_abstract.out @@ -0,0 +1,17 @@ +total time: 0.922s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─abstract (sleep; constructor) --------- 0.0% 100.0% 1 0.922s +─sleep' -------------------------------- 100.0% 100.0% 1 0.922s +─constructor --------------------------- 0.0% 0.0% 1 0.000s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─abstract (sleep; constructor) --------- 0.0% 100.0% 1 0.922s + ├─sleep' ------------------------------ 100.0% 100.0% 1 0.922s + ├─constructor ------------------------- 0.0% 0.0% 1 0.000s + └─sleep ------------------------------- 0.0% 0.0% 0 0.000s + â””sleep' ------------------------------ 0.0% 0.0% 0 0.000s + diff --git a/test-suite/output-modulo-time/ltacprof_abstract.v b/test-suite/output-modulo-time/ltacprof_abstract.v new file mode 100644 index 000000000..10a76309e --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_abstract.v @@ -0,0 +1,8 @@ +(* -*- coq-prog-args: ("-profile-ltac-cutoff" "0.0") -*- *) +Ltac sleep' := do 100 (do 100 (do 100 idtac)). +Ltac sleep := sleep'. + +Theorem x : True. +Proof. + idtac. idtac. abstract (sleep; constructor). +Defined. diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.out b/test-suite/output-modulo-time/ltacprof_cutoff.out index 0cd5777cc..d91a38bb5 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.out +++ b/test-suite/output-modulo-time/ltacprof_cutoff.out @@ -1,31 +1,37 @@ -total time: 1.584s +total time: 1.632s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -─sleep --------------------------------- 100.0% 100.0% 3 0.572s -─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─sleep --------------------------------- 100.0% 100.0% 3 0.584s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.632s +─foo1 ---------------------------------- 0.0% 64.2% 1 1.048s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -â””foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.632s +â””foo1 ---------------------------------- 0.0% 64.2% 1 1.048s -total time: 1.584s +total time: 0.520s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 0.520s +─sleep --------------------------------- 99.2% 99.2% 52 0.016s +─foo1 ---------------------------------- 0.0% 97.7% 1 0.508s +─foo0 ---------------------------------- 0.8% 96.2% 1 0.500s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 0.520s +â””foo1 ---------------------------------- 0.0% 97.7% 1 0.508s +â””foo0 ---------------------------------- 0.8% 96.2% 1 0.500s +â””sleep --------------------------------- 95.4% 95.4% 50 0.016s + +total time: 0.000s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep --------------------------------- 100.0% 100.0% 3 0.572s -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s -─foo0 ---------------------------------- 0.0% 31.3% 1 0.496s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s - ├─foo1 -------------------------------- 0.0% 63.9% 1 1.012s - │ ├─sleep ----------------------------- 32.6% 32.6% 1 0.516s - │ └─foo0 ------------------------------ 0.0% 31.3% 1 0.496s - │ â””sleep ----------------------------- 31.3% 31.3% 1 0.496s - └─sleep ------------------------------- 36.1% 36.1% 1 0.572s diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v index 3dad6271a..ae5d51bae 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -1,12 +1,28 @@ (* -*- coq-prog-args: ("-profile-ltac") -*- *) Require Coq.ZArith.BinInt. -Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). +Module WithIdTac. + Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). -Ltac foo0 := idtac; sleep. -Ltac foo1 := sleep; foo0. -Ltac foo2 := sleep; foo1. -Goal True. - foo2. - Show Ltac Profile CutOff 47. - constructor. -Qed. + Ltac foo0 := idtac; sleep. + Ltac foo1 := sleep; foo0. + Ltac foo2 := sleep; foo1. + Goal True. + foo2. + Show Ltac Profile CutOff 47. + constructor. + Qed. +End WithIdTac. + +Module TestEval. + Ltac sleep := let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac. + + Ltac foo0 := idtac; do 50 (idtac; sleep). + Ltac foo1 := sleep; foo0. + Ltac foo2 := sleep; foo1. + Goal True. + Reset Ltac Profile. + foo2. + Show Ltac Profile CutOff 47. + constructor. + Qed. +End TestEval. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 97fa8e254..419dcadb4 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -95,8 +95,7 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl x : nat n, n0 := match x + 0 with - | 0 => 0 - | S _ => 0 + | 0 | S _ => 0 end : nat e, e0 := match x + 0 as y return (y = y) with @@ -104,8 +103,7 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl | S n => eq_refl end : x + 0 = x + 0 n1, n2 := match x with - | 0 => 0 - | S _ => 0 + | 0 | S _ => 0 end : nat e1, e2 := match x return (x = x) with | 0 => eq_refl @@ -126,3 +124,48 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl end : p = p /\ p = p ============================ eq_refl = eq_refl +fun x : comparison => match x with + | Eq => 1 + | _ => 0 + end + : comparison -> nat +fun x : comparison => match x with + | Eq => 1 + | Lt => 0 + | Gt => 0 + end + : comparison -> nat +fun x : comparison => match x with + | Eq => 1 + | Lt | Gt => 0 + end + : comparison -> nat +fun x : comparison => +match x return nat with +| Eq => S O +| Lt => O +| Gt => O +end + : forall _ : comparison, nat +fun x : K => match x with + | a3 | a4 => 3 + | _ => 2 + end + : K -> nat +fun x : K => match x with + | a1 | a2 => 4 + | a3 => 3 + | _ => 2 + end + : K -> nat +fun x : K => match x with + | a1 | a2 => 4 + | a4 => 3 + | _ => 2 + end + : K -> nat +fun x : K => match x with + | a1 | a3 | a4 => 3 + | _ => 2 + end + : K -> nat diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 17fee3303..caf3b2870 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -1,5 +1,7 @@ (* Cases with let-in in constructors types *) +Unset Printing Allow Match Default Clause. + Inductive t : Set := k : let x := t in x -> x. @@ -184,3 +186,33 @@ let p := fresh "p" in |- eq_refl ?p = _ => pose (match eq_refl p in _ = z return p=p /\ z=z with eq_refl => conj eq_refl eq_refl end) end. Show. + +Set Printing Allow Match Default Clause. + +(***************************************************) +(* Testing strategy for factorizing cases branches *) + +(* Factorization + default clause *) +Check fun x => match x with Eq => 1 | _ => 0 end. + +(* No factorization *) +Unset Printing Factorizable Match Patterns. +Check fun x => match x with Eq => 1 | _ => 0 end. +Set Printing Factorizable Match Patterns. + +(* Factorization but no default clause *) +Unset Printing Allow Match Default Clause. +Check fun x => match x with Eq => 1 | _ => 0 end. +Set Printing Allow Match Default Clause. + +(* No factorization in printing all mode *) +Set Printing All. +Check fun x => match x with Eq => 1 | _ => 0 end. +Unset Printing All. + +(* Several clauses *) +Inductive K := a1|a2|a3|a4|a5|a6. +Check fun x => match x with a3 | a4 => 3 | _ => 2 end. +Check fun x => match x with a3 => 3 | a2 | a1 => 4 | _ => 2 end. +Check fun x => match x with a4 => 3 | a2 | a1 => 4 | _ => 2 end. +Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. diff --git a/test-suite/output/ErrorInCanonicalStructures.out b/test-suite/output/ErrorInCanonicalStructures.out new file mode 100644 index 000000000..73da4f44f --- /dev/null +++ b/test-suite/output/ErrorInCanonicalStructures.out @@ -0,0 +1,5 @@ +File "stdin", line 3, characters 0-24: +Error: +Could not declare a canonical structure Foo. +Expected an instance of a record or structure. + diff --git a/test-suite/output/ErrorInCanonicalStructures.v b/test-suite/output/ErrorInCanonicalStructures.v new file mode 100644 index 000000000..49597df6f --- /dev/null +++ b/test-suite/output/ErrorInCanonicalStructures.v @@ -0,0 +1,3 @@ +Record Foo := MkFoo { field1 : nat; field2 : nat -> nat }. + +Canonical Structure Foo. diff --git a/test-suite/output/ErrorInCanonicalStructures2.out b/test-suite/output/ErrorInCanonicalStructures2.out new file mode 100644 index 000000000..63a2871b8 --- /dev/null +++ b/test-suite/output/ErrorInCanonicalStructures2.out @@ -0,0 +1,5 @@ +File "stdin", line 3, characters 0-24: +Error: +Could not declare a canonical structure bar. +Expected an instance of a record or structure. + diff --git a/test-suite/output/ErrorInCanonicalStructures2.v b/test-suite/output/ErrorInCanonicalStructures2.v new file mode 100644 index 000000000..10ee177aa --- /dev/null +++ b/test-suite/output/ErrorInCanonicalStructures2.v @@ -0,0 +1,3 @@ +Definition bar := 99. + +Canonical Structure bar. diff --git a/test-suite/output/Extraction_infix.out b/test-suite/output/Extraction_infix.out new file mode 100644 index 000000000..29d50775a --- /dev/null +++ b/test-suite/output/Extraction_infix.out @@ -0,0 +1,20 @@ +(** val test : foo **) + +let test = + (fun (b, p) -> bar) (True, False) +(** val test : foo **) + +let test = + True@@?False +(** val test : foo **) + +let test = + True#^^False +(** val test : foo **) + +let test = + True@?:::False +(** val test : foo **) + +let test = + True @?::: False diff --git a/test-suite/output/Extraction_infix.v b/test-suite/output/Extraction_infix.v new file mode 100644 index 000000000..fe5926a36 --- /dev/null +++ b/test-suite/output/Extraction_infix.v @@ -0,0 +1,26 @@ +(* @herbelin's example for issue #6212 *) + +Require Import Extraction. +Inductive I := C : bool -> bool -> I. +Definition test := C true false. + +(* the parentheses around the function wrong signalled an infix operator *) + +Extract Inductive I => "foo" [ "(fun (b, p) -> bar)" ]. +Extraction test. + +(* some bonafide infix operators *) + +Extract Inductive I => "foo" [ "(@@?)" ]. +Extraction test. + +Extract Inductive I => "foo" [ "(#^^)" ]. +Extraction test. + +Extract Inductive I => "foo" [ "(@?:::)" ]. +Extraction test. + +(* allow whitespace around infix operator *) + +Extract Inductive I => "foo" [ "( @?::: )" ]. +Extraction test. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index e912003f0..af202ea01 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,3 +1,7 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in "A -> list' A -> list' (A * A)%type". +Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x + +For foo: Argument scopes are [type_scope _] +For Foo: Argument scopes are [type_scope _] diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v index 8db8956e3..8ff91268a 100644 --- a/test-suite/output/Inductive.v +++ b/test-suite/output/Inductive.v @@ -1,3 +1,7 @@ Fail Inductive list' (A:Set) : Set := | nil' : list' A | cons' : A -> list' A -> list' (A*A). + +(* Check printing of let-ins *) +Inductive foo (A : Type) (x : A) (y := x) := Foo. +Print foo. diff --git a/test-suite/output/InvalidDisjunctiveIntro.out b/test-suite/output/InvalidDisjunctiveIntro.out new file mode 100644 index 000000000..25a306b45 --- /dev/null +++ b/test-suite/output/InvalidDisjunctiveIntro.out @@ -0,0 +1,16 @@ +The command has indeed failed with message: +Cannot coerce to a disjunctive/conjunctive pattern. +The command has indeed failed with message: +Disjunctive/conjunctive introduction pattern expected. +The command has indeed failed with message: +Cannot coerce to a disjunctive/conjunctive pattern. +The command has indeed failed with message: +Cannot coerce to a disjunctive/conjunctive pattern. +The command has indeed failed with message: +Ltac variable H is bound to <tactic closure> which cannot be coerced to +an introduction pattern. +The command has indeed failed with message: +Disjunctive/conjunctive introduction pattern expected. +The command has indeed failed with message: +Ltac variable H' is bound to <tactic closure> which cannot be coerced to +an introduction pattern. diff --git a/test-suite/output/InvalidDisjunctiveIntro.v b/test-suite/output/InvalidDisjunctiveIntro.v new file mode 100644 index 000000000..4febdf034 --- /dev/null +++ b/test-suite/output/InvalidDisjunctiveIntro.v @@ -0,0 +1,18 @@ +Theorem test (A:Prop) : A \/ A -> A. + Fail intros H; destruct H as H. + (* Cannot coerce to a disjunctive/conjunctive pattern. *) + Fail intro H; destruct H as H. + (* Disjunctive/conjunctive introduction pattern expected. *) + Fail let H := fresh in intro H; destruct H as H. + (* Cannot coerce to a disjunctive/conjunctive pattern. *) + Fail let H := fresh in intros H; destruct H as H. + (* Cannot coerce to a disjunctive/conjunctive pattern. *) + Fail let H := idtac in intros H; destruct H as H. + (* Ltac variable H is bound to <tactic closure> which cannot be +coerced to an introduction pattern. *) + Fail let H := idtac in intros H; destruct H as H'. + (* Disjunctive/conjunctive introduction pattern expected. *) + Fail let H' := idtac in intros H; destruct H as H'. +(* Ltac variable H' is bound to <tactic closure> which cannot +be coerced to an introduction pattern. *) +Abort. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v new file mode 100644 index 000000000..352e422cf --- /dev/null +++ b/test-suite/output/MExtraction.v @@ -0,0 +1,12 @@ +Require Import micromega.MExtraction. +Require Import RingMicromega. +Require Import QArith. +Require Import VarMap. +Require Import ZMicromega. +Require Import QMicromega. +Require Import RMicromega. + +Recursive Extraction + List.map RingMicromega.simpl_cone (*map_cone indexes*) + denorm Qpower vm_add + n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 7bcd7b041..891296b0a 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -41,7 +41,7 @@ fun x : nat => ifn x is succ n then n else 0 -4 : Z The command has indeed failed with message: -x should not be bound in a recursive pattern of the right-hand side. +Cannot find where the recursive pattern starts. The command has indeed failed with message: in the right-hand side, y and z should appear in term position as part of a recursive pattern. @@ -64,7 +64,7 @@ The command has indeed failed with message: Cannot find where the recursive pattern starts. The command has indeed failed with message: Both ends of the recursive pattern are the same. -SUM (nat * nat) nat +(nat * nat + nat)%type : Set FST (0; 1) : Z @@ -72,7 +72,7 @@ Nil : forall A : Type, list A NIL : list nat : list nat -(false && I 3)%bool /\ I 6 +(false && I 3)%bool /\ (I 6)%bool : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index fe6c05c39..413812ee1 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -30,7 +30,7 @@ Check (decomp (true,true) as t, u in (t,u)). Section A. -Notation "! A" := (forall _:nat, A) (at level 60). +Notation "! A" := (forall _:nat, A) (at level 60) : type_scope. Check ! (0=0). Check forall n, n=0. @@ -194,9 +194,9 @@ Open Scope nat_scope. Coercion is_true := fun b => b=true. Coercion of_nat n := match n with 0 => true | _ => false end. -Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). +Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10) : bool_scope. -Check (false && I 3)%bool /\ I 6. +Check (false && I 3)%bool /\ (I 6)%bool. (**********************************************************************) (* Check notations with several recursive patterns *) diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index 1ec701ae8..6ffe56e11 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -17,10 +17,9 @@ fun (P : nat -> nat -> Prop) (x : nat) => exists y, P x y ∃ n p : nat, n + p = 0 : Prop let a := 0 in -∃ x y : nat, -let b := 1 in -let c := b in -let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d +∃ (x y : nat) (b := 1) (c := b) (d := 2) (z : nat), +let e := 3 in +let f := 4 in x + y = z + d : Prop ∀ n p : nat, n + p = 0 : Prop @@ -37,11 +36,22 @@ let' f (x y : nat) (a := 0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2 λ (f : nat -> nat) (x : nat), f(x) + S(x) : (nat -> nat) -> nat -> nat Notation plus2 n := (S(S(n))) +λ n : list(nat), match n with + | 1 :: nil => 0 + | _ => 2 + end + : list(nat) -> nat +λ n : list(nat), +match n with +| 1 :: nil => 0 +| nil | 0 :: _ | 1 :: _ :: _ | plus2 _ :: _ => 2 +end + : list(nat) -> nat λ n : list(nat), match n with | nil => 2 | 0 :: _ => 2 -| list1 => 0 +| 1 :: nil => 0 | 1 :: _ :: _ => 2 | plus2 _ :: _ => 2 end @@ -84,3 +94,9 @@ a≡ : Set .α : Set +# a : .α => +# b : .α => +let res := 0 in +for i from 0 to a updating (res) +{{for j from 0 to b updating (res) {{S res}};; res}};; res + : .α -> .α -> .α diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index ceb29d1b9..923caedac 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -36,8 +36,9 @@ Check fun P:nat->nat->Prop => fun x:nat => ex (P x). (* Test notations with binders *) -Notation "∃ x .. y , P":= (ex (fun x => .. (ex (fun y => P)) ..)) - (x binder, y binder, at level 200, right associativity). +Notation "∃ x .. y , P":= (ex (fun x => .. (ex (fun y => P)) ..)) + (x binder, y binder, at level 200, right associativity, + format "'[ ' ∃ x .. y ']' , P"). Check (∃ n p, n+p=0). @@ -70,6 +71,7 @@ Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. (* Note: does not work for pattern *) Module A. Notation "f ( x )" := (f x) (at level 10, format "f ( x )"). +Open Scope nat_scope. Check fun f x => f x + S x. Open Scope list_scope. @@ -78,6 +80,13 @@ Notation plus2 n := (S (S n)). (* plus2 was not correctly printed in the two following tests in 8.3pl1 *) Print plus2. Check fun n => match n with list1 => 0 | _ => 2 end. +Unset Printing Allow Match Default Clause. +Check fun n => match n with list1 => 0 | _ => 2 end. +Unset Printing Factorizable Match Patterns. +Check fun n => match n with list1 => 0 | _ => 2 end. +Set Printing Allow Match Default Clause. +Set Printing Factorizable Match Patterns. + End A. (* This one is not fully satisfactory because binders in the same type @@ -145,3 +154,24 @@ Check .a≡. Notation ".α" := nat. Check nat. Check .α. + +(* A test for #6304 *) + +Module M6304. +Notation "'for' m 'from' 0 'to' N 'updating' ( s1 ) {{ b }} ;; rest" := + (let s1 := + (fix rec(n: nat) := match n with + | 0 => s1 + | S m => let s1 := rec m in b + end) N + in rest) + (at level 20). + +Check fun (a b : nat) => + let res := 0 in + for i from 0 to a updating (res) {{ + for j from 0 to b updating (res) {{ S res }};; + res + }};; res. + +End M6304. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 6ef75dd13..e6a6e0288 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -128,3 +128,110 @@ return (1, 2, 3, 4) : nat *(1.2) : nat +[{0; 0}] + : list (list nat) +[{1; 2; 3}; + {4; 5; 6}; + {7; 8; 9}] + : list (list nat) +amatch = mmatch 0 (with 0 => 1| 1 => 2 end) + : unit +alist = [0; 1; 2] + : list nat +! '{{x, y}}, x + y = 0 + : Prop +exists x : nat, + nat -> + exists y : nat, + nat -> + exists '{{u, t}}, forall z1 : nat, z1 = 0 /\ x + y = 0 /\ u + t = 0 + : Prop +exists x : nat, + nat -> + exists y : nat, + nat -> + exists '{{z, t}}, forall z2 : nat, z2 = 0 /\ x + y = 0 /\ z + t = 0 + : Prop +exists_true '{{x, y}} (u := 0) '{{z, t}}, x + y = 0 /\ z + t = 0 + : Prop +exists_true (A : Type) (R : A -> A -> Prop) (_ : Reflexive R), +(forall x : A, R x x) + : Prop +exists_true (x : nat) (A : Type) (R : A -> A -> Prop) +(_ : Reflexive R) (y : nat), x + y = 0 -> forall z : A, R z z + : Prop +{{{{True, nat -> True}}, nat -> True}} + : Prop * Prop * Prop +{{D 1, 2}} + : nat * nat * (nat * nat * (nat * nat)) +! a b : nat # True # + : Prop * (Prop * Prop) +!!!! a b : nat # True # + : Prop * Prop * (Prop * Prop * Prop) +@@ a b : nat # a = b # b = a # + : Prop * Prop +exists_non_null x y z t : nat , x = y /\ z = t + : Prop +forall_non_null x y z t : nat , x = y /\ z = t + : Prop +{{RL 1, 2}} + : nat * (nat * nat) +{{RR 1, 2}} + : nat * nat * nat +@pair nat (prod nat nat) (S (S O)) (@pair nat nat (S O) O) + : prod nat (prod nat nat) +@pair (prod nat nat) nat (@pair nat nat O (S (S O))) (S O) + : prod (prod nat nat) nat +{{RLRR 1, 2}} + : nat * (nat * nat) * (nat * nat * nat) * (nat * (nat * nat)) * + (nat * nat * nat) +pair + (pair + (pair (pair (S (S O)) (pair (S O) O)) (pair (pair O (S (S O))) (S O))) + (pair (S O) (pair (S (S O)) O))) (pair (pair O (S O)) (S (S O))) + : prod + (prod (prod (prod nat (prod nat nat)) (prod (prod nat nat) nat)) + (prod nat (prod nat nat))) (prod (prod nat nat) nat) +fun x : nat => if x is n .+ 1 then n else 1 + : nat -> nat +{'{{x, y}} : nat * nat | x + y = 0} + : Set +exists2' {{x, y}}, x = 0 & y = 0 + : Prop +myexists2 x : nat * nat, + let '{{y, z}} := x in y > z & let '{{y, z}} := x in z > y + : Prop +fun '({{x, y}} as z) => x + y = 0 /\ z = z + : nat * nat -> Prop +myexists ({{x, y}} as z), x + y = 0 /\ z = z + : Prop +exists '({{x, y}} as z), x + y = 0 /\ z = z + : Prop +∀ '({{x, y}} as z), x + y = 0 /\ z = z + : Prop +fun '({{{{x, y}}, true}} | {{{{x, y}}, false}}) => x + y + : nat * nat * bool -> nat +myexists ({{{{x, y}}, true}} | {{{{x, y}}, false}}), x > y + : Prop +exists '({{{{x, y}}, true}} | {{{{x, y}}, false}}), x > y + : Prop +∀ '({{{{x, y}}, true}} | {{{{x, y}}, false}}), x > y + : Prop +fun p : nat => if p is S n then n else 0 + : nat -> nat +fun p : comparison => if p is Lt then 1 else 0 + : comparison -> nat +fun S : nat => [S | S + S] + : nat -> nat * (nat -> nat) +fun N : nat => [N | N + 0] + : nat -> nat * (nat -> nat) +fun S : nat => [[S | S + S]] + : nat -> nat * (nat -> nat) +{I : nat | I = I} + : Set +{'I : True | I = I} + : Prop +{'{{x, y}} : nat * nat | x + y = 0} + : Set +exists2 '{{y, z}} : nat * nat, y > z & z > y + : Prop diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 8c7bbe591..c98bfff41 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -59,7 +59,7 @@ Check fun f => CURRYINVLEFT (x:nat) (y:bool), f. (* Notations with variables bound both as a term and as a binder *) (* This is #4592 *) -Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)). +Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)) : type_scope. Check forall n:nat, {# n | 1 > n}. Parameter foo : forall {T}(x : T)(P : T -> Prop), Prop. @@ -183,9 +183,13 @@ Check letpair x [1] = {0}; return (1,2,3,4). (* Test spacing in #5569 *) +Section S1. +Variable plus : nat -> nat -> nat. +Infix "+" := plus. Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. +End S1. (* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). @@ -193,7 +197,226 @@ Check !!! (x y:nat), True. (* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) -Notation "* x" := (id x) (only printing, at level 15, format "* x"). -Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Section S2. +Notation "* x" := (id x) (only printing, at level 15, format "* x") : nat_scope. +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y") : nat_scope. Check (((id 1) + 2) + 3). Check (id (1 + 2)). +End S2. + +(* Test printing of notations guided by scope *) + +Module A. + +Delimit Scope line_scope with line. +Notation "{ }" := nil (format "{ }") : line_scope. +Notation "{ x }" := (cons x nil) : line_scope. +Notation "{ x ; y ; .. ; z }" := (cons x (cons y .. (cons z nil) ..)) : line_scope. +Notation "[ ]" := nil (format "[ ]") : matx_scope. +Notation "[ l ]" := (cons l%line nil) : matx_scope. +Notation "[ l ; l' ; .. ; l'' ]" := (cons l%line (cons l'%line .. (cons l''%line nil) ..)) + (format "[ '[v' l ; '/' l' ; '/' .. ; '/' l'' ']' ]") : matx_scope. + +Open Scope matx_scope. +Check [[0;0]]. +Check [[1;2;3];[4;5;6];[7;8;9]]. + +End A. + +(* Example by Beta Ziliani *) + +Require Import Lists.List. + +Module B. + +Import ListNotations. + +Delimit Scope pattern_scope with pattern. +Delimit Scope patterns_scope with patterns. + +Notation "a => b" := (a, b) (at level 201) : pattern_scope. +Notation "'with' p1 | .. | pn 'end'" := + ((cons p1%pattern (.. (cons pn%pattern nil) ..))) + (at level 91, p1 at level 210, pn at level 210) : patterns_scope. + +Definition mymatch (n:nat) (l : list (nat * nat)) := tt. +Arguments mymatch _ _%patterns. +Notation "'mmatch' n ls" := (mymatch n ls) (at level 0). + +Close Scope patterns_scope. +Close Scope pattern_scope. + +Definition amatch := mmatch 0 with 0 => 1 | 1 => 2 end. +Print amatch. (* Good: amatch = mmatch 0 (with 0 => 1| 1 => 2 end) *) + +Definition alist := [0;1;2]. +Print alist. + +End B. + +(* Test contraction of "forall x, let 'pat := x in ..." into "forall 'pat, ..." *) +(* for isolated "forall" (was not working already in 8.6) *) +Notation "! x .. y , A" := (id (forall x, .. (id (forall y, A)) .. )) (at level 200, x binder). +Check ! '(x,y), x+y=0. + +(* Check that the terminator of a recursive pattern is interpreted in + the correct environment of bindings *) +Notation "'exists_mixed' x .. y , P" := (ex (fun x => forall z:nat, .. (ex (fun y => forall z:nat, z=0 /\ P)) ..)) (at level 200, x binder). +Check exists_mixed x y '(u,t), x+y=0/\u+t=0. +Check exists_mixed x y '(z,t), x+y=0/\z+t=0. + +(* Check that intermediary let-in are inserted inbetween instances of + the repeated pattern *) +Notation "'exists_true' x .. y , P" := (exists x, True /\ .. (exists y, True /\ P) ..) (at level 200, x binder). +Check exists_true '(x,y) (u:=0) '(z,t), x+y=0/\z+t=0. + +(* Check that generalized binders are correctly interpreted *) + +Module G. +Generalizable Variables A R. +Class Reflexive {A:Type} (R : A->A->Prop) := reflexivity : forall x : A, R x x. +Check exists_true `{Reflexive A R}, forall x, R x x. +Check exists_true x `{Reflexive A R} y, x+y=0 -> forall z, R z z. +End G. + +(* Allows recursive patterns for binders to be associative on the left *) +Notation "!! x .. y # A #" := (.. (A,(forall x, True)) ..,(forall y, True)) (at level 200, x binder). +Check !! a b : nat # True #. + +(* Examples where the recursive pattern refer several times to the recursive variable *) + +Notation "{{D x , .. , y }}" := ((x,x), .. ((y,y),(0,0)) ..). +Check {{D 1, 2 }}. + +Notation "! x .. y # A #" := + ((forall x, x=x), .. ((forall y, y=y), A) ..) + (at level 200, x binder). +Check ! a b : nat # True #. + +Notation "!!!! x .. y # A #" := + (((forall x, x=x),(forall x, x=0)), .. (((forall y, y=y),(forall y, y=0)), A) ..) + (at level 200, x binder). +Check !!!! a b : nat # True #. + +Notation "@@ x .. y # A # B #" := + ((forall x, .. (forall y, A) ..), (forall x, .. (forall y, B) ..)) + (at level 200, x binder). +Check @@ a b : nat # a=b # b=a #. + +Notation "'exists_non_null' x .. y , P" := + (ex (fun x => x <> 0 /\ .. (ex (fun y => y <> 0 /\ P)) ..)) + (at level 200, x binder). +Check exists_non_null x y z t , x=y/\z=t. + +Notation "'forall_non_null' x .. y , P" := + (forall x, x <> 0 -> .. (forall y, y <> 0 -> P) ..) + (at level 200, x binder). +Check forall_non_null x y z t , x=y/\z=t. + +(* Examples where the recursive pattern is in reverse order *) + +Notation "{{RL c , .. , d }}" := (pair d .. (pair c 0) ..). +Check {{RL 1 , 2}}. + +Notation "{{RR c , .. , d }}" := (pair .. (pair 0 d) .. c). +Check {{RR 1 , 2}}. + +Set Printing All. +Check {{RL 1 , 2}}. +Check {{RR 1 , 2}}. +Unset Printing All. + +Notation "{{RLRR c , .. , d }}" := (pair d .. (pair c 0) .., pair .. (pair 0 d) .. c, pair c .. (pair d 0) .., pair .. (pair 0 c) .. d). +Check {{RLRR 1 , 2}}. +Unset Printing Notations. +Check {{RLRR 1 , 2}}. +Set Printing Notations. + +(* Check insensitivity of "match" clauses to order *) + +Notation "'if' t 'is' n .+ 1 'then' p 'else' q" := + (match t with S n => p | 0 => q end) + (at level 200). +Check fun x => if x is n.+1 then n else 1. + +(* Examples with binding patterns *) + +Check {'(x,y)|x+y=0}. + +Module D. +Notation "'exists2'' x , p & q" := (ex2 (fun x => p) (fun x => q)) + (at level 200, x pattern, p at level 200, right associativity, + format "'[' 'exists2'' '/ ' x , '/ ' '[' p & '/' q ']' ']'") + : type_scope. + +Check exists2' (x,y), x=0 & y=0. +End D. + +(* Ensuring for reparsability that printer of notations does not use a + pattern where only an ident could be reparsed *) + +Module E. +Inductive myex2 {A:Type} (P Q:A -> Prop) : Prop := + myex_intro2 : forall x:A, P x -> Q x -> myex2 P Q. +Notation "'myexists2' x : A , p & q" := (myex2 (A:=A) (fun x => p) (fun x => q)) + (at level 200, x ident, A at level 200, p at level 200, right associativity, + format "'[' 'myexists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") + : type_scope. +Check myex2 (fun x => let '(y,z) := x in y>z) (fun x => let '(y,z) := x in z>y). +End E. + +(* A canonical example of a notation with a non-recursive binder *) + +Parameter myex : forall {A}, (A -> Prop) -> Prop. +Notation "'myexists' x , p" := (myex (fun x => p)) + (at level 200, x pattern, p at level 200, right associativity). + +(* A canonical example of a notation with recursive binders *) + +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + +(* Check that printing 'pat uses an "as" when the variable bound to + the pattern is dependent. We check it for the three kinds of + notations involving bindings of patterns *) + +Check fun '((x,y) as z) => x+y=0/\z=z. (* Primitive fun/forall *) +Check myexists ((x,y) as z), x+y=0/\z=z. (* Isolated binding pattern *) +Check exists '((x,y) as z), x+y=0/\z=z. (* Applicative recursive binder *) +Check ∀ '((x,y) as z), x+y=0/\z=z. (* Other example of recursive binder, now treated as the exists case *) + +(* Check parsability and printability of irrefutable disjunctive patterns *) + +Check fun '(((x,y),true)|((x,y),false)) => x+y. +Check myexists (((x,y),true)|((x,y),false)), x>y. +Check exists '(((x,y),true)|((x,y),false)), x>y. +Check ∀ '(((x,y),true)|((x,y),false)), x>y. + +(* Check Georges' printability of a "if is then else" notation *) + +Notation "'if' c 'is' p 'then' u 'else' v" := + (match c with p => u | _ => v end) + (at level 200, p pattern at level 100). +Check fun p => if p is S n then n else 0. +Check fun p => if p is Lt then 1 else 0. + +(* Check that mixed binders and terms defaults to ident and not pattern *) +Module F. + (* First without an indirection *) +Notation "[ n | t ]" := (n, (fun n : nat => t)). +Check fun S : nat => [ S | S+S ]. +Check fun N : nat => (N, (fun n => n+0)). (* another test in passing *) + (* Then with an indirection *) +Notation "[[ n | p | t ]]" := (n, (fun p : nat => t)). +Notation "[[ n | t ]]" := [[ n | n | t ]]. +Check fun S : nat => [[ S | S+S ]]. +End F. + +(* Check parsability/printability of {x|P} and variants *) + +Check {I:nat|I=I}. +Check {'I:True|I=I}. +Check {'(x,y)|x+y=0}. + +(* Check exists2 with a pattern *) +Check ex2 (fun x => let '(y,z) := x in y>z) (fun x => let '(y,z) := x in z>y). diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 95be04c32..8a6d94c73 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -31,7 +31,7 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) : Prop both_z = fun pat : nat * nat => -let '(n, p) as pat0 := pat return (F pat0) in (Z n, Z p) : F (n, p) +let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) : forall pat : nat * nat, F pat fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop @@ -39,3 +39,9 @@ forall '(x, y) '(z, t), swap (x, y) = (z, t) : Prop fun (pat : nat) '(x, y) => x + y = pat : nat -> nat * nat -> Prop +f = fun x : nat => x + x + : nat -> nat + +Argument scope is [nat_scope] +fun x : nat => x + x + : nat -> nat diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index 0bad472f4..d671053c0 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -67,3 +67,8 @@ End Suboptimal. (** Test risk of collision for internal name *) Check fun pat => fun '(x,y) => x+y = pat. + +(** Test name in degenerate case *) +Definition f 'x := x+x. +Print f. +Check fun 'x => x+x. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index f69379a57..668b4e578 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -5,7 +5,7 @@ PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] For pwrap: Argument scopes are [type_scope _] punwrap@{u} = -fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p +fun (A : Type@{u}) (p : PWrap@{u} A) => p.(punwrap) : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) @@ -44,26 +44,45 @@ bar@{u} = nat bar is universe polymorphic foo@{u Top.17 v} = Type@{Top.17} -> Type@{v} -> Type@{u} - : Type@{max(u+1, Top.17+1, v+1)} + : Type@{max(u+1,Top.17+1,v+1)} (* u Top.17 v |= *) foo is universe polymorphic -Monomorphic mono = Type@{u} - : Type@{u+1} -(* {u} |= *) +Monomorphic mono = Type@{mono.u} + : Type@{mono.u+1} +(* {mono.u} |= *) mono is not universe polymorphic +mono + : Type@{mono.u+1} +Type@{mono.u} + : Type@{mono.u+1} +The command has indeed failed with message: +Universe u already exists. +monomono + : Type@{MONOU+1} +mono.monomono + : Type@{mono.MONOU+1} +monomono + : Type@{MONOU+1} +mono + : Type@{mono.u+1} +The command has indeed failed with message: +Universe u already exists. +bobmorane = +let tt := Type@{tt.v} in let ff := Type@{ff.v} in tt -> ff + : Type@{max(tt.u,ff.u)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} - : Type@{max(E+1, M+1, N+1)} + : Type@{max(E+1,M+1,N+1)} (* E M N |= *) foo is universe polymorphic foo@{Top.16 Top.17 Top.18} = Type@{Top.17} -> Type@{Top.18} -> Type@{Top.16} - : Type@{max(Top.16+1, Top.17+1, Top.18+1)} + : Type@{max(Top.16+1,Top.17+1,Top.18+1)} (* Top.16 Top.17 Top.18 |= *) foo is universe polymorphic @@ -88,9 +107,10 @@ The command has indeed failed with message: This object does not support universe names. The command has indeed failed with message: Cannot enforce v < u because u < gU < gV < v -Monomorphic bind_univs.mono = Type@{u} - : Type@{u+1} -(* {u} |= *) +Monomorphic bind_univs.mono = +Type@{bind_univs.mono.u} + : Type@{bind_univs.mono.u+1} +(* {bind_univs.mono.u} |= *) bind_univs.mono is not universe polymorphic bind_univs.poly@{u} = Type@{u} @@ -99,12 +119,12 @@ bind_univs.poly@{u} = Type@{u} bind_univs.poly is universe polymorphic insec@{v} = Type@{u} -> Type@{v} - : Type@{max(u+1, v+1)} + : Type@{max(u+1,v+1)} (* v |= *) insec is universe polymorphic insec@{u v} = Type@{u} -> Type@{v} - : Type@{max(u+1, v+1)} + : Type@{max(u+1,v+1)} (* u v |= *) insec is universe polymorphic @@ -125,28 +145,28 @@ inmod@{u} = Type@{u} inmod is universe polymorphic Applied.infunct@{u v} = inmod@{u} -> Type@{v} - : Type@{max(u+1, v+1)} + : Type@{max(u+1,v+1)} (* u v |= *) Applied.infunct is universe polymorphic -axfoo@{i Top.33 Top.34} : Type@{Top.33} -> Type@{i} -(* i Top.33 Top.34 |= *) +axfoo@{i Top.41 Top.42} : Type@{Top.41} -> Type@{i} +(* i Top.41 Top.42 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axfoo -axbar@{i Top.33 Top.34} : Type@{Top.34} -> Type@{i} -(* i Top.33 Top.34 |= *) +axbar@{i Top.41 Top.42} : Type@{Top.42} -> Type@{i} +(* i Top.41 Top.42 |= *) axbar is universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axbar -axfoo' : Type@{Top.36} -> Type@{i} +axfoo' : Type@{Top.44} -> Type@{axbar'.i} axfoo' is not universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axfoo' -axbar' : Type@{Top.36} -> Type@{i} +axbar' : Type@{Top.44} -> Type@{axbar'.i} axbar' is not universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index 116d5e5e9..266d94ad9 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -1,6 +1,6 @@ Set Universe Polymorphism. Set Printing Universes. -Unset Strict Universe Declaration. +(* Unset Strict Universe Declaration. *) (* universe binders on inductive types and record projections *) Inductive Empty@{u} : Type@{u} := . @@ -25,14 +25,59 @@ Print wrap. Instance bar@{u} : Wrap@{u} Set. Proof. exact nat. Qed. Print bar. +Unset Strict Universe Declaration. (* The universes in the binder come first, then the extra universes in order of appearance. *) Definition foo@{u +} := Type -> Type@{v} -> Type@{u}. Print foo. +Set Strict Universe Declaration. (* Binders even work with monomorphic definitions! *) Monomorphic Definition mono@{u} := Type@{u}. Print mono. +Check mono. +Check Type@{mono.u}. + +Module mono. + Fail Monomorphic Universe u. + Monomorphic Universe MONOU. + + Monomorphic Definition monomono := Type@{MONOU}. + Check monomono. +End mono. +Check mono.monomono. (* qualified MONOU *) +Import mono. +Check monomono. (* unqualified MONOU *) +Check mono. (* still qualified mono.u *) + +Monomorphic Constraint Set < Top.mono.u. + +Module mono2. + Monomorphic Universe u. +End mono2. + +Fail Monomorphic Definition mono2@{u} := Type@{u}. + +Module SecLet. + Unset Universe Polymorphism. + Section foo. + (* Fail Let foo@{} := Type@{u}. (* doesn't parse: Let foo@{...} doesn't exist *) *) + Unset Strict Universe Declaration. + Let tt : Type@{u} := Type@{v}. (* names disappear in the ether *) + Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* if Set Universe Polymorphism: universes are named ff.u and ff.v. Otherwise names disappear into space *) + Definition bobmorane := tt -> ff. + End foo. + Print bobmorane. (* + bobmorane@{Top.15 Top.16 ff.u ff.v} = + let tt := Type@{Top.16} in let ff := Type@{ff.v} in tt -> ff + : Type@{max(Top.15,ff.u)} + (* Top.15 Top.16 ff.u ff.v |= Top.16 < Top.15 + ff.v < ff.u + *) + + bobmorane is universe polymorphic + *) +End SecLet. (* fun x x => foo is nonsense with local binders *) Fail Definition fo@{u u} := Type@{u}. @@ -61,7 +106,7 @@ Monomorphic Universes gU gV. Monomorphic Constraint gU < gV. Fail Lemma foo@{u v|u < gU, gV < v, v < u} : nat. (* Universe binders survive through compilation, sections and modules. *) -Require bind_univs. +Require TestSuite.bind_univs. Print bind_univs.mono. Print bind_univs.poly. diff --git a/test-suite/output/bug5778.out b/test-suite/output/bug5778.out new file mode 100644 index 000000000..91ceb1b58 --- /dev/null +++ b/test-suite/output/bug5778.out @@ -0,0 +1,4 @@ +The command has indeed failed with message: +In nested Ltac calls to "c", "abs" and "abstract b ltac:(())", last call +failed. +The term "I" has type "True" which should be Set, Prop or Type. diff --git a/test-suite/output/bug5778.v b/test-suite/output/bug5778.v new file mode 100644 index 000000000..0dcd76aef --- /dev/null +++ b/test-suite/output/bug5778.v @@ -0,0 +1,7 @@ +Ltac a _ := pose (I : I). +Ltac b _ := a (). +Ltac abs _ := abstract b (). +Ltac c _ := abs (). +Goal True. + Fail c (). +Abort. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index c5d58ec1e..eb9f57102 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,7 +1,7 @@ The command has indeed failed with message: Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := - symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize + symmetry in x, y; auto with z; auto; intros; clearbody x; generalize dependent z The command has indeed failed with message: In nested Ltac calls to "g1" and "refine (uconstr)", last call failed. @@ -32,7 +32,7 @@ nat 0 0 Ltac foo := - let x := intros ** in + let x := intros in let y := intros -> in let v := constr:(nil) in let w := () in diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out index 172612405..7326f137c 100644 --- a/test-suite/output/ltac_missing_args.out +++ b/test-suite/output/ltac_missing_args.out @@ -1,20 +1,40 @@ The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.foo" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.bar" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing arguments for variables y and _. +The user-defined tactic "Top.bar" was not fully applied: +There are missing arguments for variables y and _, +an argument was provided for variable x. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.baz" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.qux" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +The user-defined tactic "Top.mydo" was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.rec" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable x, +an argument was provided for variable tac. diff --git a/test-suite/output/optimize_heap.out b/test-suite/output/optimize_heap.out new file mode 100644 index 000000000..94a0b1911 --- /dev/null +++ b/test-suite/output/optimize_heap.out @@ -0,0 +1,8 @@ +1 subgoal + + ============================ + True +1 subgoal + + ============================ + True diff --git a/test-suite/output/optimize_heap.v b/test-suite/output/optimize_heap.v new file mode 100644 index 000000000..e566bd7ba --- /dev/null +++ b/test-suite/output/optimize_heap.v @@ -0,0 +1,7 @@ +(* optimize_heap should not affect the proof state *) + +Goal True. + idtac. + Show. + optimize_heap. + Show. diff --git a/test-suite/prerequisite/bind_univs.v b/test-suite/prerequisite/bind_univs.v index f17c00e9d..e834fde11 100644 --- a/test-suite/prerequisite/bind_univs.v +++ b/test-suite/prerequisite/bind_univs.v @@ -3,3 +3,5 @@ Monomorphic Definition mono@{u} := Type@{u}. Polymorphic Definition poly@{u} := Type@{u}. + +Monomorphic Universe reqU. diff --git a/test-suite/success/BracketsWithGoalSelector.v b/test-suite/success/BracketsWithGoalSelector.v new file mode 100644 index 000000000..ed035f521 --- /dev/null +++ b/test-suite/success/BracketsWithGoalSelector.v @@ -0,0 +1,16 @@ +Goal forall A B, B \/ A -> A \/ B. +Proof. + intros * [HB | HA]. + 2: { + left. + exact HA. + Fail right. (* No such goal. Try unfocusing with "}". *) + } + Fail 2: { (* Non-existent goal. *) + idtac. (* The idtac is to get a dot, so that IDEs know to stop there. *) + 1:{ (* Syntactic test: no space before bracket. *) + right. + exact HB. +Fail Qed. + } +Qed. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v index 0f677a849..82b51b1ff 100644 --- a/test-suite/success/Check.v +++ b/test-suite/success/Check.v @@ -12,3 +12,5 @@ Check 0. Check S. Check nat. + +Type Type : Type. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 2655b651a..7c2cf3ee5 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -92,16 +92,37 @@ Check ##### 0 _ 0%bool 0%bool : prod' bool bool. Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. (* 10. Check computation of binding variable through other notations *) -(* i should be detected as binding variable and the scopes not being checked *) - +(* it should be detected as binding variable and the scopes not being checked *) Notation "'FUNNAT' i => t" := (fun i : nat => i = t) (at level 200). Notation "'Funnat' i => t" := (FUNNAT i => t + i%nat) (at level 200). (* 11. Notations with needed factorization of a recursive pattern *) (* See https://github.com/coq/coq/issues/6078#issuecomment-342287412 *) -Module A. +Module M11. Notation "[:: x1 ; .. ; xn & s ]" := (cons x1 .. (cons xn s) ..). Notation "[:: x1 ; .. ; xn ]" := (cons x1 .. (cons xn nil) ..). Check [:: 1 ; 2 ; 3 ]. Check [:: 1 ; 2 ; 3 & nil ]. (* was failing *) -End A. +End M11. + +(* 12. Preventively check that a variable which does not occur can be instantiated *) +(* by any term. In particular, it should not be restricted to a binder *) +Module M12. +Notation "N ++ x" := (S x) (only parsing). +Check 2 ++ 0. +End M12. + +(* 13. Check that internal data about associativity are not used in comparing levels *) +Module M13. +Notation "x ;; z" := (x + z) + (at level 100, z at level 200, only parsing, right associativity). +Notation "x ;; z" := (x * z) + (at level 100, z at level 200, only parsing) : foo_scope. +End M13. + +(* 14. Check that a notation with a "ident" binder does not include a pattern *) +Module M14. +Notation "'myexists' x , p" := (ex (fun x => p)) + (at level 200, x ident, p at level 200, right associativity) : type_scope. +Check myexists I, I = 0. (* Should not be seen as a constructor *) +End M14. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 6b1f0315b..cd6eac35c 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -240,3 +240,20 @@ Module IterativeDeepening. Qed. End IterativeDeepening. + +Module AxiomsAreInstances. + Set Typeclasses Axioms Are Instances. + Class TestClass1 := {}. + Axiom testax1 : TestClass1. + Definition testdef1 : TestClass1 := _. + + Unset Typeclasses Axioms Are Instances. + Class TestClass2 := {}. + Axiom testax2 : TestClass2. + Fail Definition testdef2 : TestClass2 := _. + + (* we didn't break typeclasses *) + Existing Instance testax2. + Definition testdef2 : TestClass2 := _. + +End AxiomsAreInstances. diff --git a/test-suite/success/abstract_poly.v b/test-suite/success/abstract_poly.v index b736b734f..aa8da5336 100644 --- a/test-suite/success/abstract_poly.v +++ b/test-suite/success/abstract_poly.v @@ -17,4 +17,4 @@ intros m n P e p. abstract (rewrite e in p; exact p). Defined. -Check bar_subproof@{Set Set Set}. +Check bar_subproof@{Set Set}. diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index 3178c6fc1..730b367d6 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -55,6 +55,7 @@ Module Backtracking. Axiom A : Type. Existing Class A. Axioms a b c d e: A. + Existing Instances a b c d e. Ltac get_value H := eval cbv delta [H] in H. diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v index 0ee85712e..e05762477 100644 --- a/test-suite/success/cumulativity.v +++ b/test-suite/success/cumulativity.v @@ -45,6 +45,15 @@ Section TpLift. End TpLift. +Record Tp' := { tp' : Tp }. + +Definition CTp := Tp. +(* here we have to reduce a constant to infer the correct subtyping. *) +Record Tp'' := { tp'' : CTp }. + +Definition LiftTp'@{i j|i < j} : Tp'@{i} -> Tp'@{j} := fun x => x. +Definition LiftTp''@{i j|i < j} : Tp''@{i} -> Tp''@{j} := fun x => x. + Lemma LiftC_Lem (t : Tp) : LiftTp t = t. Proof. reflexivity. Qed. @@ -98,3 +107,30 @@ Section down. intros H f g Hfg. exact (H f g Hfg). Defined. End down. + +Record Arrow@{i j} := { arrow : Type@{i} -> Type@{j} }. + +Fail Definition arrow_lift@{i i' j j' | i' < i, j < j'} + : Arrow@{i j} -> Arrow@{i' j'} + := fun x => x. + +Definition arrow_lift@{i i' j j' | i' = i, j < j'} + : Arrow@{i j} -> Arrow@{i' j'} + := fun x => x. + +Inductive Mut1 A := +| Base1 : Type -> Mut1 A +| Node1 : (A -> Mut2 A) -> Mut1 A +with Mut2 A := + | Base2 : Type -> Mut2 A + | Node2 : Mut1 A -> Mut2 A. + +(* If we don't reduce T while inferring cumulativity for the + constructor we will see a Rel and believe i is irrelevant. *) +Inductive withparams@{i j} (T:=Type@{i}:Type@{j}) := mkwithparams : T -> withparams. + +Definition withparams_co@{i i' j|i < i', i' < j} : withparams@{i j} -> withparams@{i' j} + := fun x => x. + +Fail Definition withparams_not_irr@{i i' j|i' < i, i' < j} : withparams@{i j} -> withparams@{i' j} + := fun x => x. diff --git a/test-suite/success/dtauto-let-deps.v b/test-suite/success/dtauto-let-deps.v new file mode 100644 index 000000000..094b2f8b3 --- /dev/null +++ b/test-suite/success/dtauto-let-deps.v @@ -0,0 +1,24 @@ +(* +This test is sensitive to changes in which let-ins are expanded when checking +for dependencies in constructors. +If the (x := X) is not reduced, Foo1 won't be recognized as a conjunction, +and if the (y := X) is reduced, Foo2 will be recognized as a conjunction. + +This tests the behavior of engine/termops.ml : prod_applist_assum, +which is currently specified to reduce exactly the parameters. + +If dtauto is changed to reduce lets in constructors before checking dependency, +this test will need to be changed. +*) + +Context (P Q : Type). +Inductive Foo1 (X : Type) (x := X) := foo1 : let y := X in P -> Q -> Foo1 x. +Inductive Foo2 (X : Type) (x := X) := foo2 : let y := X in P -> Q -> Foo2 y. + +Goal P -> Q -> Foo1 nat. +solve [dtauto]. +Qed. + +Goal P -> Q -> Foo2 nat. +Fail solve [dtauto]. +Abort. diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index 0ee223250..83726bfdc 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -635,6 +635,6 @@ Recursive Extraction Everything. Require Import ZArith. -Extraction Language Ocaml. +Extraction Language OCaml. Recursive Extraction Z_modulo_2 Zdiv_eucl_exist. Extraction TestCompile Z_modulo_2 Zdiv_eucl_exist. diff --git a/test-suite/success/unidecls.v b/test-suite/success/unidecls.v new file mode 100644 index 000000000..c4a1d7c28 --- /dev/null +++ b/test-suite/success/unidecls.v @@ -0,0 +1,121 @@ +Set Printing Universes. + +Module unidecls. + Universes a b. +End unidecls. + +Universe a. + +Constraint a < unidecls.a. + +Print Universes. + +(** These are different universes *) +Check Type@{a}. +Check Type@{unidecls.a}. + +Check Type@{unidecls.b}. + +Fail Check Type@{unidecls.c}. + +Fail Check Type@{i}. +Universe foo. +Module Foo. + (** Already declared globaly: but universe names are scoped at the module level *) + Universe foo. + Universe bar. + + Check Type@{Foo.foo}. + Definition bar := 0. +End Foo. + +(** Already declared in the module *) +Universe bar. + +(** Accessible outside the module: universe declarations are global *) +Check Type@{bar}. +Check Type@{Foo.bar}. + +Check Type@{Foo.foo}. +(** The same *) +Check Type@{foo}. +Check Type@{Top.foo}. + +Universe secfoo. +Section Foo'. + Fail Universe secfoo. + Universe secfoo2. + Check Type@{Foo'.secfoo2}. + Constraint secfoo2 < a. +End Foo'. + +Check Type@{secfoo2}. +Fail Check Type@{Foo'.secfoo2}. +Fail Check eq_refl : Type@{secfoo2} = Type@{a}. + +(** Below, u and v are global, fixed universes *) +Module Type Arg. + Universe u. + Parameter T: Type@{u}. +End Arg. + +Module Fn(A : Arg). + Universes v. + + Check Type@{A.u}. + Constraint A.u < v. + + Definition foo : Type@{v} := nat. + Definition bar : Type@{A.u} := nat. + + Fail Definition foo(A : Type@{v}) : Type@{A.u} := A. +End Fn. + +Module ArgImpl : Arg. + Definition T := nat. +End ArgImpl. + +Module ArgImpl2 : Arg. + Definition T := bool. +End ArgImpl2. + +(** Two applications of the functor result in the exact same universes *) +Module FnApp := Fn(ArgImpl). + +Check Type@{FnApp.v}. +Check FnApp.foo. +Check FnApp.bar. + +Check (eq_refl : Type@{ArgImpl.u} = Type@{ArgImpl2.u}). + +Module FnApp2 := Fn(ArgImpl). +Check Type@{FnApp2.v}. +Check FnApp2.foo. +Check FnApp2.bar. + +Import ArgImpl2. +(** Now u refers to ArgImpl.u and ArgImpl2.u *) +Check FnApp2.bar. + +(** It can be shadowed *) +Universe u. + +(** This refers to the qualified name *) +Check FnApp2.bar. + +Constraint u = ArgImpl.u. +Print Universes. + +Set Universe Polymorphism. + +Section PS. + Universe poly. + + Definition id (A : Type@{poly}) (a : A) : A := a. +End PS. +(** The universe is polymorphic and discharged, does not persist *) +Fail Check Type@{poly}. + +Print Universes. +Check id nat. +Check id@{Set}. diff --git a/theories/.dir-locals.el b/theories/.dir-locals.el deleted file mode 100644 index 4e8830f6c..000000000 --- a/theories/.dir-locals.el +++ /dev/null @@ -1,4 +0,0 @@ -((coq-mode . ((eval . (let ((default-directory (locate-dominating-file - buffer-file-name ".dir-locals.el"))) - (setq-local coq-prog-args `("-coqlib" ,(expand-file-name "..") "-R" ,(expand-file-name ".") "Coq")) - (setq-local coq-prog-name (expand-file-name "../bin/coqtop"))))))) diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 9b4071085..ead08b3eb 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -16,6 +16,8 @@ Implicit Types k l p q r : nat. Section Between. Variables P Q : nat -> Prop. + (** The [between] type expresses the concept + [forall i: nat, k <= i < l -> P i.]. *) Inductive between k : nat -> Prop := | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). @@ -47,6 +49,8 @@ Section Between. induction 1; auto with arith. Qed. + (** The [exists_between] type expresses the concept + [exists i: nat, k <= i < l /\ Q i]. *) Inductive exists_between k : nat -> Prop := | exists_S : forall l, exists_between k l -> exists_between k (S l) | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v index ef1737bf8..aeef9595d 100644 --- a/theories/Compat/Coq87.v +++ b/theories/Compat/Coq87.v @@ -15,3 +15,6 @@ and breaks at least fiat-crypto. *) Declare ML Module "omega_plugin". Unset Omega UseLocalDefs. + + +Set Typeclasses Axioms Are Instances. diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v index b1769da3d..31bc1cc31 100644 --- a/theories/FSets/FSetCompat.v +++ b/theories/FSets/FSetCompat.v @@ -165,13 +165,13 @@ End Backport_WSets. (** * From new Sets to new ones *) Module Backport_Sets - (E:OrderedType.OrderedType) - (M:MSetInterface.Sets with Definition E.t := E.t - with Definition E.eq := E.eq - with Definition E.lt := E.lt) - <: FSetInterface.S with Module E:=E. + (O:OrderedType.OrderedType) + (M:MSetInterface.Sets with Definition E.t := O.t + with Definition E.eq := O.eq + with Definition E.lt := O.lt) + <: FSetInterface.S with Module E:=O. - Include Backport_WSets E M. + Include Backport_WSets O M. Implicit Type s : t. Implicit Type x y : elt. @@ -182,21 +182,21 @@ Module Backport_Sets Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s := M.min_elt_spec1. Definition min_elt_2 : forall s x y, - min_elt s = Some x -> In y s -> ~ E.lt y x + min_elt s = Some x -> In y s -> ~ O.lt y x := M.min_elt_spec2. Definition min_elt_3 : forall s, min_elt s = None -> Empty s := M.min_elt_spec3. Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_spec1. Definition max_elt_2 : forall s x y, - max_elt s = Some x -> In y s -> ~ E.lt x y + max_elt s = Some x -> In y s -> ~ O.lt x y := M.max_elt_spec2. Definition max_elt_3 : forall s, max_elt s = None -> Empty s := M.max_elt_spec3. - Definition elements_3 : forall s, sort E.lt (elements s) + Definition elements_3 : forall s, sort O.lt (elements s) := M.elements_spec2. Definition choose_3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y := M.choose_spec3. Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' := @StrictOrder_Transitive _ _ M.lt_strorder. @@ -211,7 +211,7 @@ Module Backport_Sets [ apply EQ | apply LT | apply GT ]; auto. Defined. - Module E := E. + Module E := O. End Backport_Sets. @@ -342,13 +342,13 @@ End Update_WSets. (** * From old Sets to new ones. *) Module Update_Sets - (E:Orders.OrderedType) - (M:FSetInterface.S with Definition E.t := E.t - with Definition E.eq := E.eq - with Definition E.lt := E.lt) - <: MSetInterface.Sets with Module E:=E. + (O:Orders.OrderedType) + (M:FSetInterface.S with Definition E.t := O.t + with Definition E.eq := O.eq + with Definition E.lt := O.lt) + <: MSetInterface.Sets with Module E:=O. - Include Update_WSets E M. + Include Update_WSets O M. Implicit Type s : t. Implicit Type x y : elt. @@ -359,21 +359,21 @@ Module Update_Sets Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s := M.min_elt_1. Definition min_elt_spec2 : forall s x y, - min_elt s = Some x -> In y s -> ~ E.lt y x + min_elt s = Some x -> In y s -> ~ O.lt y x := M.min_elt_2. Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s := M.min_elt_3. Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_1. Definition max_elt_spec2 : forall s x y, - max_elt s = Some x -> In y s -> ~ E.lt x y + max_elt s = Some x -> In y s -> ~ O.lt x y := M.max_elt_2. Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s := M.max_elt_3. - Definition elements_spec2 : forall s, sort E.lt (elements s) + Definition elements_spec2 : forall s, sort O.lt (elements s) := M.elements_3. Definition choose_spec3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y := M.choose_3. Instance lt_strorder : StrictOrder lt. @@ -407,6 +407,6 @@ Module Update_Sets Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). Proof. intros; unfold compare; destruct M.compare; auto. Qed. - Module E := E. + Module E := O. End Update_Sets. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 037d37daf..053ed601f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -267,6 +267,13 @@ Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) format "'[' 'exists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. +Notation "'exists2' ' x , p & q" := (ex2 (fun x => p) (fun x => q)) + (at level 200, x strict pattern, p at level 200, right associativity) : type_scope. +Notation "'exists2' ' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) + (at level 200, x strict pattern, A at level 200, p at level 200, right associativity, + format "'[' 'exists2' '/ ' ' x : A , '/ ' '[' p & '/' q ']' ']'") + : type_scope. + (** Derived rules for universal quantification *) Section universal_quantification. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 5e8d2faa5..a9051e761 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -78,6 +78,33 @@ Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). Reserved Notation "{ x : A & P }" (at level 0, x at level 99). Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). +Reserved Notation "{ ' pat | P }" + (at level 0, pat strict pattern, format "{ ' pat | P }"). +Reserved Notation "{ ' pat | P & Q }" + (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). + +Reserved Notation "{ ' pat : A | P }" + (at level 0, pat strict pattern, format "{ ' pat : A | P }"). +Reserved Notation "{ ' pat : A | P & Q }" + (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + +Reserved Notation "{ ' pat : A & P }" + (at level 0, pat strict pattern, format "{ ' pat : A & P }"). +Reserved Notation "{ ' pat : A & P & Q }" + (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). + +(** Support for Gonthier-Ssreflect's "if c is pat then u else v" *) + +Module IfNotations. + +Notation "'if' c 'is' p 'then' u 'else' v" := + (match c with p => u | _ => v end) + (at level 200, p pattern at level 100). + +End IfNotations. + +(** Scopes *) + Delimit Scope type_scope with type. Delimit Scope function_scope with function. Delimit Scope core_scope with core. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 3b4f833a3..47e8a7558 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -53,6 +53,15 @@ Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. +Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. +Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : + type_scope. +Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : + type_scope. + Add Printing Let sig. Add Printing Let sig2. Add Printing Let sigT. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 5d0e7602a..47a971ef0 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -306,3 +306,10 @@ Ltac inversion_sigma_step := => induction_sigma_in_using H @eq_sigT2_rect end. Ltac inversion_sigma := repeat inversion_sigma_step. + +(** A version of [time] that works for constrs *) +Ltac time_constr tac := + let eval_early := match goal with _ => restart_timer end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) end in + ret. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index fbf992dbf..eae2c52de 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -2110,13 +2110,13 @@ Section Exists_Forall. {Exists l} + {~ Exists l}. Proof. intro Pdec. induction l as [|a l' Hrec]. - - right. now rewrite Exists_nil. + - right. abstract now rewrite Exists_nil. - destruct Hrec as [Hl'|Hl']. * left. now apply Exists_cons_tl. * destruct (Pdec a) as [Ha|Ha]. + left. now apply Exists_cons_hd. - + right. now inversion_clear 1. - Qed. + + right. abstract now inversion 1. + Defined. Inductive Forall : list A -> Prop := | Forall_nil : Forall nil @@ -2152,9 +2152,9 @@ Section Exists_Forall. - destruct Hrec as [Hl'|Hl']. + destruct (Pdec a) as [Ha|Ha]. * left. now apply Forall_cons. - * right. now inversion_clear 1. - + right. now inversion_clear 1. - Qed. + * right. abstract now inversion 1. + + right. abstract now inversion 1. + Defined. End One_predicate. @@ -2179,6 +2179,16 @@ Section Exists_Forall. * now apply Exists_cons_hd. Qed. + Lemma neg_Forall_Exists_neg (P:A->Prop) (l:list A) : + (forall x:A, {P x} + { ~ P x }) -> + ~ Forall P l -> + Exists (fun x => ~ P x) l. + Proof. + intro Dec. + apply Exists_Forall_neg; intros. + destruct (Dec x); auto. + Qed. + Lemma Forall_Exists_dec (P:A->Prop) : (forall x:A, {P x} + { ~ P x }) -> forall l:list A, @@ -2186,9 +2196,8 @@ Section Exists_Forall. Proof. intros Pdec l. destruct (Forall_dec P Pdec l); [left|right]; trivial. - apply Exists_Forall_neg; trivial. - intro x. destruct (Pdec x); [now left|now right]. - Qed. + now apply neg_Forall_Exists_neg. + Defined. Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) -> forall l, Forall P l -> Forall Q l. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index ac95ddd0c..82b04d132 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -221,13 +221,12 @@ Tactic Notation "extensionality" "in" hyp(H) := (* If we [subst H], things break if we already have another equation of the form [_ = H] *) destruct Heq; rename H_out into H. -(** Eta expansion follows from extensionality. *) +(** Eta expansion is built into Coq. *) Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : f = fun x => f x. Proof. intros. - extensionality x. reflexivity. Qed. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 90db10ef1..237d878bf 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -22,15 +22,13 @@ Open Scope program_scope. Lemma compose_id_left : forall A B (f : A -> B), id ∘ f = f. Proof. intros. - unfold id, compose. - symmetry. apply eta_expansion. + reflexivity. Qed. Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f. Proof. intros. - unfold id, compose. - symmetry ; apply eta_expansion. + reflexivity. Qed. Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), @@ -47,9 +45,7 @@ Hint Rewrite <- @compose_assoc : core. Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id. Proof. - unfold flip, compose. intros. - extensionality x ; extensionality y ; extensionality z. reflexivity. Qed. @@ -57,9 +53,7 @@ Qed. Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id. Proof. - simpl ; intros. - unfold prod_uncurry, prod_curry, compose. - extensionality x ; extensionality y ; extensionality z. + intros. reflexivity. Qed. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 2dd559a95..209c22f71 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -40,6 +40,11 @@ Section Sets_as_an_algebra. auto 6 with sets. Qed. + Theorem Empty_set_zero_right : forall X:Ensemble U, Union U X (Empty_set U) = X. + Proof. + auto 6 with sets. + Qed. + Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. Proof. unfold Add at 1; auto using Empty_set_zero with sets. @@ -131,6 +136,17 @@ Section Sets_as_an_algebra. elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. + Lemma Distributivity_l + : forall (A B C : Ensemble U), + Intersection U (Union U A B) C = + Union U (Intersection U A C) (Intersection U B C). + Proof. + intros A B C. + rewrite Intersection_commutative. + rewrite Distributivity. + f_equal; apply Intersection_commutative. + Qed. + Theorem Distributivity' : forall A B C:Ensemble U, Union U A (Intersection U B C) = @@ -251,6 +267,81 @@ Section Sets_as_an_algebra. intros; apply Definition_of_covers; auto with sets. Qed. + Lemma Disjoint_Intersection: + forall A s1 s2, Disjoint A s1 s2 -> Intersection A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * destruct H. + intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). + * intuition. + Qed. + + Lemma Intersection_Empty_set_l: + forall A s, Intersection A (Empty_set A) s = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Intersection_Empty_set_r: + forall A s, Intersection A s (Empty_set A) = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Seminus_Empty_set_l: + forall A s, Setminus A (Empty_set A) s = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Seminus_Empty_set_r: + forall A s, Setminus A s (Empty_set A) = s. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Setminus_Union_l: + forall A s1 s2 s3, + Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. inversion H0; intuition. + * intros x H. constructor; inversion H; inversion H0; intuition. + Qed. + + Lemma Setminus_Union_r: + forall A s1 s2 s3, + Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. constructor. intuition. contradict H1. intuition. + * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. + Qed. + + Lemma Setminus_Disjoint_noop: + forall A s1 s2, + Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. intuition. + * intros x H1. constructor; intuition. contradict H. + apply Inhabited_not_empty. + exists x. intuition. + Qed. + + Lemma Setminus_Included_empty: + forall A s1 s2, + Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. contradiction H2. intuition. + * intuition. + Qed. + End Sets_as_an_algebra. Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v index a0545c0a4..95c8336d2 100644 --- a/theories/Unicode/Utf8_core.v +++ b/theories/Unicode/Utf8_core.v @@ -10,10 +10,12 @@ (* Logic *) -Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) - (at level 200, x binder, y binder, right associativity) : type_scope. -Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) - (at level 200, x binder, y binder, right associativity) : type_scope. +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' ∀ x .. y ']' , P") : type_scope. +Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' ∃ x .. y ']' , P") : type_scope. Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope. Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope. @@ -25,5 +27,6 @@ Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope. Notation "x ≠y" := (x <> y) (at level 70) : type_scope. (* Abstraction *) -Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) - (at level 200, x binder, y binder, right associativity). +Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' 'λ' x .. y ']' , t"). diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 4ee6efec0..727fd3ec3 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -34,11 +34,10 @@ LOCAL := $(COQMF_LOCAL) COQLIB := $(COQMF_COQLIB) DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) -CAMLP4 := $(COQMF_CAMLP4) -CAMLP4O := $(COQMF_CAMLP4O) -CAMLP4BIN := $(COQMF_CAMLP4BIN) -CAMLP4LIB := $(COQMF_CAMLP4LIB) -CAMLP4OPTIONS := $(COQMF_CAMLP4OPTIONS) +CAMLP5O := $(COQMF_CAMLP5O) +CAMLP5BIN := $(COQMF_CAMLP5BIN) +CAMLP5LIB := $(COQMF_CAMLP5LIB) +CAMLP5OPTIONS := $(COQMF_CAMLP5OPTIONS) CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) @@ -87,7 +86,6 @@ COQCHK ?= "$(COQBIN)coqchk" COQDEP ?= "$(COQBIN)coqdep" GALLINA ?= "$(COQBIN)gallina" COQDOC ?= "$(COQBIN)coqdoc" -COQMKTOP ?= "$(COQBIN)coqmktop" COQMKFILE ?= "$(COQBIN)coq_makefile" # Timing scripts @@ -120,6 +118,8 @@ CAMLPKGS ?= # Option for making timing files TIMING?= +# Option for changing sorting of timing output file +TIMING_SORT_BY ?= auto # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -168,33 +168,30 @@ endif COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) COQCHKFLAGS?=-silent -o $(COQLIBS) -COQDOCFLAGS?=-interpolate -utf8 $(COQLIBS_NOML) +COQDOCFLAGS?=-interpolate -utf8 +COQDOCLIBS?=$(COQLIBS_NOML) # The version of Coq being run and the version of coq_makefile that # generated this makefile -COQ_VERSION:=$(shell $(COQC) --print-version | cut -d ' ' -f 1) +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") -CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) $(OCAML_API_FLAGS) +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP5LIB) # ocamldoc fails with unknown argument otherwise CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) # FIXME This should be generated by Coq GRAMMARS:=grammar.cma -ifeq ($(CAMLP4),camlp5) -CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo -else -CAMLP4EXTEND= -endif +CAMLP5EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib 2> /dev/null) ifeq (,$(CAMLLIB)) PP=$(error "Cannot find the 'ocamlfind' binary used to build Coq ($(OCAMLFIND)). Pre-compiled binary packages of Coq do not support compiling plugins this way. Please download the sources of Coq and run the Windows build script.") else -PP:=-pp '$(CAMLP4O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl' +PP:=-pp '$(CAMLP5O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" $(CAMLP5EXTEND) $(GRAMMARS) $(CAMLP5OPTIONS) -impl' endif ifneq (,$(TIMING)) @@ -228,8 +225,9 @@ COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)toploop) # We here define a bunch of variables about the files being part of the # Coq project in order to ease the writing of build target and build rules +VDFILE := .coqdeps + ALLSRCFILES := \ - $(VFILES) \ $(ML4FILES) \ $(MLFILES) \ $(MLPACKFILES) \ @@ -289,13 +287,15 @@ ALLNATIVEFILES = \ $(OBJFILES:.o=.cmi) \ $(OBJFILES:.o=.cmx) \ $(OBJFILES:.o=.cmxs) -# trick: wildcard filters out non-existing files -NATIVEFILESTOINSTALL = $(foreach f, $(ALLNATIVEFILES), $(wildcard $f)) +# trick: wildcard filters out non-existing files, so that `install` doesn't show +# warnings and `clean` doesn't pass to rm a list of files that is too long for +# the shell. +NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) FILESTOINSTALL = \ $(VOFILES) \ $(VFILES) \ $(GLOBFILES) \ - $(NATIVEFILESTOINSTALL) \ + $(NATIVEFILES) \ $(CMIFILESTOINSTALL) BYTEFILESTOINSTALL = \ $(CMOFILESTOINSTALL) \ @@ -307,7 +307,7 @@ else DO_NATDYNLINK = endif -ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES) $(VDFILE)) # Compilation targets ######################################################### @@ -332,7 +332,7 @@ make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: print-pretty-timed:: $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) print-pretty-timed-diff:: - $(HIDE)$(COQMAKE_BOTH_TIME_FILES) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) ifeq (,$(BEFORE)) print-pretty-single-time-diff:: @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' @@ -344,7 +344,7 @@ print-pretty-single-time-diff:: $(HIDE)false else print-pretty-single-time-diff:: - $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) $(BEFORE) $(AFTER) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --sort-by=$(TIMING_SORT_BY) $(BEFORE) $(AFTER) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) endif endif pretty-timed: @@ -377,7 +377,7 @@ bytefiles: $(CMOFILES) $(CMAFILES) optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) .PHONY: optfiles -# FIXME, see Ralph's bugreport +# FIXME, see Ralf's bugreport quick: $(VOFILES:.vo=.vio) .PHONY: quick @@ -386,13 +386,25 @@ vio2vo: -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) .PHONY: vio2vo +quick2vo: + $(HIDE)make -j $(J) quick + $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ + viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ + if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ + done); \ + echo "VIO2VO: $$VIOFILES"; \ + if [ -n "$$VIOFILES" ]; then \ + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $$VIOFILES; \ + fi +.PHONY: quick2vo + checkproofs: $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) \ -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) .PHONY: checkproofs validate: $(VOFILES) - $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(notdir $(^:.vo=)) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $^ .PHONY: validate only: $(TGTS) @@ -432,7 +444,7 @@ all.pdf: $(VFILES) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` # FIXME: not quite right, since the output name is different -gallinahtml: GAL=g +gallinahtml: GAL=-g gallinahtml: html all-gal.ps: GAL=-g @@ -535,7 +547,7 @@ clean:: $(HIDE)rm -f $(CMOFILES:.cmo=.o) $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) $(HIDE)rm -f $(ALLDFILES) - $(HIDE)rm -f $(ALLNATIVEFILES) + $(HIDE)rm -f $(NATIVEFILES) $(HIDE)find . -name .coq-native -type d -empty -delete $(HIDE)rm -f $(VOFILES) $(HIDE)rm -f $(VOFILES:.vo=.vio) @@ -563,7 +575,7 @@ cleanall:: clean archclean:: @# Extension point $(SHOW)'CLEAN *.cmx *.o' - $(HIDE)rm -f $(ALLNATIVEFILES) + $(HIDE)rm -f $(NATIVEFILES) $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) .PHONY: archclean @@ -712,9 +724,9 @@ $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack $(SHOW)'COQDEP $<' $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) -$(addsuffix .d,$(VFILES)): %.v.d: %.v - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEP) $(COQLIBS) -dyndep var -c "$<" $(redir_if_ok) +$(VDFILE).d: $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) $(COQLIBS) -dyndep var -c $(VFILES) $(redir_if_ok) # Misc ######################################################################## @@ -735,11 +747,10 @@ printenv:: @echo 'COQLIB = $(COQLIB)' @echo 'DOCDIR = $(DOCDIR)' @echo 'OCAMLFIND = $(OCAMLFIND)' - @echo 'CAMLP4 = $(CAMLP4)' - @echo 'CAMLP4O = $(CAMLP4O)' - @echo 'CAMLP4BIN = $(CAMLP4BIN)' - @echo 'CAMLP4LIB = $(CAMLP4LIB)' - @echo 'CAMLP4OPTIONS = $(CAMLP4OPTIONS)' + @echo 'CAMLP5O = $(CAMLP5O)' + @echo 'CAMLP5BIN = $(CAMLP5BIN)' + @echo 'CAMLP5LIB = $(CAMLP5LIB)' + @echo 'CAMLP5OPTIONS = $(CAMLP5OPTIONS)' @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index a5a5fa8fe..0d24332f1 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -10,6 +10,20 @@ STRIP_REG = re.compile('^(coq/|contrib/|)(?:theories/|src/)?') STRIP_REP = r'\1' INFINITY = '\xe2\x88\x9e' +def parse_args(argv, USAGE, HELP_STRING): + sort_by = 'auto' + if any(arg.startswith('--sort-by=') for arg in argv[1:]): + sort_by = [arg for arg in argv[1:] if arg.startswith('--sort-by=')][-1][len('--sort-by='):] + args = [arg for arg in argv if not arg.startswith('--sort-by=')] + if len(args) < 3 or '--help' in args[1:] or '-h' in args[1:] or sort_by not in ('auto', 'absolute', 'diff'): + print(USAGE) + if '--help' in args[1:] or '-h' in args[1:]: + print(HELP_STRING) + if len(args) == 2: sys.exit(0) + sys.exit(1) + return sort_by, args + + def reformat_time_string(time): seconds, milliseconds = time.split('.') seconds = int(seconds) @@ -108,6 +122,7 @@ def format_percentage(num, signed=True): return sign + '%d.%02d%%' % (whole_part, frac_part) def make_diff_table_string(left_times_dict, right_times_dict, + sort_by='auto', descending=True, left_tag="After", tag="File Name", right_tag="Before", with_percent=True, change_tag="Change", percent_change_tag="% Change"): @@ -125,10 +140,15 @@ def make_diff_table_string(left_times_dict, right_times_dict, if rseconds != 0 else (INFINITY if lseconds > 0 else 'N/A'))) for name, lseconds, rseconds in prediff_times) # update to sort by approximate difference, first - get_key = make_sorting_key(all_names_dict, descending=descending) - all_names_dict = dict((name, (fix_sign_for_sorting(int(abs(to_seconds(diff_times_dict[name]))), descending=descending), get_key(name))) - for name in all_names_dict.keys()) - names = sorted(all_names_dict.keys(), key=all_names_dict.get) + get_key_abs = make_sorting_key(all_names_dict, descending=descending) + get_key_diff = (lambda name: fix_sign_for_sorting(int(abs(to_seconds(diff_times_dict[name]))), descending=descending)) + if sort_by == 'absolute': + get_key = get_key_abs + elif sort_by == 'diff': + get_key = get_key_diff + else: # sort_by == 'auto' + get_key = (lambda name: (get_key_diff(name), get_key_abs(name))) + names = sorted(all_names_dict.keys(), key=get_key) #names = get_sorted_file_list_from_times_dict(all_names_dict, descending=descending) # set the widths of each of the columns by the longest thing to go in that column left_sum = sum_times(left_times_dict.values()) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 2feaaa04c..1e1862220 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -27,16 +27,8 @@ let rec print_prefix_list sep = function | x :: l -> print sep; print x; print_prefix_list sep l | [] -> () -let usage () = - output_string stderr "Usage summary:\ -\n\ -\ncoq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}]\ -\n ... [any] ... [-extra[-phony] result dependencies command]\ -\n ... [-I dir] ... [-R physicalpath logicalpath]\ -\n ... [-Q physicalpath logicalpath] ... [VARIABLE = value]\ -\n ... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file]\ -\n [-h] [--help]\ -\n\ +let usage_common () = + output_string stderr "\ \n[file.v]: Coq file to be compiled\ \n[file.ml[i4]?]: Objective Caml file to be compiled\ \n[file.ml{lib,pack}]: ocamlbuild file that describes a Objective Caml\ @@ -65,10 +57,28 @@ let usage () = \n[-install opt]: where opt is \"user\" to force install into user directory,\ \n \"none\" to build a makefile with no install target or\ \n \"global\" to force install in $COQLIB directory\ +\n" + +let usage_coq_project () = + output_string stderr "Available arguments:"; + usage_common (); + exit 1 + +let usage_coq_makefile () = + output_string stderr "Usage summary:\ +\n\ +\ncoq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}]\ +\n ... [any] ... [-extra[-phony] result dependencies command]\ +\n ... [-I dir] ... [-R physicalpath logicalpath]\ +\n ... [-Q physicalpath logicalpath] ... [VARIABLE = value]\ +\n ... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file]\ +\n [-h] [--help]\ +\n"; + usage_common (); + output_string stderr "\ \n[-f file]: take the contents of file as arguments\ -\n[-o file]: output should go in file file\ +\n[-o file]: output should go in file file (recommended)\ \n Output file outside the current directory is forbidden.\ -\n[-bypass-API]: when compiling plugins, bypass Coq API\ \n[-h]: print this usage summary\ \n[--help]: equivalent to [-h]\n"; exit 1 @@ -114,7 +124,7 @@ let read_whole_file s = close_in ic; Buffer.contents b -let quote s = if String.contains s ' ' then "'" ^ s ^ "'" else s +let quote s = if String.contains s ' ' || CString.is_empty s then "'" ^ s ^ "'" else s let generate_makefile oc conf_file local_file args project = let makefile_template = @@ -199,16 +209,10 @@ let windrive s = else s ;; -let generate_conf_coq_config oc args bypass_API = +let generate_conf_coq_config oc args = section oc "Coq configuration."; - let src_dirs = if bypass_API - then Coq_config.all_src_dirs - else Coq_config.api_dirs @ Coq_config.plugins_dirs in + let src_dirs = Coq_config.all_src_dirs in Envars.print_config ~prefix_var_name:"COQMF_" oc src_dirs; - if bypass_API then - Printf.fprintf oc "OCAML_API_FLAGS=\n" - else - Printf.fprintf oc "OCAML_API_FLAGS=-open API\n"; fprintf oc "COQMF_WINDRIVE=%s\n" (windrive Coq_config.coqlib) ;; @@ -267,7 +271,7 @@ let generate_conf oc project args = fprintf oc "# %s\n\n" (String.concat " " (List.map quote args)); generate_conf_files oc project; generate_conf_includes oc project; - generate_conf_coq_config oc args project.bypass_API; + generate_conf_coq_config oc args; generate_conf_defs oc project; generate_conf_doc oc project; generate_conf_extra_target oc project.extra_targets; @@ -380,8 +384,8 @@ let share_prefix s1 s2 = | _ -> false let _ = + let _fhandle = Feedback.(add_feeder (console_feedback_listener Format.err_formatter)) in let prog, args = - if Array.length Sys.argv = 1 then usage (); let args = Array.to_list Sys.argv in let prog = List.hd args in prog, List.tl args in @@ -392,7 +396,7 @@ let _ = let project = try cmdline_args_to_project ~curdir:Filename.current_dir_name args - with Parsing_error s -> prerr_endline s; usage () in + with Parsing_error s -> prerr_endline s; usage_coq_project () in if only_destination <> None then begin destination_of project (Option.get only_destination); diff --git a/tools/coqdep.ml b/tools/coqdep.ml index fd4be08b1..ca14b11bc 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -455,7 +455,7 @@ let usage () = eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -suffix s : \n"; eprintf " -slash : deprecated, no effect\n"; - eprintf " -dyndep (opt|byte|both|no|var) : set how dependencies over ML modules are printed"; + eprintf " -dyndep (opt|byte|both|no|var) : set how dependencies over ML modules are printed\n"; exit 1 let split_period = Str.split (Str.regexp (Str.quote ".")) @@ -539,4 +539,4 @@ let _ = coqdep () with CErrors.UserError(s,p) -> let pp = (match s with | None -> p | Some s -> Pp.(str s ++ str ": " ++ p)) in - Feedback.msg_error pp + Format.eprintf "%a@\n%!" Pp.pp_with pp diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml deleted file mode 100644 index 950ed53cc..000000000 --- a/tools/coqmktop.ml +++ /dev/null @@ -1,314 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** {1 Coqmktop} *) - -(** coqmktop is a script to link Coq, analogous to ocamlmktop. - The command line contains options specific to coqmktop, options for the - Ocaml linker and files to link (in addition to the default Coq files). *) - -(** {6 Utilities} *) - -(** Split a string at each blank -*) -let split_list = - let spaces = Str.regexp "[ \t\n]+" in - fun str -> Str.split spaces str - -[@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -[@@@ocaml.warning "+3"] - -let (/) = Filename.concat - -(** Which user files do we support (and propagate to ocamlopt) ? -*) -let supported_suffix f = match CUnix.get_extension f with - | ".ml" | ".cmx" | ".cmo" | ".cmxa" | ".cma" | ".c" -> true - | _ -> false - -let supported_flambda_option f = List.mem f Coq_config.flambda_flags - -(** From bytecode extension to native -*) -let native_suffix f = match CUnix.get_extension f with - | ".cmo" -> (Filename.chop_suffix f ".cmo") ^ ".cmx" - | ".cma" -> (Filename.chop_suffix f ".cma") ^ ".cmxa" - | ".a" -> f - | _ -> failwith ("File "^f^" has not extension .cmo, .cma or .a") - -(** Transforms a file name in the corresponding Caml module name. -*) -let module_of_file name = - capitalize (try Filename.chop_extension name with Invalid_argument _ -> name) - -(** Run a command [prog] with arguments [args]. - We do not use [Sys.command] anymore, see comment in [CUnix.sys_command]. -*) -let run_command prog args = - match CUnix.sys_command prog args with - | Unix.WEXITED 127 -> failwith ("no such command "^prog) - | Unix.WEXITED n -> n - | Unix.WSIGNALED n -> failwith (prog^" killed by signal "^string_of_int n) - | Unix.WSTOPPED n -> failwith (prog^" stopped by signal "^string_of_int n) - - - -(** {6 Coqmktop options} *) - -let opt = ref false -let top = ref false -let echo = ref false -let no_start = ref false - -let is_ocaml4 = Coq_config.caml_version.[0] <> '3' - -(** {6 Includes options} *) - -(** Since the Coq core .cma are given with their relative paths - (e.g. "lib/clib.cma"), we only need to include directories mentionned in - the temp main ml file below (for accessing the corresponding .cmi). *) - -let std_includes basedir = - let rebase d = match basedir with None -> d | Some base -> base / d in - ["-I"; rebase "."; - "-I"; rebase "lib"; - "-I"; rebase "vernac"; (* For Mltop *) - "-I"; rebase "toplevel"; - "-I"; rebase "kernel/byterun"; - "-I"; Envars.camlp4lib () ] @ - (if is_ocaml4 then ["-I"; "+compiler-libs"] else []) - -(** For the -R option, visit all directories under [dir] and add - corresponding -I to the [opts] option list (in reversed order) *) -let incl_all_subdirs dir opts = - let l = ref opts in - let add f = l := f :: "-I" :: !l in - let rec traverse dir = - if Sys.file_exists dir && Sys.is_directory dir then - let () = add dir in - let subdirs = try Sys.readdir dir with any -> [||] in - Array.iter (fun f -> traverse (dir/f)) subdirs - in - traverse dir; !l - - -(** {6 Objects to link} *) - -(** NB: dynlink is now always linked, it is used for loading plugins - and compiled vm code (see native-compiler). We now reject platforms - with ocamlopt but no dynlink.cmxa during ./configure, and give - instructions there about how to build a dummy dynlink.cmxa, - cf. dev/dynlink.ml. *) - -(** OCaml + CamlpX libraries *) - -let ocaml_libs = ["str.cma";"unix.cma";"nums.cma";"dynlink.cma";"threads.cma"] -let camlp4_libs = ["gramlib.cma"] -let libobjs = ocaml_libs @ camlp4_libs - -(** Toplevel objects *) - -let ocaml_topobjs = - if is_ocaml4 then - ["ocamlcommon.cma";"ocamlbytecomp.cma";"ocamltoplevel.cma"] - else - ["toplevellib.cma"] - -let camlp4_topobjs = ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"] - -let topobjs = ocaml_topobjs @ camlp4_topobjs - -(** Coq Core objects *) - -let copts = (split_list Coq_config.osdeplibs) @ (split_list Tolink.copts) -let core_objs = split_list Tolink.core_objs -let core_libs = split_list Tolink.core_libs - -(** Build the list of files to link and the list of modules names -*) -let files_to_link userfiles = - let top = if !top then topobjs else [] in - let modules = List.map module_of_file (top @ core_objs @ userfiles) in - let objs = libobjs @ top @ core_libs in - let objs' = (if !opt then List.map native_suffix objs else objs) @ userfiles - in (modules, objs') - - -(** {6 Parsing of the command-line} *) - -let usage () = - prerr_endline "Usage: coqmktop <options> <ocaml options> files\ -\nFlags are:\ -\n -coqlib dir Specify where the Coq object files are\ -\n -ocamlfind dir Specify where the ocamlfind binary is\ -\n -camlp4bin dir Specify where the Camlp4/5 binaries are\ -\n -o exec-file Specify the name of the resulting toplevel\ -\n -boot Run in boot mode\ -\n -echo Print calls to external commands\ -\n -opt Compile in native code\ -\n -top Build Coq on a OCaml toplevel (incompatible with -opt)\ -\n -R dir Add recursively dir to OCaml search path\ -\n"; - exit 1 - -let parse_args () = - let rec parse (op,fl) = function - | [] -> List.rev op, List.rev fl - - (* Directories *) - | "-coqlib" :: d :: rem -> - Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem - | "-ocamlfind" :: d :: rem -> - Flags.ocamlfind_spec := true; Flags.ocamlfind := d ; parse (op,fl) rem - | "-camlp4bin" :: d :: rem -> - Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem - | "-R" :: d :: rem -> parse (incl_all_subdirs d op,fl) rem - | ("-coqlib"|"-camlbin"|"-camlp4bin"|"-R") :: [] -> usage () - - (* Boolean options of coqmktop *) - | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem - | "-opt" :: rem -> opt := true ; parse (op,fl) rem - | "-top" :: rem -> top := true ; parse (op,fl) rem - | "-no-start" :: rem -> no_start:=true; parse (op, fl) rem - | "-echo" :: rem -> echo := true ; parse (op,fl) rem - - (* Extra options with arity 0 or 1, directly passed to ocamlc/ocamlopt *) - | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem -> - parse (o::op,fl) rem - | ("-cclib"|"-ccopt"|"-I"|"-o"|"-w" as o) :: rem' -> - begin - match rem' with - | a :: rem -> parse (a::o::op,fl) rem - | [] -> usage () - end - - | ("-h"|"-help"|"--help") :: _ -> usage () - | f :: rem when supported_flambda_option f -> parse (op,fl) rem - | f :: rem when supported_suffix f -> parse (op,f::fl) rem - | f :: _ -> prerr_endline ("Don't know what to do with " ^ f); exit 1 - in - parse ([],[]) (List.tl (Array.to_list Sys.argv)) - - -(** {6 Temporary main file} *) - -(** remove the temporary main file -*) -let clean file = - let rm f = if Sys.file_exists f then Sys.remove f in - let basename = Filename.chop_suffix file ".ml" in - if not !echo then begin - rm file; - rm (basename ^ ".o"); - rm (basename ^ ".cmi"); - rm (basename ^ ".cmo"); - rm (basename ^ ".cmx") - end - -(** Initializes the kind of loading in the main program -*) -let declare_loading_string () = - if not !top then - "Mltop.remove ();;" - else - "begin try\ -\n (* Enable rectypes in the toplevel if it has the directive #rectypes *)\ -\n begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\ -\n | Toploop.Directive_none f -> f ()\ -\n | _ -> ()\ -\n end\ -\n with\ -\n | Not_found -> ()\ -\n end;;\ -\n\ -\n let ppf = Format.std_formatter;;\ -\n Mltop.set_top\ -\n {Mltop.load_obj=\ -\n (fun f -> if not (Topdirs.load_file ppf f)\ -\n then CErrors.user_err Pp.(str (\"Could not load plugin \"^f)));\ -\n Mltop.use_file=Topdirs.dir_use ppf;\ -\n Mltop.add_dir=Topdirs.dir_directory;\ -\n Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\ -\n" - -(** create a temporary main file to link -*) -let create_tmp_main_file modules = - let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in - try - (* Add the pre-linked modules *) - output_string oc "List.iter Mltop.add_known_module [\""; - output_string oc (String.concat "\";\"" modules); - output_string oc "\"];;\n"; - (* Initializes the kind of loading *) - output_string oc (declare_loading_string()); - (* Start the toplevel loop *) - if not !no_start then output_string oc "Coqtop.start();;\n"; - close_out oc; - main_name - with reraise -> - clean main_name; raise reraise - -(* TODO: remove once OCaml 4.04 is adopted *) -let split_on_char sep s = - let r = ref [] in - let j = ref (String.length s) in - for i = String.length s - 1 downto 0 do - if s.[i] = sep then begin - r := String.sub s (i + 1) (!j - i - 1) :: !r; - j := i - end - done; - String.sub s 0 !j :: !r - -(** {6 Main } *) - -let main () = - let (options, userfiles) = parse_args () in - (* Directories: *) - let () = Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)) in - let basedir = if !Flags.boot then None else Some (Envars.coqlib ()) in - (* Which ocaml compiler to invoke *) - let prog = if !opt then "opt" else "ocamlc" in - (* Which arguments ? *) - if !opt && !top then failwith "no custom toplevel in native code!"; - let flags = if !opt then Coq_config.flambda_flags else Coq_config.vmbyteflags in - let topstart = if !top then [ "topstart.cmo" ] else [] in - let (modules, tolink) = files_to_link userfiles in - let main_file = create_tmp_main_file modules in - try - (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - - With the coq .cma, we MUST use the -linkall option. *) - let coq_camlflags = - List.filter ((<>) "") (split_on_char ' ' Coq_config.caml_flags) in - let args = - coq_camlflags @ "-linkall" :: "-w" :: "-31" :: flags @ copts @ options @ - (std_includes basedir) @ tolink @ [ main_file ] @ topstart - in - if !echo then begin - let command = String.concat " " (Envars.ocamlfind ()::prog::args) in - print_endline command; - print_endline - ("(command length is " ^ - (string_of_int (String.length command)) ^ " characters)"); - flush Pervasives.stdout - end; - let exitcode = run_command (Envars.ocamlfind ()) (prog::args) in - clean main_file; - exitcode - with reraise -> clean main_file; raise reraise - -let pr_exn = function - | Failure msg -> msg - | Unix.Unix_error (err,fn,arg) -> fn^" "^arg^" : "^Unix.error_message err - | any -> Printexc.to_string any - -let _ = - try exit (main ()) - with any -> Printf.eprintf "Error: %s\n" (pr_exn any); exit 1 diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index e1d1c60d7..f4777c4fb 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -14,7 +14,7 @@ type party = { sock : Unix.file_descr; cout : out_channel; mutable tokens : int; - priority : Flags.priority; + priority : priority; } let answer party msg = @@ -42,10 +42,10 @@ end = struct let is_empty q = !q = [] let rec split acc = function | [] -> List.rev acc, [] - | (_, { priority = Flags.Low }) :: _ as l -> List.rev acc, l + | (_, { priority = Low }) :: _ as l -> List.rev acc, l | x :: xs -> split (x :: acc) xs let push (_,{ priority } as item) q = - if priority = Flags.Low then q := !q @ [item] + if priority = Low then q := !q @ [item] else let high, low = split [] !q in q := high @ (item :: low) @@ -148,7 +148,7 @@ let check_alive s = | Some s -> let cout = Unix.out_channel_of_descr s in set_binary_mode_out cout true; - output_string cout (print_request (Hello Flags.Low)); flush cout; + output_string cout (print_request (Hello Low)); flush cout; output_string cout (print_request Ping); flush cout; begin match Unix.select [s] [] [] 1.0 with | [s],_,_ -> diff --git a/tools/make-both-single-timing-files.py b/tools/make-both-single-timing-files.py index 2d33503c3..32c52c7a1 100755 --- a/tools/make-both-single-timing-files.py +++ b/tools/make-both-single-timing-files.py @@ -3,16 +3,10 @@ import sys from TimeFileMaker import * if __name__ == '__main__': - USAGE = 'Usage: %s AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] + USAGE = 'Usage: %s [--sort-by=auto|absolute|diff] AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] HELP_STRING = r'''Formats timing information from the output of two invocations of `coqc -time` into a sorted table''' - if len(sys.argv) < 3 or '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: - print(USAGE) - if '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: - print(HELP_STRING) - if len(sys.argv) == 2: sys.exit(0) - sys.exit(1) - else: - left_dict = get_single_file_times(sys.argv[1]) - right_dict = get_single_file_times(sys.argv[2]) - table = make_diff_table_string(left_dict, right_dict, tag="Code") - print_or_write_table(table, sys.argv[3:]) + sort_by, args = parse_args(sys.argv, USAGE, HELP_STRING) + left_dict = get_single_file_times(args[1]) + right_dict = get_single_file_times(args[2]) + table = make_diff_table_string(left_dict, right_dict, tag="Code", sort_by=sort_by) + print_or_write_table(table, args[3:]) diff --git a/tools/make-both-time-files.py b/tools/make-both-time-files.py index 69ec5a663..f730a8d6b 100755 --- a/tools/make-both-time-files.py +++ b/tools/make-both-time-files.py @@ -3,20 +3,14 @@ import sys from TimeFileMaker import * if __name__ == '__main__': - USAGE = 'Usage: %s AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] + USAGE = 'Usage: %s [--sort-by=auto|absolute|diff] AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] HELP_STRING = r'''Formats timing information from the output of two invocations of `make TIMED=1` into a sorted table. The input is expected to contain lines in the format: FILE_NAME (...user: NUMBER_IN_SECONDS...) ''' - if len(sys.argv) < 3 or '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: - print(USAGE) - if '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: - print(HELP_STRING) - if len(sys.argv) == 2: sys.exit(0) - sys.exit(1) - else: - left_dict = get_times(sys.argv[1]) - right_dict = get_times(sys.argv[2]) - table = make_diff_table_string(left_dict, right_dict) - print_or_write_table(table, sys.argv[3:]) + sort_by, args = parse_args(sys.argv, USAGE, HELP_STRING) + left_dict = get_times(args[1]) + right_dict = get_times(args[2]) + table = make_diff_table_string(left_dict, right_dict, sort_by=sort_by) + print_or_write_table(table, args[3:]) diff --git a/tools/md5sum.ml b/tools/md5sum.ml new file mode 100644 index 000000000..2fdcacc83 --- /dev/null +++ b/tools/md5sum.ml @@ -0,0 +1,24 @@ +let get_content file = + let ic = open_in_bin file in + let buf = Buffer.create 2048 in + let rec fill () = + match input_char ic with + | '\r' -> fill () (* NOTE: handles the case on Windows where the + git checkout has included return characters. + See: https://github.com/coq/coq/pull/6305 *) + | c -> Buffer.add_char buf c; fill () + | exception End_of_file -> close_in ic; Buffer.contents buf + in + fill () + +let () = + match Sys.argv with + | [|_; file|] -> + let content = get_content file in + let md5 = Digest.to_hex (Digest.string content) in + print_string (md5 ^ " " ^ file) + | _ -> + prerr_endline "Error: This program needs exactly one parameter."; + prerr_endline "Usage: ocaml md5sum.ml <FILE>"; + prerr_endline "Print MD5 (128-bit) checksum of the file content modulo \\r."; + exit 1 diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml new file mode 100644 index 000000000..5b73471c5 --- /dev/null +++ b/toplevel/coqargs.ml @@ -0,0 +1,575 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s)) + +let fatal_error ?extra exn = + Topfmt.print_err_exn ?extra exn; + let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in + exit exit_code + +let error_missing_arg s = + prerr_endline ("Error: extra argument expected after option "^s); + prerr_endline "See -help for the syntax of supported options"; + exit 1 + +(******************************************************************************) +(* Imperative effects! This must be fixed at some point. *) +(******************************************************************************) +let set_worker_id opt s = + assert (s <> "master"); + Flags.async_proofs_worker_id := s + +let set_type_in_type () = + let typing_flags = Environ.typing_flags (Global.env ()) in + Global.set_typing_flags { typing_flags with Declarations.check_universes = false } + +(******************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo +type color = [`ON | `AUTO | `OFF] + +type coq_cmdopts = { + + load_init : bool; + load_rcfile : bool; + rcfile : string option; + + ml_includes : string list; + vo_includes : (string * Names.DirPath.t * bool) list; + vo_requires : (string * string option * bool option) list; + (* None = No Import; Some false = Import; Some true = Export *) + + (* XXX: Fusion? *) + batch_mode : bool; + compilation_mode : compilation_mode; + + toplevel_name : Names.DirPath.t; + toploop : string option; + + compile_list: (string * bool) list; (* bool is verbosity *) + compilation_output_name : string option; + + load_vernacular_list : (string * bool) list; + + vio_checking: bool; + vio_tasks : (int list * string) list; + vio_files : string list; + vio_files_j : int; + + color : color; + + impredicative_set : Declarations.set_predicativity; + stm_flags : Stm.AsyncOpts.stm_opt; + debug : bool; + time : bool; + + filter_opts : bool; + + glob_opt : bool; + + memory_stat : bool; + print_tags : bool; + print_where : bool; + print_config: bool; + output_context : bool; + + inputstate : string option; + outputstate : string option; + +} + +let init_args = { + + load_init = true; + load_rcfile = true; + rcfile = None; + + ml_includes = []; + vo_includes = []; + vo_requires = []; + + batch_mode = false; + compilation_mode = BuildVo; + + toplevel_name = Names.(DirPath.make [Id.of_string "Top"]); + toploop = None; + + compile_list = []; + compilation_output_name = None; + + load_vernacular_list = []; + + vio_checking = false; + vio_tasks = []; + vio_files = []; + vio_files_j = 0; + + color = `AUTO; + + impredicative_set = Declarations.PredicativeSet; + stm_flags = Stm.AsyncOpts.default_opts; + debug = false; + time = false; + + filter_opts = false; + + glob_opt = false; + + memory_stat = false; + print_tags = false; + print_where = false; + print_config = false; + output_context = false; + + inputstate = None; + outputstate = None; +} + +(******************************************************************************) +(* Functional arguments *) +(******************************************************************************) +let add_ml_include opts s = + { opts with ml_includes = s :: opts.ml_includes } + +let add_vo_include opts d p implicit = + let p = Libnames.dirpath_of_string p in + { opts with vo_includes = (d, p, implicit) :: opts.vo_includes } + +let add_vo_require opts d p export = + { opts with vo_requires = (d, p, export) :: opts.vo_requires } + +let add_compat_require opts v = + match v with + | Flags.V8_5 -> add_vo_require opts "Coq.Compat.Coq85" None (Some false) + | Flags.V8_6 -> add_vo_require opts "Coq.Compat.Coq86" None (Some false) + | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false) + | Flags.VOld | Flags.Current -> opts + +let set_batch_mode opts = + Flags.quiet := true; + System.trust_file_cache := false; + { opts with batch_mode = true } + +let add_compile opts verbose s = + let opts = set_batch_mode opts in + if not opts.glob_opt then Dumpglob.dump_to_dotglob (); + (** make the file name explicit; needed not to break up Coq loadpath stuff. *) + let s = + let open Filename in + if is_implicit s + then concat current_dir_name s + else s + in + { opts with compile_list = (s,verbose) :: opts.compile_list } + +let add_load_vernacular opts verb s = + { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list } + +let add_vio_task opts f = + let opts = set_batch_mode opts in + { opts with vio_tasks = f :: opts.vio_tasks } + +let add_vio_file opts f = + let opts = set_batch_mode opts in + { opts with vio_files = f :: opts.vio_files } + +let set_vio_checking_j opts opt j = + try { opts with vio_files_j = int_of_string j } + with Failure _ -> + prerr_endline ("The first argument of " ^ opt ^ " must the number"); + prerr_endline "of concurrent workers to be used (a positive integer)."; + prerr_endline "Makefiles generated by coq_makefile should be called"; + prerr_endline "setting the J variable like in 'make vio2vo J=3'"; + exit 1 + +(** Options for proof general *) +let set_emacs opts = + if not (Option.is_empty opts.toploop) then + CErrors.user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop"); + Coqloop.print_emacs := true; + Printer.enable_goal_tags_printing := true; + { opts with color = `OFF } + +let set_color opts = function +| "yes" | "on" -> { opts with color = `ON } +| "no" | "off" -> { opts with color = `OFF } +| "auto" -> { opts with color = `AUTO } +| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1 + +let warn_deprecated_inputstate = + CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" + (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") + +let set_inputstate opts s = + warn_deprecated_inputstate (); + { opts with inputstate = Some s } + +let warn_deprecated_outputstate = + CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" + (fun () -> + Pp.strbrk "The outputstate option is deprecated and discouraged.") + +let set_outputstate opts s = + warn_deprecated_outputstate (); + { opts with outputstate = Some s } + +let exitcode opts = if opts.filter_opts then 2 else 0 + +(******************************************************************************) +(* Parsing helpers *) +(******************************************************************************) +let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) + +let get_bool opt = function + | "yes" | "on" -> true + | "no" | "off" -> false + | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1 + +let get_int opt n = + try int_of_string n + with Failure _ -> + prerr_endline ("Error: integer expected after option "^opt); exit 1 + +let get_float opt n = + try float_of_string n + with Failure _ -> + prerr_endline ("Error: float expected after option "^opt); exit 1 + +let get_host_port opt s = + match CString.split ':' s with + | [host; portr; portw] -> + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) + | ["stdfds"] -> Some Spawned.AnonPipe + | _ -> + prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt); + exit 1 + +let get_error_resilience opt = function + | "on" | "all" | "yes" -> `All + | "off" | "no" -> `None + | s -> `Only (CString.split ',' s) + +let get_priority opt s = + try CoqworkmgrApi.priority_of_string s + with Invalid_argument _ -> + prerr_endline ("Error: low/high expected after "^opt); exit 1 + +let get_async_proofs_mode opt = let open Stm.AsyncOpts in function + | "no" | "off" -> APoff + | "yes" | "on" -> APon + | "lazy" -> APonLazy + | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1 + +let get_cache opt = function + | "force" -> Some Stm.AsyncOpts.Force + | _ -> prerr_endline ("Error: force expected after "^opt); exit 1 + +let is_not_dash_option = function + | Some f when String.length f > 0 && f.[0] <> '-' -> true + | _ -> false + +let rec add_vio_args peek next oval = + if is_not_dash_option (peek ()) then + let oval = add_vio_file oval (next ()) in + add_vio_args peek next oval + else oval + +let get_native_name s = + (* We ignore even critical errors because this mode has to be super silent *) + try + String.concat "/" [Filename.dirname s; + Nativelib.output_dir; Library.native_name_from_filename s] + with _ -> "" + +(*s Parsing of the command line. + We no longer use [Arg.parse], in order to use share [Usage.print_usage] + between coqtop and coqc. *) + +let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesystem" + (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned") + +exception NoCoqLib + +let usage batch = + begin + try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib) + with NoCoqLib -> usage_no_coqlib () + end; + let lp = Coqinit.toplevel_init_load_path () in + (* Necessary for finding the toplevels below *) + List.iter Mltop.add_coq_path lp; + if batch then Usage.print_usage_coqc () + else begin + Mltop.load_ml_objects_raw_rex + (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); + Usage.print_usage_coqtop () + end + +(* Main parsing routine *) +let parse_args arglist : coq_cmdopts * string list = + let args = ref arglist in + let extras = ref [] in + let rec parse oval = match !args with + | [] -> + (oval, List.rev !extras) + | opt :: rem -> + args := rem; + let next () = match !args with + | x::rem -> args := rem; x + | [] -> error_missing_arg opt + in + let peek_next () = match !args with + | x::_ -> Some x + | [] -> None + in + let noval = begin match opt with + + (* Complex options with many args *) + |"-I"|"-include" -> + begin match rem with + | d :: rem -> + args := rem; + add_ml_include oval d + | [] -> error_missing_arg opt + end + |"-Q" -> + begin match rem with + | d :: p :: rem -> + args := rem; + add_vo_include oval d p false + | _ -> error_missing_arg opt + end + |"-R" -> + begin match rem with + | d :: p :: rem -> + args := rem; + add_vo_include oval d p true + | _ -> error_missing_arg opt + end + + (* Options with two arg *) + |"-check-vio-tasks" -> + let tno = get_task_list (next ()) in + let tfile = next () in + add_vio_task oval (tno,tfile) + + |"-schedule-vio-checking" -> + let oval = { oval with vio_checking = true } in + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + |"-schedule-vio2vo" -> + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + (* Options with one arg *) + |"-coqlib" -> + Flags.coqlib_spec := true; + Flags.coqlib := (next ()); + oval + + |"-async-proofs" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) + }} + |"-async-proofs-j" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ())) + }} + |"-async-proofs-cache" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) + }} + + |"-async-proofs-tac-j" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_n_tacworkers = (get_int opt (next ())) + }} + + |"-async-proofs-worker-priority" -> + WorkerLoop.async_proofs_worker_priority := get_priority opt (next ()); + oval + + |"-async-proofs-private-flags" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); + }} + + |"-async-proofs-tactic-error-resilience" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) + }} + + |"-async-proofs-command-error-resilience" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ()) + }} + + |"-async-proofs-delegation-threshold" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ()) + }} + + |"-worker-id" -> set_worker_id opt (next ()); oval + + |"-compat" -> + let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in + Flags.compat_version := v; + add_compat_require oval v + + |"-compile" -> + add_compile oval false (next ()) + + |"-compile-verbose" -> + add_compile oval true (next ()) + + |"-dump-glob" -> + Dumpglob.dump_into_file (next ()); + { oval with glob_opt = true } + + |"-feedback-glob" -> + Dumpglob.feedback_glob (); oval + + |"-exclude-dir" -> + System.exclude_directory (next ()); oval + + |"-init-file" -> + { oval with rcfile = Some (next ()); } + + |"-inputstate"|"-is" -> + set_inputstate oval (next ()) + + |"-outputstate" -> + set_outputstate oval (next ()) + + |"-load-ml-object" -> + Mltop.dir_ml_load (next ()); oval + + |"-load-ml-source" -> + Mltop.dir_ml_use (next ()); oval + + |"-load-vernac-object" -> + add_vo_require oval (next ()) None None + + |"-load-vernac-source"|"-l" -> + add_load_vernacular oval false (next ()) + + |"-load-vernac-source-verbose"|"-lv" -> + add_load_vernacular oval true (next ()) + + |"-print-mod-uid" -> + let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 + + |"-profile-ltac-cutoff" -> + Flags.profile_ltac := true; + Flags.profile_ltac_cutoff := get_float opt (next ()); + oval + + |"-require" -> add_vo_require oval (next ()) None (Some false) + + |"-top" -> + let topname = Libnames.dirpath_of_string (next ()) in + if Names.DirPath.is_empty topname then + CErrors.user_err Pp.(str "Need a non empty toplevel module name"); + { oval with toplevel_name = topname } + + |"-main-channel" -> + Spawned.main_channel := get_host_port opt (next()); oval + + |"-control-channel" -> + Spawned.control_channel := get_host_port opt (next()); oval + + |"-vio2vo" -> + let oval = add_compile oval false (next ()) in + { oval with compilation_mode = Vio2Vo } + + |"-toploop" -> + if !Coqloop.print_emacs then + CErrors.user_err Pp.(str "Flags -toploop and -emacs are incompatible"); + { oval with toploop = Some (next ()) } + + |"-w" | "-W" -> + let w = next () in + if w = "none" then + (CWarnings.set_flags w; oval) + else + let w = CWarnings.get_flags () ^ "," ^ w in + CWarnings.set_flags (CWarnings.normalize_flags_string w); + oval + + |"-o" -> { oval with compilation_output_name = Some (next()) } + + (* Options with zero arg *) + |"-async-queries-always-delegate" + |"-async-proofs-always-delegate" + |"-async-proofs-full" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_full = true; + }} + |"-async-proofs-never-reopen-branch" -> + { oval with stm_flags = { oval.stm_flags with + Stm.AsyncOpts.async_proofs_never_reopen_branch = true + }} + |"-batch" -> set_batch_mode oval + |"-test-mode" -> Flags.test_mode := true; oval + |"-beautify" -> Flags.beautify := true; oval + |"-boot" -> Flags.boot := true; { oval with load_rcfile = false; } + |"-bt" -> Backtrace.record_backtrace true; oval + |"-color" -> set_color oval (next ()) + |"-config"|"--config" -> { oval with print_config = true } + |"-debug" -> Coqinit.set_debug (); oval + |"-stm-debug" -> Stm.stm_debug := true; oval + |"-emacs" -> set_emacs oval + |"-filteropts" -> { oval with filter_opts = true } + |"-ideslave" -> + if !Coqloop.print_emacs then + CErrors.user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); + Flags.ide_slave := true; + { oval with toploop = Some "coqidetop" } + + |"-impredicative-set" -> + { oval with impredicative_set = Declarations.ImpredicativeSet } + |"-indices-matter" -> Indtypes.enforce_indices_matter (); oval + |"-m"|"--memory" -> { oval with memory_stat = true } + |"-noinit"|"-nois" -> { oval with load_init = false } + |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true } + |"-native-compiler" -> + if not Coq_config.native_compiler then + warning "Native compilation was disabled at configure time." + else Flags.output_native_objects := true; oval + |"-output-context" -> { oval with output_context = true } + |"-profile-ltac" -> Flags.profile_ltac := true; oval + |"-q" -> { oval with load_rcfile = false; } + |"-quiet"|"-silent" -> + Flags.quiet := true; + Flags.make_warn false; + oval + |"-quick" -> { oval with compilation_mode = BuildVio } + |"-list-tags" -> { oval with print_tags = true } + |"-time" -> { oval with time = true } + |"-type-in-type" -> set_type_in_type (); oval + |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) + |"-where" -> { oval with print_where = true } + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage oval.batch_mode; oval + |"-v"|"--version" -> Usage.version (exitcode oval) + |"-print-version"|"--print-version" -> + Usage.machine_readable_version (exitcode oval) + + (* Unknown option *) + | s -> + extras := s :: !extras; + oval + end in + parse noval + in + try + parse init_args + with any -> fatal_error any diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli new file mode 100644 index 000000000..8ee1a8f55 --- /dev/null +++ b/toplevel/coqargs.mli @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo +type color = [`ON | `AUTO | `OFF] + +type coq_cmdopts = { + + load_init : bool; + load_rcfile : bool; + rcfile : string option; + + ml_includes : string list; + vo_includes : (string * Names.DirPath.t * bool) list; + vo_requires : (string * string option * bool option) list; + + (* Fuse these two? Currently, [batch_mode] is only used to + distinguish coqc / coqtop in help display. *) + batch_mode : bool; + compilation_mode : compilation_mode; + + toplevel_name : Names.DirPath.t; + toploop : string option; + + compile_list: (string * bool) list; (* bool is verbosity *) + compilation_output_name : string option; + + load_vernacular_list : (string * bool) list; + + vio_checking: bool; + vio_tasks : (int list * string) list; + vio_files : string list; + vio_files_j : int; + + color : color; + + impredicative_set : Declarations.set_predicativity; + stm_flags : Stm.AsyncOpts.stm_opt; + debug : bool; + time : bool; + + filter_opts : bool; + + glob_opt : bool; + + memory_stat : bool; + print_tags : bool; + print_where : bool; + print_config: bool; + output_context : bool; + + inputstate : string option; + outputstate : string option; + +} + +val parse_args : string list -> coq_cmdopts * string list +val exitcode : coq_cmdopts -> int diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 3a195c1df..d8aaf3db8 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -20,21 +20,15 @@ let set_debug () = does not exist. *) let rcdefaultname = "coqrc" -let rcfile = ref "" -let rcfile_specified = ref false -let set_rcfile s = rcfile := s; rcfile_specified := true -let load_rc = ref true -let no_load_rc () = load_rc := false - -let load_rcfile doc sid = - if !load_rc then +let load_rcfile ~rcfile ~time ~state = try - if !rcfile_specified then - if CUnix.file_readable_p !rcfile then - Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true doc sid !rcfile - else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) - else + match rcfile with + | Some rcfile -> + if CUnix.file_readable_p rcfile then + Vernac.load_vernac ~time ~verbosely:false ~interactive:false ~check:true ~state rcfile + else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) + | None -> try let warn x = Feedback.msg_warning (str x) in let inferedrc = List.find CUnix.file_readable_p [ @@ -43,8 +37,8 @@ let load_rcfile doc sid = Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; Envars.home ~warn / "."^rcdefaultname ] in - Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true doc sid inferedrc - with Not_found -> doc, sid + Vernac.load_vernac ~time ~verbosely:false ~interactive:false ~check:true ~state inferedrc + with Not_found -> state (* Flags.if_verbose mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ @@ -54,71 +48,79 @@ let load_rcfile doc sid = let reraise = CErrors.push reraise in let () = Feedback.msg_info (str"Load of rcfile failed.") in iraise reraise - else - (Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); - doc, sid) (* Recursively puts dir in the LoadPath if -nois was not passed *) -let add_stdlib_path ~load_init ~unix_path ~coq_root ~with_ml = - let add_ml = if with_ml then Mltop.AddRecML else Mltop.AddNoML in - Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:load_init - -let add_userlib_path ~unix_path = - Mltop.add_rec_path Mltop.AddRecML ~unix_path - ~coq_root:Libnames.default_root_prefix ~implicit:false - -(* Options -I, -I-as, and -R of the command line *) -let includes = ref [] -let push_include s alias implicit = - includes := (s, alias, implicit) :: !includes -let ml_includes = ref [] -let push_ml_include s = ml_includes := s :: !ml_includes - -(* Initializes the LoadPath *) -let init_load_path ~load_init = +let build_stdlib_path ~load_init ~unix_path ~coq_path ~with_ml = + let open Mltop in + let add_ml = if with_ml then AddRecML else AddNoML in + { recursive = true; + path_spec = VoPath { unix_path; coq_path ; has_ml = add_ml; implicit = load_init } + } + +let build_userlib_path ~unix_path = + let open Mltop in + { recursive = true; + path_spec = VoPath { + unix_path; + coq_path = Libnames.default_root_prefix; + has_ml = Mltop.AddRecML; + implicit = false; + } + } + +let ml_path_if c p = + let open Mltop in + let f x = { recursive = false; path_spec = MlPath x } in + if c then List.map f p else [] + +(* LoadPath for toploop toplevels *) +let toplevel_init_load_path () = + let coqlib = Envars.coqlib () in + (* NOTE: These directories are searched from last to first *) + (* first, developer specific directory to open *) + ml_path_if Coq_config.local [coqlib/"dev"] @ + + (* main loops *) + ml_path_if (Coq_config.local || !Flags.boot) [coqlib/"stm"; coqlib/"ide"] @ + ml_path_if (System.exists_dir (coqlib/"toploop")) [coqlib/"toploop"] + +(* LoadPath for Coq user libraries *) +let libs_init_load_path ~load_init = + + let open Mltop in let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in let coqpath = Envars.coqpath in - let coq_root = Names.DirPath.make [Libnames.coq_root] in - (* NOTE: These directories are searched from last to first *) - (* first, developer specific directory to open *) - if Coq_config.local then - Mltop.add_ml_dir (coqlib/"dev"); - (* main loops *) - if Coq_config.local || !Flags.boot then begin - Mltop.add_ml_dir (coqlib/"stm"); - Mltop.add_ml_dir (coqlib/"ide") - end; - if System.exists_dir (coqlib/"toploop") then - Mltop.add_ml_dir (coqlib/"toploop"); - (* then standard library *) - add_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false; - (* then plugins *) - add_stdlib_path ~load_init ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true; - (* then user-contrib *) - if Sys.file_exists user_contrib then - add_userlib_path ~unix_path:user_contrib; - (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) - List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs; - (* then directories in COQPATH *) - List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath; - (* then current directory (not recursively!) *) - Mltop.add_ml_dir "."; - Loadpath.add_load_path "." Libnames.default_root_prefix ~implicit:false; - (* additional loadpath, given with options -Q and -R *) - List.iter - (fun (unix_path, coq_root, implicit) -> - Mltop.add_rec_path Mltop.AddNoML ~unix_path ~coq_root ~implicit) - (List.rev !includes); - (* additional ml directories, given with option -I *) - List.iter Mltop.add_ml_dir (List.rev !ml_includes) + let coq_path = Names.DirPath.make [Libnames.coq_root] in + + (* then standard library and plugins *) + [build_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_path ~with_ml:false; + build_stdlib_path ~load_init ~unix_path:(coqlib/"plugins") ~coq_path ~with_ml:true ] @ + + (* then user-contrib *) + (if Sys.file_exists user_contrib then + [build_userlib_path ~unix_path:user_contrib] else [] + ) @ + + (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *) + List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) @ + + (* then current directory (not recursively!) *) + [ { recursive = false; + path_spec = VoPath { unix_path = "."; + coq_path = Libnames.default_root_prefix; + implicit = false; + has_ml = AddTopML } + } ] (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = + let open Mltop in + let lp s = { recursive = false; path_spec = MlPath s } in let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot [dl]) + Mltop.add_coq_path (lp (List.fold_left (/) Envars.coqroot [dl])) in - Mltop.add_ml_dir (Envars.coqlib ()); + Mltop.add_coq_path (lp (Envars.coqlib ())); List.iter add_subdir Coq_config.all_src_dirs diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 60ed698b8..14f39170c 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -10,16 +10,12 @@ val set_debug : unit -> unit -val set_rcfile : string -> unit +val load_rcfile : rcfile:(string option) -> time:bool -> state:Vernac.State.t -> Vernac.State.t -val no_load_rc : unit -> unit -val load_rcfile : Stm.doc -> Stateid.t -> Stm.doc * Stateid.t - -val push_include : string -> Names.DirPath.t -> bool -> unit -(** [push_include phys_path log_path implicit] *) - -val push_ml_include : string -> unit +val init_ocaml_path : unit -> unit -val init_load_path : load_init:bool -> unit +(* LoadPath for toploop toplevels *) +val toplevel_init_load_path : unit -> Mltop.coq_path list -val init_ocaml_path : unit -> unit +(* LoadPath for Coq user libraries *) +val libs_init_load_path : load_init:bool -> Mltop.coq_path list diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 910c81381..ae0b94476 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -258,8 +258,9 @@ let rec discard_to_dot () = | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () -let read_sentence ~doc sid input = - try Stm.parse_sentence ~doc sid input +let read_sentence ~state input = + let open Vernac.State in + try Stm.parse_sentence ~doc:state.doc state.sid input with reraise -> let reraise = CErrors.push reraise in discard_to_dot (); @@ -300,19 +301,20 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in is caught and handled (i.e. not re-raised). *) -let do_vernac doc sid = +let do_vernac ~time ~state = + let open Vernac.State in top_stderr (fnl()); - if !print_emacs then top_stderr (str (top_buffer.prompt doc)); + if !print_emacs then top_stderr (str (top_buffer.prompt state.doc)); resynch_buffer top_buffer; try let input = (top_buffer.tokens, None) in - Vernac.process_expr doc sid (read_sentence ~doc sid (fst input)) + Vernac.process_expr ~time ~state (read_sentence ~state (fst input)) with | Stm.End_of_input | CErrors.Quit -> top_stderr (fnl ()); raise CErrors.Quit | CErrors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise CErrors.Drop - else (Feedback.msg_error (str "There is no ML toplevel."); doc, sid) + else (Feedback.msg_warning (str "There is no ML toplevel."); state) (* Exception printing should be done by the feedback listener, however this is not yet ready so we rely on the exception for now. *) @@ -321,7 +323,7 @@ let do_vernac doc sid = let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; - doc, sid + state (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -337,25 +339,26 @@ let loop_flush_all () = Format.pp_print_flush !Topfmt.std_ft (); Format.pp_print_flush !Topfmt.err_ft () -let rec loop doc = +let rec loop ~time ~state = + let open Vernac.State in Sys.catch_break true; try - reset_input_buffer doc stdin top_buffer; + reset_input_buffer state.doc stdin top_buffer; (* Be careful to keep this loop tail-recursive *) - let rec vernac_loop doc sid = - let ndoc, nsid = do_vernac doc sid in + let rec vernac_loop ~state = + let nstate = do_vernac ~time ~state in loop_flush_all (); - vernac_loop ndoc nsid + vernac_loop ~state:nstate (* We recover the current stateid, threading from the caller is not possible due exceptions. *) - in vernac_loop doc (Stm.get_current_state ~doc) + in vernac_loop ~state with - | CErrors.Drop -> doc + | CErrors.Drop -> state | CErrors.Quit -> exit 0 | any -> - Feedback.msg_error (str "Anomaly: main loop exited with exception: " ++ + top_stderr (str "Anomaly: main loop exited with exception: " ++ str (Printexc.to_string any) ++ fnl() ++ str"Please report" ++ strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); - loop doc + loop ~time ~state diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 46934f326..1c1309051 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -31,9 +31,7 @@ val set_prompt : (unit -> string) -> unit val coqloop_feed : Feedback.feedback -> unit (** Parse and execute one vernac command. *) - -val do_vernac : Stm.doc -> Stateid.t -> Stm.doc * Stateid.t +val do_vernac : time:bool -> state:Vernac.State.t -> Vernac.State.t (** Main entry point of Coq: read and execute vernac commands. *) - -val loop : Stm.doc -> Stm.doc +val loop : time:bool -> state:Vernac.State.t -> Vernac.State.t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 553da2dc0..26ede1834 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -7,8 +7,7 @@ (************************************************************************) open Pp -open CErrors -open Libnames +open Coqargs let () = at_exit flush_all @@ -31,50 +30,6 @@ let print_header () = let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) -let toploop = ref None - -let color : [`ON | `AUTO | `OFF] ref = ref `AUTO -let set_color = function -| "yes" | "on" -> color := `ON -| "no" | "off" -> color := `OFF -| "auto" -> color := `AUTO -| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1 - -let init_color () = - let has_color = match !color with - | `OFF -> false - | `ON -> true - | `AUTO -> - Terminal.has_style Unix.stdout && - Terminal.has_style Unix.stderr && - (* emacs compilation buffer does not support colors by default, - its TERM variable is set to "dumb". *) - try Sys.getenv "TERM" <> "dumb" with Not_found -> false - in - if has_color then begin - let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in - match colors with - | None -> - (** Default colors *) - Topfmt.init_terminal_output ~color:true - | Some "" -> - (** No color output *) - Topfmt.init_terminal_output ~color:false - | Some s -> - (** Overwrite all colors *) - Topfmt.clear_styles (); - Topfmt.parse_color_config s; - Topfmt.init_terminal_output ~color:true - end - else - Topfmt.init_terminal_output ~color:false - -let toploop_init = ref begin fun x -> - let () = init_color () in - let () = CoqworkmgrApi.(init !Flags.async_proofs_worker_priority) in - x - end - (* Feedback received in the init stage, this is different as the STM will not be generally be initialized, thus stateid, etc... may be bogus. For now we just print to the console too *) @@ -82,16 +37,16 @@ let coqtop_init_feed = Coqloop.coqloop_feed let drop_last_doc = ref None (* Default toplevel loop *) -let console_toploop_run doc = +let console_toploop_run opts ~state = (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; - let doc = Coqloop.loop doc in + let state = Coqloop.loop ~time:opts.time ~state in (* Initialise and launch the Ocaml toplevel *) - drop_last_doc := Some doc; + drop_last_doc := Some state; Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); (* We let the feeder in place for users of Drop *) @@ -99,10 +54,7 @@ let console_toploop_run doc = let toploop_run = ref console_toploop_run -let output_context = ref false - let memory_stat = ref false - let print_memory_stat () = begin (* -m|--memory from the command-line *) if !memory_stat then @@ -123,133 +75,89 @@ let print_memory_stat () = let _ = at_exit print_memory_stat (******************************************************************************) -(* Engagement *) -(******************************************************************************) -let impredicative_set = ref Declarations.PredicativeSet -let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet -let set_type_in_type () = - let typing_flags = Environ.typing_flags (Global.env ()) in - Global.set_typing_flags { typing_flags with Declarations.check_universes = false } -let engage () = - Global.set_engagement !impredicative_set - -(******************************************************************************) -(* Interactive toplevel name *) -(******************************************************************************) -let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) -let toplevel_name = ref toplevel_default_name -let set_toplevel_name dir = - if Names.DirPath.is_empty dir then user_err Pp.(str "Need a non empty toplevel module name"); - toplevel_name := dir - -(******************************************************************************) (* Input/Output State *) (******************************************************************************) -let warn_deprecated_inputstate = - CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" - (fun () -> strbrk "The inputstate option is deprecated and discouraged.") - -let inputstate = ref "" -let set_inputstate s = - warn_deprecated_inputstate (); - inputstate:=s -let inputstate () = - if not (CString.is_empty !inputstate) then - let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in - States.intern_state fname - -let warn_deprecated_outputstate = - CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" - (fun () -> - strbrk "The outputstate option is deprecated and discouraged.") - -let outputstate = ref "" -let set_outputstate s = - warn_deprecated_outputstate (); - outputstate:=s -let outputstate () = - if not (CString.is_empty !outputstate) then - let fname = CUnix.make_suffix !outputstate ".coq" in - States.extern_state fname +let inputstate opts = + Option.iter (fun istate_file -> + let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in + States.intern_state fname) opts.inputstate + +let outputstate opts = + Option.iter (fun ostate_file -> + let fname = CUnix.make_suffix ostate_file ".coq" in + States.extern_state fname) opts.outputstate (******************************************************************************) (* Interactive Load File Simulation *) (******************************************************************************) -let load_vernacular_list = ref ([] : (string * bool) list) - -let add_load_vernacular verb s = - load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list - -let load_vernacular doc sid = +let load_vernacular opts ~state = List.fold_left - (fun (doc,sid) (f_in, verbosely) -> + (fun state (f_in, verbosely) -> let s = Loadpath.locate_file f_in in - if !Flags.beautify then - Flags.with_option Flags.beautify_file (Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid) f_in - else - Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid s) - (doc, sid) (List.rev !load_vernacular_list) - -let load_init_vernaculars doc sid = - let doc, sid = Coqinit.load_rcfile doc sid in - load_vernacular doc sid + (* Should make the beautify logic clearer *) + let load_vernac f = Vernac.load_vernac ~time:opts.time ~verbosely ~interactive:false ~check:true ~state f in + if !Flags.beautify + then Flags.with_option Flags.beautify_file load_vernac f_in + else load_vernac s + ) state (List.rev opts.load_vernacular_list) + +let load_init_vernaculars opts ~state = + let state = if opts.load_rcfile then + Coqinit.load_rcfile ~rcfile:opts.rcfile ~time:opts.time ~state + else begin + Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); + state + end in + + load_vernacular opts ~state (******************************************************************************) -(* Required Modules *) +(* Startup LoadPath and Modules *) (******************************************************************************) -let set_include d p implicit = - let p = dirpath_of_string p in - Coqinit.push_include d p implicit - -(* None = No Import; Some false = Import; Some true = Export *) -let require_list = ref ([] : (string * string option * bool option) list) -let add_require s = require_list := s :: !require_list +(* prelude_data == From Coq Require Export Prelude. *) +let prelude_data = "Prelude", Some "Coq", Some true -let load_init = ref true +let require_libs opts = + if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires -(* From Coq Require Import Prelude. *) -let prelude_data = "Prelude", Some "Coq", Some true +let cmdline_load_path opts = + let open Mltop in + (* loadpaths given by options -Q and -R *) + List.map + (fun (unix_path, coq_path, implicit) -> + { recursive = true; + path_spec = VoPath { unix_path; coq_path; has_ml = Mltop.AddNoML; implicit } }) + (List.rev opts.vo_includes) @ -let require_libs () = - if !load_init then prelude_data :: !require_list else !require_list + (* additional ml directories, given with option -I *) + List.map (fun s -> {recursive = false; path_spec = MlPath s}) (List.rev opts.ml_includes) -let add_compat_require v = - match v with - | Flags.V8_5 -> add_require ("Coq.Compat.Coq85", None, Some false) - | Flags.V8_6 -> add_require ("Coq.Compat.Coq86", None, Some false) - | Flags.V8_7 -> add_require ("Coq.Compat.Coq87", None, Some false) - | Flags.VOld | Flags.Current -> () +let build_load_path opts = + Coqinit.libs_init_load_path ~load_init:opts.load_init @ + cmdline_load_path opts (******************************************************************************) -(* File Compilation *) +(* Fatal Errors *) (******************************************************************************) -let glob_opt = ref false - -let compile_list = ref ([] : (bool * string) list) - -type compilation_mode = BuildVo | BuildVio | Vio2Vo -let compilation_mode = ref BuildVo -let compilation_output_name = ref None - -let batch_mode = ref false -let set_batch_mode () = - System.trust_file_cache := false; - batch_mode := true - -let add_compile verbose s = - set_batch_mode (); - Flags.quiet := true; - if not !glob_opt then Dumpglob.dump_to_dotglob (); - (** make the file name explicit; needed not to break up Coq loadpath stuff. *) - let s = - let open Filename in - if is_implicit s - then concat current_dir_name s - else s +(** Prints info which is either an error or an anomaly and then exits + with the appropriate error code *) +let fatal_error msg = + Topfmt.std_logger Feedback.Error msg; + flush_all (); + exit 1 + +let fatal_error_exn ?extra exn = + Topfmt.print_err_exn ?extra exn; + flush_all (); + let exit_code = + if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in - compile_list := (verbose,s) :: !compile_list + exit exit_code +(******************************************************************************) +(* File Compilation *) +(******************************************************************************) let warn_file_no_extension = CWarnings.create ~name:"file-no-extension" ~category:"filesystem" (fun (f,ext) -> @@ -267,16 +175,11 @@ let ensure_ext ext f = let chop_extension f = try Filename.chop_extension f with _ -> f -let compile_error msg = - Topfmt.std_logger Feedback.Error msg; - flush_all (); - exit 1 - let ensure_bname src tgt = let src, tgt = Filename.basename src, Filename.basename tgt in let src, tgt = chop_extension src, chop_extension tgt in if src <> tgt then - compile_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ + fatal_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ str "Source: " ++ str src ++ fnl () ++ str "Target: " ++ str tgt) @@ -288,20 +191,24 @@ let ensure_vio v vio = ensure ".vio" v vio let ensure_exists f = if not (Sys.file_exists f) then - compile_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) + fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) (* Compile a vernac file *) -let compile ~verbosely ~f_in ~f_out = +let compile opts ~verbosely ~f_in ~f_out = + let open Vernac.State in let check_pending_proofs () = let pfs = Proof_global.get_all_proof_names () in if not (CList.is_empty pfs) then - compile_error (str "There are pending proofs: " + fatal_error (str "There are pending proofs: " ++ (pfs |> List.rev |> prlist_with_sep pr_comma Names.Id.print) ++ str ".") in - match !compilation_mode with + let iload_path = build_load_path opts in + let require_libs = require_libs opts in + let stm_options = opts.stm_flags in + match opts.compilation_mode with | BuildVo -> Flags.record_aux_file := true; let long_f_dot_v = ensure_v f_in in @@ -313,19 +220,20 @@ let compile ~verbosely ~f_in ~f_out = let doc, sid = Stm.(new_doc { doc_type = VoDoc long_f_dot_vo; - require_libs = require_libs () + iload_path; require_libs; stm_options; }) in - let doc, sid = load_init_vernaculars doc sid in - let ldir = Stm.get_ldir ~doc in + let state = { doc; sid; proof = None } in + let state = load_init_vernaculars opts ~state in + let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_vo) ~v_file:long_f_dot_v); Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); let wall_clock1 = Unix.gettimeofday () in - let doc, _ = Vernac.load_vernac ~verbosely ~check:true ~interactive:false doc (Stm.get_current_state ~doc) long_f_dot_v in - let _doc = Stm.join ~doc in + let state = Vernac.load_vernac ~time:opts.time ~verbosely ~check:true ~interactive:false ~state long_f_dot_v in + let _doc = Stm.join ~doc:state.doc in let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); @@ -346,16 +254,27 @@ let compile ~verbosely ~f_in ~f_out = | None -> long_f_dot_v ^ "io" | Some f -> ensure_vio long_f_dot_v f in + (* We need to disable error resiliency, otherwise some errors + will be ignored in batch mode. c.f. #6707 + + This is not necessary in the vo case as it fully checks the + document anyways. *) + let stm_options = let open Stm.AsyncOpts in + { stm_options with + async_proofs_cmd_error_resilience = false; + async_proofs_tac_error_resilience = `None; + } in + let doc, sid = Stm.(new_doc { doc_type = VioDoc long_f_dot_vio; - require_libs = require_libs () + iload_path; require_libs; stm_options; }) in - let doc, sid = load_init_vernaculars doc sid in - - let ldir = Stm.get_ldir ~doc in - let doc, _ = Vernac.load_vernac ~verbosely ~check:false ~interactive:false doc (Stm.get_current_state ~doc) long_f_dot_v in - let doc = Stm.finish ~doc in + let state = { doc; sid; proof = None } in + let state = load_init_vernaculars opts ~state in + let ldir = Stm.get_ldir ~doc:state.doc in + let state = Vernac.load_vernac ~time:opts.time ~verbosely ~check:false ~interactive:false ~state long_f_dot_v in + let doc = Stm.finish ~doc:state.doc in check_pending_proofs (); let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in Stm.reset_task_queue () @@ -369,88 +288,96 @@ let compile ~verbosely ~f_in ~f_out = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile ~verbosely ~f_in ~f_out = +let compile opts ~verbosely ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile ~verbosely ~f_in ~f_out; + compile opts ~verbosely ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file (verbosely,f_in) = +let compile_file opts (f_in, verbosely) = if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile ~verbosely ~f_in ~f_out:None) f_in + (fun f_in -> compile opts ~verbosely ~f_in ~f_out:None) f_in else - compile ~verbosely ~f_in ~f_out:None + compile opts ~verbosely ~f_in ~f_out:None -let compile_files doc = - if !compile_list == [] then () - else List.iter compile_file (List.rev !compile_list) +let compile_files opts = + let compile_list = List.rev opts.compile_list in + List.iter (compile_file opts) compile_list (******************************************************************************) (* VIO Dispatching *) (******************************************************************************) - -let vio_tasks = ref [] -let add_vio_task f = - set_batch_mode (); - Flags.quiet := true; - vio_tasks := f :: !vio_tasks - -let check_vio_tasks () = +let check_vio_tasks opts = let rc = List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev !vio_tasks) in - if not rc then exit 1 + true (List.rev opts.vio_tasks) in + if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) -let vio_files = ref [] -let vio_files_j = ref 0 -let vio_checking = ref false -let add_vio_file f = - set_batch_mode (); - Flags.quiet := true; - vio_files := f :: !vio_files - -let set_vio_checking_j opt j = - try vio_files_j := int_of_string j - with Failure _ -> - prerr_endline ("The first argument of " ^ opt ^ " must the number"); - prerr_endline "of concurrent workers to be used (a positive integer)."; - prerr_endline "Makefiles generated by coq_makefile should be called"; - prerr_endline "setting the J variable like in 'make vio2vo J=3'"; - exit 1 - -let schedule_vio_checking () = - if !vio_files <> [] && !vio_checking then - Vio_checking.schedule_vio_checking !vio_files_j !vio_files - -let schedule_vio_compilation () = - if !vio_files <> [] && not !vio_checking then - Vio_checking.schedule_vio_compilation !vio_files_j !vio_files +let schedule_vio opts = + (* We must add update the loadpath here as the scheduling process + happens outside of the STM *) + let iload_path = build_load_path opts in + List.iter Mltop.add_coq_path iload_path; + + if opts.vio_checking then + Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files + else + Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files (******************************************************************************) -(* UI Options *) +(* Color Options *) (******************************************************************************) -(** Options for proof general *) - -let set_emacs () = - if not (Option.is_empty !toploop) then - user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop"); - Coqloop.print_emacs := true; - Printer.enable_goal_tags_printing := true; - color := `OFF - -(** Options for CoqIDE *) - -let set_ideslave () = - if !Coqloop.print_emacs then user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); - toploop := Some "coqidetop"; - Flags.ide_slave := true +let init_color color_mode = + let has_color = match color_mode with + | `OFF -> false + | `ON -> true + | `AUTO -> + Terminal.has_style Unix.stdout && + Terminal.has_style Unix.stderr && + (* emacs compilation buffer does not support colors by default, + its TERM variable is set to "dumb". *) + try Sys.getenv "TERM" <> "dumb" with Not_found -> false + in + if has_color then begin + let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in + match colors with + | None -> + (** Default colors *) + Topfmt.init_terminal_output ~color:true + | Some "" -> + (** No color output *) + Topfmt.init_terminal_output ~color:false + | Some s -> + (** Overwrite all colors *) + Topfmt.clear_styles (); + Topfmt.parse_color_config s; + Topfmt.init_terminal_output ~color:true + end + else + Topfmt.init_terminal_output ~color:false -(** Options for slaves *) +let toploop_init = ref begin fun opts x -> + let () = init_color opts.color in + let () = CoqworkmgrApi.init !WorkerLoop.async_proofs_worker_priority in + x + end -let set_toploop name = - if !Coqloop.print_emacs then user_err Pp.(str "Flags -toploop and -emacs are incompatible"); - toploop := Some name +let print_style_tags opts = + let () = init_color opts.color in + let tags = Topfmt.dump_tags () in + let iter (t, st) = + let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in + print_string opt + in + let make (t, st) = + let tags = List.map string_of_int (Terminal.repr st) in + (t ^ "=" ^ String.concat ";" tags) + in + let repr = List.map make tags in + let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in + let () = List.iter iter tags in + flush_all () (** GC tweaking *) @@ -477,307 +404,37 @@ let init_gc () = Gc.minor_heap_size = 33554432; (** 4M *) Gc.space_overhead = 120} -(*s Parsing of the command line. - We no longer use [Arg.parse], in order to use share [Usage.print_usage] - between coqtop and coqc. *) - -let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesystem" - (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned") - -exception NoCoqLib - -let usage batch = - begin - try - Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib); - Coqinit.init_load_path ~load_init:!load_init; - with NoCoqLib -> usage_no_coqlib () - end; - if batch then Usage.print_usage_coqc () - else begin - Mltop.load_ml_objects_raw_rex - (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); - Usage.print_usage_coqtop () - end - -let print_style_tags () = - let () = init_color () in - let tags = Topfmt.dump_tags () in - let iter (t, st) = - let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in - print_string opt - in - let make (t, st) = - let tags = List.map string_of_int (Terminal.repr st) in - (t ^ "=" ^ String.concat ";" tags) - in - let repr = List.map make tags in - let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in - let () = List.iter iter tags in - flush_all () - -let error_missing_arg s = - prerr_endline ("Error: extra argument expected after option "^s); - prerr_endline "See -help for the syntax of supported options"; - exit 1 - -let filter_opts = ref false -let exitcode () = if !filter_opts then 2 else 0 - -let print_where = ref false -let print_config = ref false -let print_tags = ref false - -let get_priority opt s = - try Flags.priority_of_string s - with Invalid_argument _ -> - prerr_endline ("Error: low/high expected after "^opt); exit 1 - -let get_async_proofs_mode opt = function - | "no" | "off" -> Flags.APoff - | "yes" | "on" -> Flags.APon - | "lazy" -> Flags.APonLazy - | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1 - -let get_cache opt = function - | "force" -> Some Flags.Force - | _ -> prerr_endline ("Error: force expected after "^opt); exit 1 - - -let set_worker_id opt s = - assert (s <> "master"); - Flags.async_proofs_worker_id := s - -let get_bool opt = function - | "yes" | "on" -> true - | "no" | "off" -> false - | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1 - -let get_int opt n = - try int_of_string n - with Failure _ -> - prerr_endline ("Error: integer expected after option "^opt); exit 1 - -let get_float opt n = - try float_of_string n - with Failure _ -> - prerr_endline ("Error: float expected after option "^opt); exit 1 - -let get_host_port opt s = - match CString.split ':' s with - | [host; portr; portw] -> - Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) - | ["stdfds"] -> Some Spawned.AnonPipe - | _ -> - prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt); - exit 1 - -let get_error_resilience opt = function - | "on" | "all" | "yes" -> `All - | "off" | "no" -> `None - | s -> `Only (CString.split ',' s) - -let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) - -let is_not_dash_option = function - | Some f when String.length f > 0 && f.[0] <> '-' -> true - | _ -> false - -let get_native_name s = - (* We ignore even critical errors because this mode has to be super silent *) - try - String.concat "/" [Filename.dirname s; - Nativelib.output_dir; Library.native_name_from_filename s] - with _ -> "" - -(** Prints info which is either an error or an anomaly and then exits - with the appropriate error code *) -let fatal_error ?extra exn = - Topfmt.print_err_exn ?extra exn; - let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in - exit exit_code - -let parse_args arglist = - let args = ref arglist in - let extras = ref [] in - let rec parse () = match !args with - | [] -> List.rev !extras - | opt :: rem -> - args := rem; - let next () = match !args with - | x::rem -> args := rem; x - | [] -> error_missing_arg opt - in - let peek_next () = match !args with - | x::_ -> Some x - | [] -> None - in - begin match opt with - - (* Complex options with many args *) - |"-I"|"-include" -> - begin match rem with - | d :: rem -> Coqinit.push_ml_include d; args := rem - | [] -> error_missing_arg opt - end - |"-Q" -> - begin match rem with - | d :: p :: rem -> set_include d p false; args := rem - | _ -> error_missing_arg opt - end - |"-R" -> - begin match rem with - | d :: p :: rem -> set_include d p true; args := rem - | _ -> error_missing_arg opt - end - - (* Options with two arg *) - |"-check-vio-tasks" -> - let tno = get_task_list (next ()) in - let tfile = next () in - add_vio_task (tno,tfile) - |"-schedule-vio-checking" -> - vio_checking := true; - set_vio_checking_j opt (next ()); - add_vio_file (next ()); - while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done - |"-schedule-vio2vo" -> - set_vio_checking_j opt (next ()); - add_vio_file (next ()); - while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done - - (* Options with one arg *) - |"-coqlib" -> Flags.coqlib_spec:=true; Flags.coqlib:=(next ()) - |"-async-proofs" -> - Flags.async_proofs_mode := get_async_proofs_mode opt (next()) - |"-async-proofs-j" -> - Flags.async_proofs_n_workers := (get_int opt (next ())) - |"-async-proofs-cache" -> - Flags.async_proofs_cache := get_cache opt (next ()) - |"-async-proofs-tac-j" -> - Flags.async_proofs_n_tacworkers := (get_int opt (next ())) - |"-async-proofs-worker-priority" -> - Flags.async_proofs_worker_priority := get_priority opt (next ()) - |"-async-proofs-private-flags" -> - Flags.async_proofs_private_flags := Some (next ()); - |"-async-proofs-tactic-error-resilience" -> - Flags.async_proofs_tac_error_resilience := get_error_resilience opt (next ()) - |"-async-proofs-command-error-resilience" -> - Flags.async_proofs_cmd_error_resilience := get_bool opt (next ()) - |"-async-proofs-delegation-threshold" -> - Flags.async_proofs_delegation_threshold:= get_float opt (next ()) - |"-worker-id" -> set_worker_id opt (next ()) - |"-compat" -> - let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in - Flags.compat_version := v; add_compat_require v - |"-compile" -> add_compile false (next ()) - |"-compile-verbose" -> add_compile true (next ()) - |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true - |"-feedback-glob" -> Dumpglob.feedback_glob () - |"-exclude-dir" -> System.exclude_directory (next ()) - |"-init-file" -> Coqinit.set_rcfile (next ()) - |"-inputstate"|"-is" -> set_inputstate (next ()) - |"-load-ml-object" -> Mltop.dir_ml_load (next ()) - |"-load-ml-source" -> Mltop.dir_ml_use (next ()) - |"-load-vernac-object" -> add_require (next (), None, None) - |"-load-vernac-source"|"-l" -> add_load_vernacular false (next ()) - |"-load-vernac-source-verbose"|"-lv" -> add_load_vernacular true (next ()) - |"-outputstate" -> set_outputstate (next ()) - |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 - |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; Flags.profile_ltac_cutoff := get_float opt (next ()) - |"-require" -> add_require (next (), None, Some false) - |"-top" -> set_toplevel_name (dirpath_of_string (next ())) - |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()) - |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) - |"-vio2vo" -> - add_compile false (next ()); - compilation_mode := Vio2Vo - |"-toploop" -> set_toploop (next ()) - |"-w" | "-W" -> - let w = next () in - if w = "none" then CWarnings.set_flags w - else - let w = CWarnings.get_flags () ^ "," ^ w in - CWarnings.set_flags (CWarnings.normalize_flags_string w) - |"-o" -> compilation_output_name := Some (next()) - - (* Options with zero arg *) - |"-async-queries-always-delegate" - |"-async-proofs-always-delegate" - |"-async-proofs-full" -> - Flags.async_proofs_full := true; - |"-async-proofs-never-reopen-branch" -> - Flags.async_proofs_never_reopen_branch := true; - |"-batch" -> set_batch_mode () - |"-test-mode" -> Flags.test_mode := true - |"-beautify" -> Flags.beautify := true - |"-boot" -> Flags.boot := true; Coqinit.no_load_rc () - |"-bt" -> Backtrace.record_backtrace true - |"-color" -> set_color (next ()) - |"-config"|"--config" -> print_config := true - |"-debug" -> Coqinit.set_debug () - |"-stm-debug" -> Flags.stm_debug := true - |"-emacs" -> set_emacs () - |"-filteropts" -> filter_opts := true - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage !batch_mode - |"-ideslave" -> set_ideslave () - |"-impredicative-set" -> set_impredicative_set () - |"-indices-matter" -> Indtypes.enforce_indices_matter () - |"-m"|"--memory" -> memory_stat := true - |"-noinit"|"-nois" -> load_init := false - |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true - |"-native-compiler" -> - if Coq_config.no_native_compiler then - warning "Native compilation was disabled at configure time." - else Flags.native_compiler := true - |"-output-context" -> output_context := true - |"-profile-ltac" -> Flags.profile_ltac := true - |"-q" -> Coqinit.no_load_rc () - |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> compilation_mode := BuildVio - |"-list-tags" -> print_tags := true - |"-time" -> Flags.time := true - |"-type-in-type" -> set_type_in_type () - |"-unicode" -> add_require ("Utf8_core", None, Some false) - |"-v"|"--version" -> Usage.version (exitcode ()) - |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode ()) - |"-where" -> print_where := true - - (* Unknown option *) - | s -> extras := s :: !extras - end; - parse () - in - try - parse () - with any -> fatal_error any - +(** Main init routine *) let init_toplevel arglist = (* Coq's init process, phase 1: - - OCaml parameters, and basic structures and IO + OCaml parameters, basic structures, and IO *) - Profile.init_profile (); + CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) let init_feeder = Feedback.add_feeder coqtop_init_feed in Lib.init(); + (* Coq's init process, phase 2: - - Basic Coq environment, load-path, plugins. + Basic Coq environment, load-path, plugins. *) let res = begin try - let extras = parse_args arglist in + let opts,extras = parse_args arglist in + memory_stat := opts.memory_stat; + (* If we have been spawned by the Spawn module, this has to be done * early since the master waits us to connect back *) Spawned.init_channels (); Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - if !print_where then (print_endline(Envars.coqlib ()); exit(exitcode ())); - if !print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode ())); - if !print_tags then (print_style_tags (); exit (exitcode ())); - if !filter_opts then (print_string (String.concat "\n" extras); exit 0); - Coqinit.init_load_path ~load_init:!load_init; - Option.iter Mltop.load_ml_object_raw !toploop; - let extras = !toploop_init extras in + if opts.print_where then (print_endline(Envars.coqlib ()); exit(exitcode opts)); + if opts.print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode opts)); + if opts.print_tags then (print_style_tags opts; exit (exitcode opts)); + if opts.filter_opts then (print_string (String.concat "\n" extras); exit 0); + let top_lp = Coqinit.toplevel_init_load_path () in + List.iter Mltop.add_coq_path top_lp; + Option.iter Mltop.load_ml_object_raw opts.toploop; + let extras = !toploop_init opts extras in if not (CList.is_empty extras) then begin prerr_endline ("Don't know what to do with "^String.concat " " extras); prerr_endline "See -help for the list of supported options"; @@ -785,10 +442,10 @@ let init_toplevel arglist = end; Flags.if_verbose print_header (); Mltop.init_known_plugins (); - engage (); + Global.set_engagement opts.impredicative_set; (* Allow the user to load an arbitrary state here *) - inputstate (); + inputstate opts; (* This state will be shared by all the documents *) Stm.init_core (); @@ -797,39 +454,48 @@ let init_toplevel arglist = It is essential that the module system is in a consistent state before we take the first snapshot. This was not - guaranteed in the past. In particular, we want to be sure we - have called start_library before loading the prelude and rest - of required files. + guaranteed in the past, but now is thanks to the STM API. We split the codepath here depending whether coqtop is called in interactive mode or not. *) - if (not !batch_mode || CList.is_empty !compile_list) + (* The condition for starting the interactive mode is a bit + convoluted, we should really refactor batch/compilation_mode + more. *) + if (not opts.batch_mode + || CList.(is_empty opts.compile_list && is_empty opts.vio_files && is_empty opts.vio_tasks)) (* Interactive *) then begin + let iload_path = build_load_path opts in + let require_libs = require_libs opts in + let stm_options = opts.stm_flags in try - let doc, sid = Stm.(new_doc - { doc_type = Interactive !toplevel_name; - require_libs = require_libs () - }) in - Some (load_init_vernaculars doc sid) - with any -> flush_all(); fatal_error any - (* Non interactive *) + let open Vernac.State in + let doc, sid = + Stm.(new_doc + { doc_type = Interactive opts.toplevel_name; + iload_path; require_libs; stm_options; + }) in + let state = { doc; sid; proof = None } in + Some (load_init_vernaculars opts ~state), opts + with any -> flush_all(); fatal_error_exn any + (* Non interactive: we perform a sequence of compilation steps *) end else begin try - compile_files (); - schedule_vio_checking (); - schedule_vio_compilation (); - check_vio_tasks (); + compile_files opts; + (* Vio compile pass *) + if opts.vio_files <> [] then schedule_vio opts; + (* Vio task pass *) + check_vio_tasks opts; (* Allow the user to output an arbitrary state *) - outputstate (); - None - with any -> flush_all(); fatal_error any + outputstate opts; + None, opts + with any -> flush_all(); fatal_error_exn any end; with any -> flush_all(); let extra = Some (str "Error during initialization: ") in - fatal_error ?extra any + fatal_error_exn ?extra any end in Feedback.del_feeder init_feeder; res @@ -837,16 +503,14 @@ let init_toplevel arglist = let start () = match init_toplevel (List.tl (Array.to_list Sys.argv)) with (* Batch mode *) - | Some (doc, sid) when not !batch_mode -> - !toploop_run doc; + | Some state, opts when not opts.batch_mode -> + !toploop_run opts ~state; exit 1 - | _ -> + | _ , opts -> flush_all(); - if !output_context then begin + if opts.output_context then begin let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; - Profile.print_profile (); + CProfile.print_profile (); exit 0 - -(* [Coqtop.start] will be called by the code produced by coqmktop *) diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 5b9494eaa..dedb298e2 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -11,14 +11,13 @@ state, load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [Coqloop.loop]. *) -val init_toplevel : string list -> (Stm.doc * Stateid.t) option +val init_toplevel : string list -> Vernac.State.t option * Coqargs.coq_cmdopts val start : unit -> unit (* Last document seen after `Drop` *) -val drop_last_doc : Stm.doc option ref +val drop_last_doc : Vernac.State.t option ref (* For other toploops *) -val toploop_init : (string list -> string list) ref -val toploop_run : (Stm.doc -> unit) ref - +val toploop_init : (Coqargs.coq_cmdopts -> string list -> string list) ref +val toploop_run : (Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit) ref diff --git a/toplevel/coqtop_bin.ml b/toplevel/coqtop_bin.ml new file mode 100644 index 000000000..56aced92a --- /dev/null +++ b/toplevel/coqtop_bin.ml @@ -0,0 +1,2 @@ +(* Main coqtop initialization *) +let () = Coqtop.start() diff --git a/toplevel/coqtop_byte_bin.ml b/toplevel/coqtop_byte_bin.ml new file mode 100644 index 000000000..7d8354ec3 --- /dev/null +++ b/toplevel/coqtop_byte_bin.ml @@ -0,0 +1,21 @@ +let drop_setup () = + begin try + (* Enable rectypes in the toplevel if it has the directive #rectypes *) + begin match Hashtbl.find Toploop.directive_table "rectypes" with + | Toploop.Directive_none f -> f () + | _ -> () + end + with + | Not_found -> () + end; + let ppf = Format.std_formatter in + Mltop.(set_top + { load_obj = (fun f -> if not (Topdirs.load_file ppf f) + then CErrors.user_err Pp.(str ("Could not load plugin "^f)) + ); + use_file = Topdirs.dir_use ppf; + add_dir = Topdirs.dir_directory; + ml_loop = (fun () -> Toploop.loop ppf); + }) + +let _ = drop_setup () diff --git a/toplevel/coqtop_opt_bin.ml b/toplevel/coqtop_opt_bin.ml new file mode 100644 index 000000000..410b4679a --- /dev/null +++ b/toplevel/coqtop_opt_bin.ml @@ -0,0 +1,3 @@ +let drop_setup () = Mltop.remove () + +let _ = drop_setup () diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 10bf48647..9fb2e33d7 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -2,4 +2,5 @@ Vernac Usage Coqloop Coqinit +Coqargs Coqtop diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 8fdaedbaf..1f681d9cf 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -110,15 +110,26 @@ let pr_open_cur_subgoals () = (* Stm.End_of_input -> true *) (* | _ -> false *) -let rec interp_vernac ~check ~interactive doc sid (loc,com) = - let interp = function +module State = struct + + type t = { + doc : Stm.doc; + sid : Stateid.t; + proof : Proof.t option; + } + +end + +let rec interp_vernac ~time ~check ~interactive ~state (loc,com) = + let open State in + let interp v = + match under_control v with | VernacLoad (verbosely, fname) -> - let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in + let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let f = Loadpath.locate_file fname in - load_vernac ~verbosely ~check ~interactive doc sid f - | v -> - + load_vernac ~time ~verbosely ~check ~interactive ~state f + | _ -> (* XXX: We need to run this before add as the classification is highly dynamic and depends on the structure of the document. Hopefully this is fixed when VtMeta can be removed @@ -134,7 +145,7 @@ let rec interp_vernac ~check ~interactive doc sid (loc,com) = in CWarnings.set_flags wflags; - let doc, nsid, ntip = Stm.add ~doc ~ontop:sid (not !Flags.quiet) (loc,v) in + let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) (loc,v) in (* Main STM interaction *) if ntip <> `NewTip then @@ -152,18 +163,19 @@ let rec interp_vernac ~check ~interactive doc sid (loc,com) = is_proof_step && Proof_global.there_are_pending_proofs () in if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ()); - ndoc, nsid + let new_proof = Proof_global.give_me_the_proof_opt () in + { doc = ndoc; sid = nsid; proof = new_proof } in try (* The -time option is only supported from console-based clients due to the way it prints. *) - if !Flags.time then print_cmd_header ?loc com; - let com = if !Flags.time then VernacTime (loc,com) else com in + if time then print_cmd_header ?loc com; + let com = if time then VernacTime(time,(loc,com)) else com in interp com with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird things, so we better avoid it while we investigate *) - if interactive then ignore(Stm.edit_at ~doc sid); + if interactive then ignore(Stm.edit_at ~doc:state.doc state.sid); let (reraise, info) = CErrors.push reraise in let info = begin match Loc.get_loc info with @@ -172,7 +184,7 @@ let rec interp_vernac ~check ~interactive doc sid (loc,com) = end in iraise (reraise, info) (* Load a vernac file. CErrors are annotated with file and location *) -and load_vernac ~verbosely ~check ~interactive doc sid file = +and load_vernac ~time ~verbosely ~check ~interactive ~state file = let ft_beautify, close_beautify = if !Flags.beautify_file then let chan_beautify = open_out (file^beautify_suffix) in @@ -183,14 +195,14 @@ and load_vernac ~verbosely ~check ~interactive doc sid file = let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in - let rsid = ref sid in - let rdoc = ref doc in + let rstate = ref state in + let open State in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do let loc, ast = - Stm.parse_sentence ~doc:!rdoc !rsid in_pa + Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa (* If an error in parsing occurs, we propagate the exception so the caller of load_vernac will take care of it. However, in the future it could be possible that we want to handle @@ -214,11 +226,10 @@ and load_vernac ~verbosely ~check ~interactive doc sid file = Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); - let ndoc, nsid = Flags.silently (interp_vernac ~check ~interactive !rdoc !rsid) (loc, ast) in - rsid := nsid; - rdoc := ndoc + let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) (loc, ast) in + rstate := state; done; - !rdoc, !rsid + !rstate with any -> (* whatever the exception *) let (e, info) = CErrors.push any in close_in in_chan; @@ -229,7 +240,7 @@ and load_vernac ~verbosely ~check ~interactive doc sid file = if !Flags.beautify then pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa ft_beautify None; if !Flags.beautify_file then close_beautify (); - !rdoc, !rsid + !rstate | reraise -> if !Flags.beautify_file then close_beautify (); iraise (disable_drop e, info) @@ -241,6 +252,6 @@ and load_vernac ~verbosely ~check ~interactive doc sid file = of a new state label). An example of state-preserving command is one coming from the query panel of Coqide. *) -let process_expr doc sid loc_ast = +let process_expr ~time ~state loc_ast = checknav_deep loc_ast; - interp_vernac ~interactive:true ~check:true doc sid loc_ast + interp_vernac ~time ~interactive:true ~check:true ~state loc_ast diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index f9a430026..e909ada1e 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -7,14 +7,24 @@ (************************************************************************) (** Parsing of vernacular. *) +module State : sig + + type t = { + doc : Stm.doc; + sid : Stateid.t; + proof : Proof.t option; + } + +end (** [process_expr sid cmd] Executes vernac command [cmd]. Callers are expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : Stm.doc -> Stateid.t -> Vernacexpr.vernac_expr Loc.located -> Stm.doc * Stateid.t +val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control Loc.located -> State.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle and print errors in form of exceptions. *) -val load_vernac : verbosely:bool -> check:bool -> interactive:bool -> Stm.doc -> Stateid.t -> string -> Stm.doc * Stateid.t +val load_vernac : time:bool -> verbosely:bool -> check:bool -> interactive:bool -> + state:State.t -> string -> State.t diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 51dd5cd4f..ec6b62ee2 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -317,7 +317,7 @@ let build_beq_scheme mode kn = let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in if not (Sorts.List.mem InSet kelim) then raise (NonSingletonProp (kn,i)); - if mib.mind_finite = Decl_kinds.CoFinite then + if mib.mind_finite = CoFinite then raise NoDecidabilityCoInductive; let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in create_input fix), diff --git a/vernac/classes.ml b/vernac/classes.ml index b80741269..4a2dba859 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -8,10 +8,7 @@ (*i*) open Names -open Term -open Constr -open Vars -open Environ +open EConstr open Nametab open CErrors open Util @@ -70,10 +67,9 @@ let existing_instance glob g info = let c = global g in let info = Option.default Hints.empty_hint_info info in let instance, _ = Global.type_of_global_in_context (Global.env ()) c in - let _, r = decompose_prod_assum instance in + let _, r = Term.decompose_prod_assum instance in match class_of_constr Evd.empty (EConstr.of_constr r) with - | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob - (*FIXME*) (Flags.use_polymorphic_flag ()) c) + | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob c) | None -> user_err ?loc:(loc_of_reference g) ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") @@ -83,19 +79,20 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m (* Declare everything in the parameters as implicit, and the class instance as well *) -let type_ctx_instance evars env ctx inst subst = - let rec aux (subst, instctx) l = function +let type_ctx_instance env sigma ctx inst subst = + let open Vars in + let rec aux (sigma, subst, instctx) l = function decl :: ctx -> let t' = substl subst (RelDecl.get_type decl) in - let c', l = + let (sigma, c'), l = match decl with - | LocalAssum _ -> EConstr.Unsafe.to_constr (interp_casted_constr_evars env evars (List.hd l) t'), List.tl l - | LocalDef (_,b,_) -> substl subst b, l + | LocalAssum _ -> interp_casted_constr_evars env sigma (List.hd l) t', List.tl l + | LocalDef (_,b,_) -> (sigma, substl subst b), l in let d = RelDecl.get_name decl, Some c', t' in - aux (c' :: subst, d :: instctx) l ctx - | [] -> subst - in aux (subst, []) inst (List.rev ctx) + aux (sigma, c' :: subst, d :: instctx) l ctx + | [] -> sigma, subst + in aux (sigma, subst, []) inst (List.rev ctx) let id_of_class cl = match cl.cl_impl with @@ -112,38 +109,38 @@ let instance_hook k info global imps ?hook cst = Typeclasses.declare_instance (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k info global imps ?hook id decl poly evm term termtype = +let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = let kind = IsDefinition Instance in - let evm = - let levels = Univ.LSet.union (Univops.universes_of_constr termtype) - (Univops.universes_of_constr term) in - Evd.restrict_universe_context evm levels + let sigma = + let env = Global.env () in + let levels = Univ.LSet.union (Univops.universes_of_constr env termtype) + (Univops.universes_of_constr env term) in + Evd.restrict_universe_context sigma levels in - let uctx = Evd.check_univ_decl ~poly evm decl in + let uctx = Evd.check_univ_decl ~poly sigma decl in let entry = Declare.definition_entry ~types:termtype ~univs:uctx term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; - Universes.register_universe_binders (ConstRef kn) (Evd.universe_binders evm); + Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders sigma); instance_hook k info global imps ?hook (ConstRef kn); id let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) - poly ctx (instid, bk, cl) props ?(generalize=true) + ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let ((loc, instid), pl) = instid in - let evd, decl = Univdecls.interp_univ_decl_opt env pl in - let evars = ref evd in + let sigma, decl = Univdecls.interp_univ_decl_opt env pl in let tclass, ids = match bk with | Decl_kinds.Implicit -> Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false (fun avoid (clname, _) -> match clname with - | Some (cl, b) -> + | Some cl -> let t = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) @@ -154,26 +151,26 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in - let k, u, cty, ctx', ctx, len, imps, subst = - let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in - let ctx = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) ctx in - let c', imps' = interp_type_evars_impls ~impls env' evars tclass in - let c' = EConstr.Unsafe.to_constr c' in + let sigma, k, u, cty, ctx', ctx, len, imps, subst = + let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in + let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in - let ctx', c = decompose_prod_assum c' in + let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in - let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) !evars (EConstr.of_constr c) in - let u = EConstr.EInstance.kind !evars u in - let cl = Typeclasses.typeclass_univ_instance (k, u) in - let _, args = + let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) sigma c in + let u_s = EInstance.kind sigma u in + let cl = Typeclasses.typeclass_univ_instance (k, u_s) in + let args = List.map of_constr args in + let cl_context = List.map (Termops.map_rel_decl of_constr) (snd cl.cl_context) in + let _, args = List.fold_right (fun decl (args, args') -> match decl with | LocalAssum _ -> (List.tl args, List.hd args :: args') - | LocalDef (_,b,_) -> (args, substl args' b :: args')) - (snd cl.cl_context) (args, []) + | LocalDef (_,b,_) -> (args, Vars.substl args' b :: args')) + cl_context (args, []) in - cl, u, c', ctx', ctx, len, imps, args + sigma, cl, u, c', ctx', ctx, len, imps, args in let id = match instid with @@ -187,9 +184,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - evars := Evarutil.nf_evar_map !evars; - evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars; - let subst = List.map (fun c -> EConstr.Unsafe.to_constr (Evarutil.nf_evar !evars (EConstr.of_constr c))) subst in + let sigma = Evarutil.nf_evar_map sigma in + let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in if abstract then begin let subst = List.fold_left2 @@ -197,18 +193,16 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) [] subst (snd k.cl_context) in let (_, ty_constr) = instance_constructor (k,u) subst in - let nf, subst = Evarutil.e_nf_evars_and_universes evars in - let termtype = - let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - nf t - in - Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype); - let univs = Evd.check_univ_decl ~poly !evars decl in + let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + let sigma,_ = Evarutil.nf_evars_and_universes sigma in + Pretyping.check_evars env Evd.empty sigma termtype; + let univs = Evd.check_univ_decl ~poly sigma decl in + let termtype = to_constr sigma termtype in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,(termtype,univs),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in - Universes.register_universe_binders (ConstRef cst) (Evd.universe_binders !evars); + Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps ?hook (ConstRef cst); id end else ( @@ -220,16 +214,16 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) Some (Inl fs) | Some (_, t) -> Some (Inr t) | None -> - if Flags.is_program_mode () then Some (Inl []) + if program_mode then Some (Inl []) else None in - let subst = + let subst, sigma = match props with - | None -> if List.is_empty k.cl_props then Some (Inl subst) else None + | None -> + (if List.is_empty k.cl_props then Some (Inl subst) else None), sigma | Some (Inr term) -> - let c = interp_casted_constr_evars env' evars term cty in - let c = EConstr.Unsafe.to_constr c in - Some (Inr (c, subst)) + let sigma, c = interp_casted_constr_evars env' sigma term cty in + Some (Inr (c, subst)), sigma | Some (Inl props) -> let get_id = function @@ -266,9 +260,10 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) | (n, _) :: _ -> unbound_method env' k.cl_impl (get_id n) | _ -> - Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') - k.cl_props props subst)) - in + let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in + let sigma, res = type_ctx_instance (push_rel_context ctx' env') sigma kcl_props props subst in + Some (Inl res), sigma + in let term, termtype = match subst with | None -> let termtype = it_mkProd_or_LetIn cty ctx in @@ -280,34 +275,30 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) in let (app, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in + let term = it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in Some term, termtype | Some (Inr (def, subst)) -> let termtype = it_mkProd_or_LetIn cty ctx in - let term = Termops.it_mkLambda_or_LetIn def ctx in + let term = it_mkLambda_or_LetIn def ctx in Some term, termtype in - let _ = - evars := Evarutil.nf_evar_map !evars; - evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true - env !evars; - (* Try resolving fields that are typeclasses automatically. *) - evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false - env !evars - in - let _ = evars := Evarutil.nf_evar_map_undefined !evars in - let evm, nf = Evarutil.nf_evar_map_universes !evars in - let termtype = nf termtype in - let _ = (* Check that the type is free of evars now. *) - Pretyping.check_evars env Evd.empty evm (EConstr.of_constr termtype) - in - let term = Option.map nf term in - if not (Evd.has_undefined evm) && not (Option.is_empty term) then + let sigma = Evarutil.nf_evar_map sigma in + let sigma = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true env sigma in + (* Try resolving fields that are typeclasses automatically. *) + let sigma = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env sigma in + let sigma = Evarutil.nf_evar_map_undefined sigma in + (* Beware of this step, it is required as to minimize universes. *) + let sigma, _nf = Evarutil.nf_evar_map_universes sigma in + (* Check that the type is free of evars now. *) + Pretyping.check_evars env Evd.empty sigma termtype; + let termtype = to_constr sigma termtype in + let term = Option.map (to_constr sigma) term in + if not (Evd.has_undefined sigma) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id decl - poly evm (Option.get term) termtype - else if Flags.is_program_mode () || refine || Option.is_empty term then begin + poly sigma (Option.get term) termtype + else if program_mode || refine || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in - if Flags.is_program_mode () then + if program_mode then let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; @@ -317,12 +308,12 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) match term with | Some t -> let obls, _, constr, typ = - Obligations.eterm_obligations env id evm 0 t termtype + Obligations.eterm_obligations env id sigma 0 t termtype in obls, Some constr, typ | None -> [||], None, termtype in let hook = Lemmas.mk_hook hook in - let ctx = Evd.evar_universe_context evm in + let ctx = Evd.evar_universe_context sigma in ignore (Obligations.add_definition id ?term:constr ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id @@ -333,16 +324,16 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code the refinement manually.*) - let gls = List.rev (Evd.future_goals evm) in - let evm = Evd.reset_future_goals evm in - Lemmas.start_proof id ~pl:decl kind evm (EConstr.of_constr termtype) + let gls = List.rev (Evd.future_goals sigma) in + let sigma = Evd.reset_future_goals sigma in + Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) (Lemmas.mk_hook (fun _ -> instance_hook k pri global imps ?hook)); (* spiwack: I don't know what to do with the status here. *) if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun evm -> (evm,EConstr.of_constr (Option.get term))); + Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] @@ -356,6 +347,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) else CErrors.user_err Pp.(str "Unsolved obligations remaining.")) let named_of_rel_context l = + let open Vars in let acc, ctx = List.fold_right (fun decl (subst, ctx) -> @@ -369,20 +361,20 @@ let named_of_rel_context l = let context poly l = let env = Global.env() in - let evars = ref (Evd.from_env env) in - let _, ((env', fullctx), impls) = interp_context_evars env evars l in - let fullctx = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) fullctx in - let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in - let fullctx = Context.Rel.map subst fullctx in - let ce t = Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr t) in + let sigma = Evd.from_env env in + let sigma, (_, ((env', fullctx), impls)) = interp_context_evars env sigma l in + (* Note, we must use the normalized evar from now on! *) + let sigma,_ = Evarutil.nf_evars_and_universes sigma in + let ce t = Pretyping.check_evars env Evd.empty sigma t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in let ctx = try named_of_rel_context fullctx with e when CErrors.noncritical e -> user_err Pp.(str "Anonymous variables not allowed in contexts.") in - let uctx = ref (Evd.universe_context_set !evars) in + let uctx = ref (Evd.universe_context_set sigma) in let fn status (id, b, t) = + let b, t = Option.map (to_constr sigma) b, to_constr sigma t in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then (* Declare the universe context once *) let univs = if poly @@ -398,10 +390,9 @@ let context poly l = (DefinitionEntry entry, IsAssumption Logical) in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in - match class_of_constr !evars (EConstr.of_constr t) with + match class_of_constr sigma (of_constr t) with | Some (rels, ((tc,_), args) as _cl) -> - add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*) - poly (ConstRef cst)); + add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (ConstRef cst)); status (* declare_subclasses (ConstRef cst) cl *) | None -> status @@ -418,7 +409,7 @@ let context poly l = in let nstatus = match b with | None -> - pi3 (Command.declare_assumption false decl (t, univs) Universes.empty_binders [] impl + pi3 (ComAssumption.declare_assumption false decl (t, univs) Universes.empty_binders [] impl Vernacexpr.NoInline (Loc.tag id)) | Some b -> let decl = (Discharge, poly, Definition) in diff --git a/vernac/classes.mli b/vernac/classes.mli index c0f03227c..d47c6a6f8 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -41,6 +41,7 @@ val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) ?refine:bool -> (** Allow refinement *) + program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> Vernacexpr.typeclass_constraint -> diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml new file mode 100644 index 000000000..5d7adb24a --- /dev/null +++ b/vernac/comAssumption.ml @@ -0,0 +1,182 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Vars +open Environ +open Declare +open Names +open Globnames +open Constrexpr_ops +open Constrintern +open Impargs +open Decl_kinds +open Pretyping +open Vernacexpr +open Entries + +(* 2| Variable/Hypothesis/Parameter/Axiom declarations *) + +let axiom_into_instance = ref false + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "automatically declare axioms whose type is a typeclass as instances"; + optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; + optread = (fun _ -> !axiom_into_instance); + optwrite = (:=) axiom_into_instance; } + +let should_axiom_into_instance = function + | Discharge -> + (* The typeclass behaviour of Variable and Context doesn't depend + on section status *) + true + | Global | Local -> !axiom_into_instance + +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = +match local with +| Discharge when Lib.sections_are_opened () -> + let ctx = match ctx with + | Monomorphic_const_entry ctx -> ctx + | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx + in + let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in + let _ = declare_variable ident decl in + let () = assumption_message ident in + let () = + if not !Flags.quiet && Proof_global.there_are_pending_proofs () then + Feedback.msg_info (str"Variable" ++ spc () ++ Id.print ident ++ + strbrk " is not visible from current goals") + in + let r = VarRef ident in + let () = Typeclasses.declare_instance None true r in + let () = if is_coe then Class.try_add_new_coercion r ~local:true false in + (r,Univ.Instance.empty,true) + +| Global | Local | Discharge -> + let do_instance = should_axiom_into_instance local in + let local = DeclareDef.get_locality ident ~kind:"axiom" local in + let inl = match nl with + | NoInline -> None + | DefaultInline -> Some (Flags.get_inline_level()) + | InlineAt i -> Some i + in + let decl = (ParameterEntry (None,(c,ctx),inl), IsAssumption kind) in + let kn = declare_constant ident ~local decl in + let gr = ConstRef kn in + let () = maybe_declare_manual_implicits false gr imps in + let () = Declare.declare_univ_binders gr pl in + let () = assumption_message ident in + let () = if do_instance then Typeclasses.declare_instance None false gr in + let () = if is_coe then Class.try_add_new_coercion gr ~local p in + let inst = match ctx with + | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Monomorphic_const_entry _ -> Univ.Instance.empty + in + (gr,inst,Lib.is_modtype_strict ()) + +let interp_assumption sigma env impls bl c = + let c = mkCProdN ?loc:(local_binders_loc bl) bl c in + let sigma, (ty, impls) = interp_type_evars_impls env sigma ~impls c in + let ty = EConstr.Unsafe.to_constr ty in + sigma, (ty, impls) + +(* When monomorphic the universe constraints are declared with the first declaration only. *) +let next_uctx = + let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in + function + | Polymorphic_const_entry _ as uctx -> uctx + | Monomorphic_const_entry _ -> empty_uctx + +let declare_assumptions idl is_coe k (c,uctx) pl imps nl = + let refs, status, _ = + List.fold_left (fun (refs,status,uctx) id -> + let ref',u',status' = + declare_assumption is_coe k (c,uctx) pl imps false nl id in + (ref',u')::refs, status' && status, next_uctx uctx) + ([],true,uctx) idl + in + List.rev refs, status + + +let maybe_error_many_udecls = function + | ((loc,id), Some _) -> + user_err ?loc ~hdr:"many_universe_declarations" + Pp.(str "When declaring multiple axioms in one command, " ++ + str "only the first is allowed a universe binder " ++ + str "(which will be shared by the whole block).") + | (_, None) -> () + +let process_assumptions_udecls kind l = + let udecl, first_id = match l with + | (coe, ((id, udecl)::rest, c))::rest' -> + List.iter maybe_error_many_udecls rest; + List.iter (fun (coe, (idl, c)) -> List.iter maybe_error_many_udecls idl) rest'; + udecl, id + | (_, ([], _))::_ | [] -> assert false + in + let () = match kind, udecl with + | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> + let loc = fst first_id in + let msg = Pp.str "Section variables cannot be polymorphic." in + user_err ?loc msg + | _ -> () + in + udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l + +let do_assumptions kind nl l = + let open Context.Named.Declaration in + let env = Global.env () in + let udecl, l = process_assumptions_udecls kind l in + let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in + let l = + if pi2 kind (* poly *) then + (* Separate declarations so that A B : Type puts A and B in different levels. *) + List.fold_right (fun (is_coe,(idl,c)) acc -> + List.fold_right (fun id acc -> + (is_coe, ([id], c)) :: acc) idl acc) + l [] + else l + in + (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) + let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> + let sigma,(t,imps) = interp_assumption sigma env ienv [] c in + let env = + push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in + let ienv = List.fold_right (fun (_,id) ienv -> + let impls = compute_internalization_data env Variable t imps in + Id.Map.add id impls ienv) idl ienv in + ((sigma,env,ienv),((is_coe,idl),t,imps))) + (sigma,env,empty_internalization_env) l + in + let sigma = solve_remaining_evars all_and_fail_flags env sigma Evd.empty in + (* The universe constraints come from the whole telescope. *) + let sigma = Evd.nf_constraints sigma in + let nf_evar c = EConstr.to_constr sigma (EConstr.of_constr c) in + let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) -> + let t = nf_evar t in + let uvars = Univ.LSet.union uvars (Univops.universes_of_constr env t) in + uvars, (coe,t,imps)) + Univ.LSet.empty l + in + let sigma = Evd.restrict_universe_context sigma uvars in + let uctx = Evd.check_univ_decl ~poly:(pi2 kind) sigma udecl in + let ubinders = Evd.universe_binders sigma in + pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> + let t = replace_vars subst t in + let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let subst' = List.map2 + (fun (_,id) (c,u) -> (id, Universes.constr_of_global_univ (c,u))) + idl refs + in + subst'@subst, status' && status, next_uctx uctx) + ([], true, uctx) l) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli new file mode 100644 index 000000000..2fa156abd --- /dev/null +++ b/vernac/comAssumption.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Constr +open Entries +open Globnames +open Vernacexpr +open Constrexpr +open Decl_kinds + +(** {6 Parameters/Assumptions} *) + +val do_assumptions : locality * polymorphic * assumption_object_kind -> + Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Exported for Classes *) + +(** returns [false] if the assumption is neither local to a section, + nor in a module type and meant to be instantiated. *) +val declare_assumption : coercion_flag -> assumption_kind -> + types in_constant_universes_entry -> + Universes.universe_binders -> Impargs.manual_implicits -> + bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> + global_reference * Univ.Instance.t * bool diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml new file mode 100644 index 000000000..d376696f7 --- /dev/null +++ b/vernac/comDefinition.ml @@ -0,0 +1,132 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open Constr +open Environ +open Entries +open Redexpr +open Declare +open Constrintern +open Pretyping + +open Context.Rel.Declaration + +(* Commands of the interface: Constant definitions *) + +let rec under_binders env sigma f n c = + if Int.equal n 0 then f env sigma (EConstr.of_constr c) else + match Constr.kind c with + | Lambda (x,t,c) -> + mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c) + | LetIn (x,b,t,c) -> + mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) + | _ -> assert false + +let red_constant_entry n ce sigma = function + | None -> ce + | Some red -> + let proof_out = ce.const_entry_body in + let env = Global.env () in + let (redfun, _) = reduction_of_red_expr env red in + let redfun env sigma c = + let (_, c) = redfun env sigma c in + EConstr.Unsafe.to_constr c + in + { ce with const_entry_body = Future.chain proof_out + (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } + +let warn_implicits_in_term = + CWarnings.create ~name:"implicits-in-term" ~category:"implicits" + (fun () -> + strbrk "Implicit arguments declaration relies on type." ++ spc () ++ + strbrk "The term declares more implicits than the type here.") + +let check_imps ~impsty ~impsbody = + let b = + try + List.for_all (fun (key, (va:bool*bool*bool)) -> + (* Pervasives.(=) is OK for this type *) + Pervasives.(=) (List.assoc_f Impargs.explicitation_eq key impsty) va) + impsbody + with Not_found -> false + in + if not b then warn_implicits_in_term () + +let interp_definition pl bl poly red_option c ctypopt = + let open EConstr in + let env = Global.env() in + (* Explicitly bound universes and constraints *) + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + (* Build the parameters *) + let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars env evd bl in + (* Build the type *) + let evd, tyopt = Option.fold_left_map + (interp_type_evars_impls ~impls env_bl) + evd ctypopt + in + (* Build the body, and merge implicits from parameters and from type/body *) + let evd, c, imps, tyopt = + match tyopt with + | None -> + let evd, (c, impsbody) = interp_constr_evars_impls ~impls env_bl evd c in + evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsbody, None + | Some (ty, impsty) -> + let evd, (c, impsbody) = interp_casted_constr_evars_impls ~impls env_bl evd c ty in + check_imps ~impsty ~impsbody; + evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsty, Some ty + in + (* universe minimization *) + let evd = Evd.nf_constraints evd in + (* Substitute evars and universes, and add parameters. + Note: in program mode some evars may remain. *) + let ctx = List.map (EConstr.to_rel_decl evd) ctx in + let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr evd c) ctx in + let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr evd ty) ctx) tyopt in + (* Keep only useful universes. *) + let uvars_fold uvars c = + Univ.LSet.union uvars (universes_of_constr env evd (of_constr c)) + in + let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in + let evd = Evd.restrict_universe_context evd uvars in + (* Check we conform to declared universes *) + let uctx = Evd.check_univ_decl ~poly evd decl in + (* We're done! *) + let ce = definition_entry ?types:tyopt ~univs:uctx c in + (red_constant_entry (Context.Rel.length ctx) ce evd red_option, evd, decl, imps) + +let check_definition (ce, evd, _, imps) = + check_evars_are_solved (Global.env ()) evd Evd.empty; + ce + +let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = + let (ce, evd, univdecl, imps as def) = + interp_definition univdecl bl (pi2 k) red_option c ctypopt + in + if program_mode then + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.const_entry_body in + assert(Safe_typing.empty_private_constants = sideff); + assert(Univ.ContextSet.is_empty ctx); + let typ = match ce.const_entry_type with + | Some t -> t + | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) + in + Obligations.check_evars env evd; + let obls, _, c, cty = + Obligations.eterm_obligations env ident evd 0 c typ + in + let ctx = Evd.evar_universe_context evd in + let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in + ignore(Obligations.add_definition + ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) + else let ce = check_definition def in + ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps + (Lemmas.mk_hook + (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli new file mode 100644 index 000000000..4a65c1e91 --- /dev/null +++ b/vernac/comDefinition.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Entries +open Decl_kinds +open Redexpr +open Constrexpr + +(** {6 Definitions/Let} *) + +val do_definition : program_mode:bool -> + Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> + local_binder_expr list -> red_expr option -> constr_expr -> + constr_expr option -> unit Lemmas.declaration_hook -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Not used anywhere. *) +val interp_definition : + Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> + constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * + Univdecls.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml new file mode 100644 index 000000000..d648e293a --- /dev/null +++ b/vernac/comFixpoint.ml @@ -0,0 +1,356 @@ +open Pp +open CErrors +open Util +open Constr +open Vars +open Termops +open Declare +open Names +open Constrexpr +open Constrexpr_ops +open Constrintern +open Decl_kinds +open Pretyping +open Evarutil +open Evarconv +open Misctypes +open Vernacexpr + +module RelDecl = Context.Rel.Declaration + +(* 3c| Fixpoints and co-fixpoints *) + +(* An (unoptimized) function that maps preorders to partial orders... + + Input: a list of associations (x,[y1;...;yn]), all yi distincts + and different of x, meaning x<=y1, ..., x<=yn + + Output: a list of associations (x,Inr [y1;...;yn]), collecting all + distincts yi greater than x, _or_, (x, Inl y) meaning that + x is in the same class as y (in which case, x occurs + nowhere else in the association map) + + partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list +*) + +let rec partial_order cmp = function + | [] -> [] + | (x,xge)::rest -> + let rec browse res xge' = function + | [] -> + let res = List.map (function + | (z, Inr zge) when List.mem_f cmp x zge -> + (z, Inr (List.union cmp zge xge')) + | r -> r) res in + (x,Inr xge')::res + | y::xge -> + let rec link y = + try match List.assoc_f cmp y res with + | Inl z -> link z + | Inr yge -> + if List.mem_f cmp x yge then + let res = List.remove_assoc_f cmp y res in + let res = List.map (function + | (z, Inl t) -> + if cmp t y then (z, Inl x) else (z, Inl t) + | (z, Inr zge) -> + if List.mem_f cmp y zge then + (z, Inr (List.add_set cmp x (List.remove cmp y zge))) + else + (z, Inr zge)) res in + browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) + else + browse res (List.add_set cmp y (List.union cmp xge' yge)) xge + with Not_found -> browse res (List.add_set cmp y xge') xge + in link y + in browse (partial_order cmp rest) [] xge + +let non_full_mutual_message x xge y yge isfix rest = + let reason = + if Id.List.mem x yge then + Id.print y ++ str " depends on " ++ Id.print x ++ strbrk " but not conversely" + else if Id.List.mem y xge then + Id.print x ++ str " depends on " ++ Id.print y ++ strbrk " but not conversely" + else + Id.print y ++ str " and " ++ Id.print x ++ strbrk " are not mutually dependent" in + let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in + let k = if isfix then "fixpoint" else "cofixpoint" in + let w = + if isfix + then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() + else mt () in + strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ + str "(" ++ e ++ str ")." ++ fnl () ++ w + +let warn_non_full_mutual = + CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" + (fun (x,xge,y,yge,isfix,rest) -> + non_full_mutual_message x xge y yge isfix rest) + +let check_mutuality env evd isfix fixl = + let names = List.map fst fixl in + let preorder = + List.map (fun (id,def) -> + (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' (EConstr.of_constr def)) names)) + fixl in + let po = partial_order Id.equal preorder in + match List.filter (function (_,Inr _) -> true | _ -> false) po with + | (x,Inr xge)::(y,Inr yge)::rest -> + warn_non_full_mutual (x,xge,y,yge,isfix,rest) + | _ -> () + +type structured_fixpoint_expr = { + fix_name : Id.t; + fix_univs : universe_decl_expr option; + fix_annot : Id.t Loc.located option; + fix_binders : local_binder_expr list; + fix_body : constr_expr option; + fix_type : constr_expr +} + +let interp_fix_context ~cofix env sigma fix = + let before, after = if not cofix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in + let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars env sigma before in + let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in + let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in + sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) + +let interp_fix_ccl sigma impls (env,_) fix = + interp_type_evars_impls ~impls env sigma fix.fix_type + +let interp_fix_body env_rec sigma impls (_,ctx) fix ccl = + let open EConstr in + Option.cata (fun body -> + let env = push_rel_context ctx env_rec in + let sigma, body = interp_casted_constr_evars env sigma ~impls body ccl in + sigma, Some (it_mkLambda_or_LetIn body ctx)) (sigma, None) fix.fix_body + +let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx + +let prepare_recursive_declaration fixnames fixtypes fixdefs = + let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in + let names = List.map (fun id -> Name id) fixnames in + (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) + +(* Jump over let-bindings. *) + +let compute_possible_guardness_evidences (ctx,_,recindex) = + (* A recursive index is characterized by the number of lambdas to + skip before finding the relevant inductive argument *) + match recindex with + | Some i -> [i] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + List.interval 0 (Context.Rel.nhyps ctx - 1) + +type recursive_preentry = + Id.t list * constr option list * types list + +(* Wellfounded definition *) + +let contrib_name = "Program" +let subtac_dir = [contrib_name] +let tactics_module = subtac_dir @ ["Tactics"] + +let init_constant dir s sigma = + Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) + +let fix_proto = init_constant tactics_module "fix_proto" + +let interp_recursive ~program_mode ~cofix fixl notations = + let open Context.Named.Declaration in + let open EConstr in + let env = Global.env() in + let fixnames = List.map (fun fix -> fix.fix_name) fixl in + + (* Interp arities allowing for unresolved types *) + let all_universes = + List.fold_right (fun sfe acc -> + match sfe.fix_univs , acc with + | None , acc -> acc + | x , None -> x + | Some ls , Some us -> + let lsu = ls.univdecl_instance and usu = us.univdecl_instance in + if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then + user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); + Some us) fixl None in + let sigma, decl = Univdecls.interp_univ_decl_opt env all_universes in + let sigma, (fixctxs, fiximppairs, fixannots) = + on_snd List.split3 @@ + List.fold_left_map (fun sigma -> interp_fix_context env sigma ~cofix) sigma fixl in + let fixctximpenvs, fixctximps = List.split fiximppairs in + let sigma, (fixccls,fixcclimps) = + on_snd List.split @@ + List.fold_left3_map interp_fix_ccl sigma fixctximpenvs fixctxs fixl in + let fixtypes = List.map2 build_fix_type fixctxs fixccls in + let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in + let fiximps = List.map3 + (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (Context.Rel.nhyps ctx) cclimps)) + fixctximps fixcclimps fixctxs in + let sigma, rec_sign = + List.fold_left2 + (fun (sigma, env') id t -> + if program_mode then + let sigma, sort = Typing.type_of ~refresh:true env sigma t in + let sigma, fixprot = + try + let sigma, h_term = fix_proto sigma in + let app = mkApp (h_term, [|sort; t|]) in + let _evd = ref sigma in + let res = Typing.e_solve_evars env _evd app in + !_evd, res + with e when CErrors.noncritical e -> sigma, t + in + sigma, LocalAssum (id,fixprot) :: env' + else sigma, LocalAssum (id,t) :: env') + (sigma,[]) fixnames fixtypes + in + let env_rec = push_named_context rec_sign env in + + (* Get interpretation metadatas *) + let fixtypes = List.map EConstr.Unsafe.to_constr fixtypes in + let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in + + (* Interp bodies with rollback because temp use of notations/implicit *) + let sigma, fixdefs = + Metasyntax.with_syntax_protection (fun () -> + List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; + List.fold_left4_map + (fun sigma fixctximpenv -> interp_fix_body env_rec sigma (Id.Map.fold Id.Map.add fixctximpenv impls)) + sigma fixctximpenvs fixctxs fixl fixccls) + () in + + (* Instantiate evars and check all are resolved *) + let sigma = solve_unif_constraints_with_heuristics env_rec sigma in + let sigma, nf = nf_evars_and_universes sigma in + let fixdefs = List.map (fun c -> Option.map EConstr.Unsafe.to_constr c) fixdefs in + let fixdefs = List.map (Option.map nf) fixdefs in + let fixtypes = List.map nf fixtypes in + let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in + + (* Build the fix declaration block *) + (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + +let check_recursive isfix env evd (fixnames,fixdefs,_) = + check_evars_are_solved env evd Evd.empty; + if List.for_all Option.has_some fixdefs then begin + let fixdefs = List.map Option.get fixdefs in + check_mutuality env evd isfix (List.combine fixnames fixdefs) + end + +let interp_fixpoint ~cofix l ntns = + let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in + check_recursive true env evd fix; + (fix,pl,Evd.evar_universe_context evd,info) + +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + if List.exists Option.is_empty fixdefs then + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let env = Global.env() in + let indexes = search_guard env indexes fixdecls in + let fiximps = List.map (fun (n,r,p) -> r) fiximps in + let vars = Univops.universes_of_constr env (mkFix ((indexes,0),fixdecls)) in + let fixdecls = + List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + fixpoint_message (Some indexes) fixnames; + end; + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + if List.exists Option.is_empty fixdefs then + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in + let env = Global.env () in + let vars = Univops.universes_of_constr env (List.hd fixdecls) in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + cofixpoint_message fixnames + end; + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + +let extract_decreasing_argument limit = function + | (na,CStructRec) -> na + | (na,_) when not limit -> na + | _ -> user_err Pp.(str + "Only structural decreasing is supported for a non-Program Fixpoint") + +let extract_fixpoint_components limit l = + let fixl, ntnl = List.split l in + let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> + let ann = extract_decreasing_argument limit ann in + {fix_name = id; fix_annot = ann; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + fixl, List.flatten ntnl + +let extract_cofixpoint_components l = + let fixl, ntnl = List.split l in + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.flatten ntnl + +let check_safe () = + let open Declarations in + let flags = Environ.typing_flags (Global.env ()) in + flags.check_universes && flags.check_guarded + +let do_fixpoint local poly l = + let fixl, ntns = extract_fixpoint_components true l in + let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in + let possible_indexes = + List.map compute_possible_guardness_evidences info in + declare_fixpoint local poly fix possible_indexes ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint local poly l = + let fixl,ntns = extract_cofixpoint_components l in + let cofix = interp_fixpoint ~cofix:true fixl ntns in + declare_cofixpoint local poly cofix ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli new file mode 100644 index 000000000..2c84bd84d --- /dev/null +++ b/vernac/comFixpoint.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Constr +open Decl_kinds +open Constrexpr +open Vernacexpr + +(** {6 Fixpoints and cofixpoints} *) + +(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) + +val do_fixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +type structured_fixpoint_expr = { + fix_name : Id.t; + fix_univs : Vernacexpr.universe_decl_expr option; + fix_annot : Id.t Loc.located option; + fix_binders : local_binder_expr list; + fix_body : constr_expr option; + fix_type : constr_expr +} + +(** Typing global fixpoints and cofixpoint_expr *) + +(** Exported for Program *) +val interp_recursive : + (* Misc arguments *) + program_mode:bool -> cofix:bool -> + (* Notations of the fixpoint / should that be folded in the previous argument? *) + structured_fixpoint_expr list -> decl_notation list -> + + (* env / signature / univs / evar_map *) + (Environ.env * EConstr.named_context * Univdecls.universe_decl * Evd.evar_map) * + (* names / defs / types *) + (Id.t list * Constr.constr option list * Constr.types list) * + (* ctx per mutual def / implicits / struct annotations *) + (EConstr.rel_context * Impargs.manual_explicitation list * int option) list + +(** Exported for Funind *) + +(** Extracting the semantical components out of the raw syntax of + (co)fixpoints declarations *) + +val extract_fixpoint_components : bool -> + (fixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +val extract_cofixpoint_components : + (cofixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +type recursive_preentry = + Id.t list * constr option list * types list + +val interp_fixpoint : + cofix:bool -> + structured_fixpoint_expr list -> decl_notation list -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list + +(** Registering fixpoints and cofixpoints in the environment *) +(** [Not used so far] *) +val declare_fixpoint : + locality -> polymorphic -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (Context.Rel.t * Impargs.manual_implicits * int option) list -> + Proof_global.lemma_possible_guards -> decl_notation list -> unit + +val declare_cofixpoint : locality -> polymorphic -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (Context.Rel.t * Impargs.manual_implicits * int option) list -> + decl_notation list -> unit + +(** Very private function, do not use *) +val compute_possible_guardness_evidences : + ('a, 'b) Context.Rel.pt * 'c * int option -> int list diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml new file mode 100644 index 000000000..41474fc63 --- /dev/null +++ b/vernac/comInductive.ml @@ -0,0 +1,455 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Sorts +open Util +open Constr +open Termops +open Environ +open Declare +open Names +open Libnames +open Globnames +open Nameops +open Constrexpr +open Constrexpr_ops +open Constrintern +open Nametab +open Impargs +open Reductionops +open Indtypes +open Pretyping +open Evarutil +open Indschemes +open Misctypes +open Context.Rel.Declaration +open Entries + +module RelDecl = Context.Rel.Declaration + +(* 3b| Mutual inductive definitions *) + +let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function + | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) + | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) + | CHole (k, _, _) -> + let (has_no_args,name,params) = a in + if not has_no_args then + user_err ?loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " + ++ Id.print cs ++ str "."); + let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in + CAppExpl ((None,Ident(loc,name),None),List.rev args) + | c -> c + ) + +let push_types env idl tl = + List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) + env idl tl + +type structured_one_inductive_expr = { + ind_name : Id.t; + ind_univs : Vernacexpr.universe_decl_expr option; + ind_arity : constr_expr; + ind_lc : (Id.t * constr_expr) list +} + +type structured_inductive_expr = + local_binder_expr list * structured_one_inductive_expr list + +let minductive_message warn = function + | [] -> user_err Pp.(str "No inductive definition.") + | [x] -> (Id.print x ++ str " is defined" ++ + if warn then str " as a non-primitive record" else mt()) + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are defined") + +let check_all_names_different indl = + let ind_names = List.map (fun ind -> ind.ind_name) indl in + let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in + let l = List.duplicates Id.equal ind_names in + let () = match l with + | [] -> () + | t :: _ -> raise (InductiveError (SameNamesTypes t)) + in + let l = List.duplicates Id.equal cstr_names in + let () = match l with + | [] -> () + | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) + in + let l = List.intersect Id.equal ind_names cstr_names in + match l with + | [] -> () + | _ -> raise (InductiveError (SameNamesOverlap l)) + +let mk_mltype_data sigma env assums arity indname = + let is_ml_type = is_sort env sigma (EConstr.of_constr arity) in + (is_ml_type,indname,assums) + +let prepare_param = function + | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t + | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b + +(** Make the arity conclusion flexible to avoid generating an upper bound universe now, + only if the universe does not appear anywhere else. + This is really a hack to stay compatible with the semantics of template polymorphic + inductives which are recognized when a "Type" appears at the end of the conlusion in + the source syntax. *) + +let rec check_anonymous_type ind = + let open Glob_term in + match DAst.get ind with + | GSort (GType []) -> true + | GProd ( _, _, _, e) + | GLetIn (_, _, _, e) + | GLambda (_, _, _, e) + | GApp (e, _) + | GCast (e, _) -> check_anonymous_type e + | _ -> false + +let make_conclusion_flexible sigma ty poly = + if poly && Term.isArity ty then + let _, concl = Term.destArity ty in + match concl with + | Type u -> + (match Univ.universe_level u with + | Some u -> + Evd.make_flexible_variable sigma ~algebraic:true u + | None -> sigma) + | _ -> sigma + else sigma + +let is_impredicative env u = + u = Prop Null || (is_impredicative_set env && u = Prop Pos) + +let interp_ind_arity env sigma ind = + let c = intern_gen IsType env ind.ind_arity in + let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let sigma,t = understand_tcc env sigma ~expected_type:IsType c in + let pseudo_poly = check_anonymous_type c in + let () = if not (Reductionops.is_arity env sigma t) then + user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") + in + let t = EConstr.Unsafe.to_constr t in + sigma, (t, pseudo_poly, impls) + +let interp_cstrs env sigma impls mldata arity ind = + let cnames,ctyps = List.split ind.ind_lc in + (* Complete conclusions of constructor types if given in ML-style syntax *) + let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in + (* Interpret the constructor types *) + let sigma, (ctyps'', cimpls) = + on_snd List.split @@ + List.fold_left_map (fun sigma l -> + on_snd (on_fst EConstr.Unsafe.to_constr) @@ + interp_type_evars_impls env sigma ~impls l) sigma ctyps' in + sigma, (cnames, ctyps'', cimpls) + +let sign_level env evd sign = + fst (List.fold_right + (fun d (lev,env) -> + match d with + | LocalDef _ -> lev, push_rel d env + | LocalAssum _ -> + let s = destSort (Reduction.whd_all env + (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))) + in + let u = univ_of_sort s in + (Univ.sup u lev, push_rel d env)) + sign (Univ.type0m_univ,env)) + +let sup_list min = List.fold_left Univ.sup min + +let extract_level env evd min tys = + let sorts = List.map (fun ty -> + let ctx, concl = Reduction.dest_prod_assum env ty in + sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys + in sup_list min sorts + +let is_flexible_sort evd u = + match Univ.Universe.level u with + | Some l -> Evd.is_flexible_level evd l + | None -> false + +let inductive_levels env evd poly arities inds = + let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in + let levels = List.map (fun (x,(ctx,a)) -> + if a = Prop Null then None + else Some (univ_of_sort a)) destarities + in + let cstrs_levels, min_levels, sizes = + CList.split3 + (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> + let len = List.length tys in + let minlev = Sorts.univ_of_sort du in + let minlev = + if len > 1 && not (is_impredicative env du) then + Univ.sup minlev Univ.type0_univ + else minlev + in + let minlev = + (** Indices contribute. *) + if Indtypes.is_indices_matter () && List.length ctx > 0 then ( + let ilev = sign_level env evd ctx in + Univ.sup ilev minlev) + else minlev + in + let clev = extract_level env evd minlev tys in + (clev, minlev, len)) inds destarities) + in + (* Take the transitive closure of the system of constructors *) + (* level constraints and remove the recursive dependencies *) + let levels' = Universes.solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) (Array.of_list min_levels) + in + let evd, arities = + CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> + if is_impredicative env du then + (** Any product is allowed here. *) + evd, arity :: arities + else (** If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor + *) + (** Constructors contribute. *) + let evd = + if Sorts.is_set du then + if not (Evd.check_leq evd cu Univ.type0_univ) then + raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + else evd + else evd + (* Evd.set_leq_sort env evd (Type cu) du *) + in + let evd = + if len >= 2 && Univ.is_type0m_univ cu then + (** "Polymorphic" type constraint and more than one constructor, + should not land in Prop. Add constraint only if it would + land in Prop directly (no informative arguments as well). *) + Evd.set_leq_sort env evd (Prop Pos) du + else evd + in + let duu = Sorts.univ_of_sort du in + let evd = + if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then + Evd.set_eq_sort env evd (Prop Null) du + else evd + else Evd.set_eq_sort env evd (Type cu) du + in + (evd, arity :: arities)) + (evd,[]) (Array.to_list levels') destarities sizes + in evd, List.rev arities + +let check_named (loc, na) = match na with +| Name _ -> () +| Anonymous -> + let msg = str "Parameters must be named." in + user_err ?loc msg + + +let check_param = function +| CLocalDef (na, _, _) -> check_named na +| CLocalAssum (nas, Default _, _) -> List.iter check_named nas +| CLocalAssum (nas, Generalized _, _) -> () +| CLocalPattern (loc,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") + +let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = + check_all_names_different indl; + List.iter check_param paramsl; + let env0 = Global.env() in + let pl = (List.hd indl).ind_univs in + let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let sigma, (impls, ((env_params, ctx_params), userimpls)) = + interp_context_evars env0 sigma paramsl + in + let ctx_params = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx_params in + let indnames = List.map (fun ind -> ind.ind_name) indl in + + (* Names of parameters as arguments of the inductive type (defs removed) *) + let assums = List.filter is_local_assum ctx_params in + let params = List.map (RelDecl.get_name %> Name.get_id) assums in + + (* Interpret the arities *) + let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + + let fullarities = List.map (fun (c, _, _) -> Term.it_mkProd_or_LetIn c ctx_params) arities in + let env_ar = push_types env0 indnames fullarities in + let env_ar_params = push_rel_context ctx_params env_ar in + + (* Compute interpretation metadatas *) + let indimpls = List.map (fun (_, _, impls) -> userimpls @ + lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in + let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in + let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in + let ntn_impls = compute_internalization_env env0 (Inductive (params,true)) indnames fullarities indimpls in + let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in + + let sigma, constructors = + Metasyntax.with_syntax_protection (fun () -> + (* Temporary declaration of notations and scopes *) + List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; + (* Interpret the constructor types *) + List.fold_left3_map (fun sigma -> interp_cstrs env_ar_params sigma impls) sigma mldatas arities indl) + () in + + (* Try further to solve evars, and instantiate them *) + let sigma = solve_remaining_evars all_and_fail_flags env_params sigma Evd.empty in + (* Compute renewed arities *) + let sigma, nf = nf_evars_and_universes sigma in + let arities = List.map nf arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in + let sigma = List.fold_left2 (fun sigma ty poly -> make_conclusion_flexible sigma ty poly) sigma arities aritypoly in + let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in + let sigma, nf' = nf_evars_and_universes sigma in + let nf x = nf' (nf x) in + let arities = List.map nf' arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in + let ctx_params = Context.Rel.map nf ctx_params in + let uctx = Evd.check_univ_decl ~poly sigma decl in + List.iter (fun c -> check_evars env_params Evd.empty sigma (EConstr.of_constr c)) arities; + Context.Rel.iter (fun c -> check_evars env0 Evd.empty sigma (EConstr.of_constr c)) ctx_params; + List.iter (fun (_,ctyps,_) -> + List.iter (fun c -> check_evars env_ar_params Evd.empty sigma (EConstr.of_constr c)) ctyps) + constructors; + + (* Build the inductive entries *) + let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { + mind_entry_typename = ind.ind_name; + mind_entry_arity = arity; + mind_entry_template = template; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) indl arities aritypoly constructors in + let impls = + let len = Context.Rel.nhyps ctx_params in + List.map2 (fun indimpls (_,_,cimpls) -> + indimpls, List.map (fun impls -> + userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors + in + let univs = + match uctx with + | Polymorphic_const_entry uctx -> + if cum then + Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context uctx) + else Polymorphic_ind_entry uctx + | Monomorphic_const_entry uctx -> + Monomorphic_ind_entry uctx + in + (* Build the mutual inductive entry *) + let mind_ent = + { mind_entry_params = List.map prepare_param ctx_params; + mind_entry_record = None; + mind_entry_finite = finite; + mind_entry_inds = entries; + mind_entry_private = if prv then Some false else None; + mind_entry_universes = univs; + } + in + (if poly && cum then + InferCumulativity.infer_inductive env_ar mind_ent + else mind_ent), Evd.universe_binders sigma, impls + +(* Very syntactical equality *) +let eq_local_binders bl1 bl2 = + List.equal local_binder_eq bl1 bl2 + +let extract_coercions indl = + let mkqid (_,((_,id),_)) = qualid_of_ident id in + let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in + List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) + +let extract_params indl = + let paramsl = List.map (fun (_,params,_,_) -> params) indl in + match paramsl with + | [] -> anomaly (Pp.str "empty list of inductive types.") + | params::paramsl -> + if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str + "Parameters should be syntactically the same for each inductive type."); + params + +let extract_inductive indl = + List.map (fun (((_,indname),pl),_,ar,lc) -> { + ind_name = indname; ind_univs = pl; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; + ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc + }) indl + +let extract_mutual_inductive_declaration_components indl = + let indl,ntnl = List.split indl in + let params = extract_params indl in + let coes = extract_coercions indl in + let indl = extract_inductive indl in + (params,indl), coes, List.flatten ntnl + +let is_recursive mie = + let rec is_recursive_constructor lift typ = + match Constr.kind typ with + | Prod (_,arg,rest) -> + not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || + is_recursive_constructor (lift+1) rest + | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest + | _ -> false + in + match mie.mind_entry_inds with + | [ind] -> + let nparams = List.length mie.mind_entry_params in + List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc + | _ -> false + +let declare_mutual_inductive_with_eliminations mie pl impls = + (* spiwack: raises an error if the structure is supposed to be non-recursive, + but isn't *) + begin match mie.mind_entry_finite with + | Declarations.BiFinite when is_recursive mie -> + if Option.has_some mie.mind_entry_record then + user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") + else + user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) + | _ -> () + end; + let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in + let (_, kn), prim = declare_mind mie in + let mind = Global.mind_of_delta_kn kn in + List.iteri (fun i (indimpls, constrimpls) -> + let ind = (mind,i) in + let gr = IndRef ind in + maybe_declare_manual_implicits false gr indimpls; + Declare.declare_univ_binders gr pl; + List.iteri + (fun j impls -> + maybe_declare_manual_implicits false + (ConstructRef (ind, succ j)) impls) + constrimpls) + impls; + let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in + Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); + if mie.mind_entry_private == None + then declare_default_schemes mind; + mind + +type one_inductive_impls = + Impargs.manual_explicitation list (* for inds *)* + Impargs.manual_explicitation list list (* for constrs *) + +let do_mutual_inductive indl cum poly prv finite = + let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in + (* Interpret the types *) + let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in + (* Declare the mutual inductive block with its associated schemes *) + ignore (declare_mutual_inductive_with_eliminations mie pl impls); + (* Declare the possible notations of inductive types *) + List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; + (* Declare the coercions *) + List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes; + (* If positivity is assumed declares itself as unsafe. *) + if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli new file mode 100644 index 000000000..82ea131e1 --- /dev/null +++ b/vernac/comInductive.mli @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Entries +open Libnames +open Vernacexpr +open Constrexpr +open Decl_kinds + +(** {6 Inductive and coinductive types} *) + +(** Entry points for the vernacular commands Inductive and CoInductive *) + +val do_mutual_inductive : + (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Declarations.recursivity_kind -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Exported for Record and Funind *) + +(** Registering a mutual inductive definition together with its + associated schemes *) + +type one_inductive_impls = + Impargs.manual_implicits (** for inds *)* + Impargs.manual_implicits list (** for constrs *) + +val declare_mutual_inductive_with_eliminations : + mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> + MutInd.t + +(** Exported for Funind *) + +(** Extracting the semantical components out of the raw syntax of mutual + inductive declarations *) + +type structured_one_inductive_expr = { + ind_name : Id.t; + ind_univs : Vernacexpr.universe_decl_expr option; + ind_arity : constr_expr; + ind_lc : (Id.t * constr_expr) list +} + +type structured_inductive_expr = + local_binder_expr list * structured_one_inductive_expr list + +val extract_mutual_inductive_declaration_components : + (one_inductive_expr * decl_notation list) list -> + structured_inductive_expr * (*coercions:*) qualid list * decl_notation list + +(** Typing mutual inductive definitions *) + +val interp_mutual_inductive : + structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Declarations.recursivity_kind -> + mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml new file mode 100644 index 000000000..a9a91e304 --- /dev/null +++ b/vernac/comProgramFixpoint.ml @@ -0,0 +1,342 @@ +open Pp +open CErrors +open Util +open Constr +open Entries +open Vars +open Declare +open Names +open Libnames +open Globnames +open Nameops +open Constrexpr +open Constrexpr_ops +open Constrintern +open Decl_kinds +open Evarutil +open Context.Rel.Declaration +open ComFixpoint + +module RelDecl = Context.Rel.Declaration + +(* Wellfounded definition *) + +open Coqlib + +let contrib_name = "Program" +let subtac_dir = [contrib_name] +let fixsub_module = subtac_dir @ ["Wf"] +(* let tactics_module = subtac_dir @ ["Tactics"] *) + +let init_reference dir s () = Coqlib.coq_reference "Command" dir s +let init_constant dir s sigma = + Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) + +let make_ref l s = init_reference l s +(* let fix_proto = init_constant tactics_module "fix_proto" *) +let fix_sub_ref = make_ref fixsub_module "Fix_sub" +let measure_on_R_ref = make_ref fixsub_module "MR" +let well_founded = init_constant ["Init"; "Wf"] "well_founded" +let mkSubset sigma name typ prop = + let open EConstr in + let sigma, app_h = Evarutil.new_global sigma (delayed_force build_sigma).typ in + sigma, mkApp (app_h, [| typ; mkLambda (name, typ, prop) |]) + +let sigT = Lazy.from_fun build_sigma_type + +let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) +let lt_ref = make_qref "Init.Peano.lt" + +let rec telescope sigma l = + let open EConstr in + let open Vars in + match l with + | [] -> assert false + | [LocalAssum (n, t)] -> + sigma, t, [LocalDef (n, mkRel 1, t)], mkRel 1 + | LocalAssum (n, t) :: tl -> + let sigma, ty, tys, (k, constr) = + List.fold_left + (fun (sigma, ty, tys, (k, constr)) decl -> + let t = RelDecl.get_type decl in + let pred = mkLambda (RelDecl.get_name decl, t, ty) in + let sigma, ty = Evarutil.new_global sigma (Lazy.force sigT).typ in + let sigma, intro = Evarutil.new_global sigma (Lazy.force sigT).intro in + let sigty = mkApp (ty, [|t; pred|]) in + let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in + (sigma, sigty, pred :: tys, (succ k, intro))) + (sigma, t, [], (2, mkRel 1)) tl + in + let sigma, last, subst = List.fold_right2 + (fun pred decl (sigma, prev, subst) -> + let t = RelDecl.get_type decl in + let sigma, p1 = Evarutil.new_global sigma (Lazy.force sigT).proj1 in + let sigma, p2 = Evarutil.new_global sigma (Lazy.force sigT).proj2 in + let proj1 = applist (p1, [t; pred; prev]) in + let proj2 = applist (p2, [t; pred; prev]) in + (sigma, lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) + (List.rev tys) tl (sigma, mkRel 1, []) + in sigma, ty, (LocalDef (n, last, t) :: subst), constr + + | LocalDef (n, b, t) :: tl -> + let sigma, ty, subst, term = telescope sigma tl in + sigma, ty, (LocalDef (n, b, t) :: subst), lift 1 term + +let nf_evar_context sigma ctx = + List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx + +let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = + let open EConstr in + let open Vars in + let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in + Coqlib.check_required_library ["Coq";"Program";"Wf"]; + let env = Global.env() in + let sigma, decl = Univdecls.interp_univ_decl_opt env pl in + let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars env sigma bl in + let len = List.length binders_rel in + let top_env = push_rel_context binders_rel env in + let sigma, top_arity = interp_type_evars top_env sigma arityc in + let full_arity = it_mkProd_or_LetIn top_arity binders_rel in + let sigma, argtyp, letbinders, make = telescope sigma binders_rel in + let argname = Id.of_string "recarg" in + let arg = LocalAssum (Name argname, argtyp) in + let binders = letbinders @ [arg] in + let binders_env = push_rel_context binders_rel env in + let sigma, (rel, _) = interp_constr_evars_impls env sigma r in + let relty = Typing.unsafe_type_of env sigma rel in + let relargty = + let error () = + user_err ?loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_econstr_env env sigma rel ++ str " is not an homogeneous binary relation.") + in + try + let ctx, ar = Reductionops.splay_prod_n env sigma 2 relty in + match ctx, EConstr.kind sigma ar with + | [LocalAssum (_,t); LocalAssum (_,u)], Sort s + when Sorts.is_prop (ESorts.kind sigma s) && Reductionops.is_conv env sigma t u -> t + | _, _ -> error () + with e when CErrors.noncritical e -> error () + in + let sigma, measure = interp_casted_constr_evars binders_env sigma measure relargty in + let sigma, wf_rel, wf_rel_fun, measure_fn = + let measure_body, measure = + it_mkLambda_or_LetIn measure letbinders, + it_mkLambda_or_LetIn measure binders + in + let sigma, comb = Evarutil.new_global sigma (delayed_force measure_on_R_ref) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel_fun x y = + mkApp (rel, [| subst1 x measure_body; + subst1 y measure_body |]) + in sigma, wf_rel, wf_rel_fun, measure + in + let sigma, wf_term = well_founded sigma in + let wf_proof = mkApp (wf_term, [| argtyp ; wf_rel |]) in + let argid' = Id.of_string (Id.to_string argname ^ "'") in + let wfarg sigma len = + let sigma, ss_term = mkSubset sigma (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1))) in + sigma, LocalAssum (Name argid', ss_term) + in + let sigma, intern_bl = + let sigma, wfa = wfarg sigma 1 in + sigma, wfa :: [arg] + in + let _intern_env = push_rel_context intern_bl env in + let sigma, proj = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.proj1 in + let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let projection = (* in wfarg :: arg :: before *) + mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) + in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let intern_arity = substl [projection] top_arity_let in + (* substitute the projection of wfarg for something, + now intern_arity is in wfarg :: arg *) + let sigma, wfa = wfarg sigma 1 in + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfa] in + let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in + let sigma, curry_fun = + let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in + let sigma, intro = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.intro in + let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in + let rcurry = mkApp (rel, [| measure; lift len measure |]) in + let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in + let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in + let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in + sigma, LocalDef (Name recname, body, ty) + in + let fun_bl = intern_fun_binder :: [arg] in + let lift_lets = lift_rel_context 1 letbinders in + let sigma, intern_body = + let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in + let (r, l, impls, scopes) = + Constrintern.compute_internalization_data env + Constrintern.Recursive (EConstr.Unsafe.to_constr full_arity) impls + in + let newimpls = Id.Map.singleton recname + (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], + scopes @ [None]) in + interp_casted_constr_evars (push_rel_context ctx env) sigma + ~impls:newimpls body (lift 1 top_arity) + in + let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in + let prop = mkLambda (Name argname, argtyp, top_arity_let) in + (* XXX: Previous code did parallel evdref update, so possible old + weak ordering semantics may bite here. *) + let sigma, def = + let sigma, h_a_term = Evarutil.new_global sigma (delayed_force fix_sub_ref) in + let sigma, h_e_term = Evarutil.new_evar env sigma + ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof in + sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |]) + in + let _evd = ref sigma in + let def = Typing.e_solve_evars env _evd def in + let sigma = !_evd in + let sigma = Evarutil.nf_evar_map sigma in + let def = mkApp (def, [|intern_body_lam|]) in + let binders_rel = nf_evar_context sigma binders_rel in + let binders = nf_evar_context sigma binders in + let top_arity = Evarutil.nf_evar sigma top_arity in + let hook, recname, typ = + if List.length binders_rel > 1 then + let name = add_suffix recname "_func" in + (* XXX: Mutating the evar_map in the hook! *) + (* XXX: Likely the sigma is out of date when the hook is called .... *) + let hook sigma l gr _ = + let sigma, h_body = Evarutil.new_global sigma gr in + let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in + let ty = it_mkProd_or_LetIn top_arity binders_rel in + let ty = EConstr.Unsafe.to_constr ty in + let univs = Evd.check_univ_decl ~poly sigma decl in + (*FIXME poly? *) + let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in + (** FIXME: include locality *) + let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in + let gr = ConstRef c in + let () = Universes.register_universe_binders gr (Evd.universe_binders sigma) in + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] + in + let typ = it_mkProd_or_LetIn top_arity binders in + hook, name, typ + else + let typ = it_mkProd_or_LetIn top_arity binders_rel in + let hook sigma l gr _ = + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] + in hook, recname, typ + in + (* XXX: Capturing sigma here... bad bad *) + let hook = Lemmas.mk_hook (hook sigma) in + let fullcoqc = EConstr.to_constr sigma def in + let fullctyp = EConstr.to_constr sigma typ in + Obligations.check_evars env sigma; + let evars, _, evars_def, evars_typ = + Obligations.eterm_obligations env recname sigma 0 fullcoqc fullctyp + in + let ctx = Evd.evar_universe_context sigma in + ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl + evars_typ ctx evars ~hook) + +let out_def = function + | Some def -> def + | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") + +let collect_evars_of_term evd c ty = + let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in + Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) + evars (Evd.from_ctx (Evd.evar_universe_context evd)) + +let do_program_recursive local poly fixkind fixl ntns = + let cofix = fixkind = Obligations.IsCoFixpoint in + let (env, rec_sign, pl, evd), fix, info = + interp_recursive ~cofix ~program_mode:true fixl ntns + in + (* Program-specific code *) + (* Get the interesting evars, those that were not instanciated *) + let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in + (* Solve remaining evars *) + let evd = nf_evar_map_undefined evd in + let collect_evars id def typ imps = + (* Generalize by the recursive prototypes *) + let def = + EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) + and typ = + EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) + in + let evm = collect_evars_of_term evd def typ in + let evars, _, def, typ = + Obligations.eterm_obligations env id evm + (List.length rec_sign) def typ + in (id, def, typ, imps, evars) + in + let (fixnames,fixdefs,fixtypes) = fix in + let fiximps = List.map pi2 info in + let fixdefs = List.map out_def fixdefs in + let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in + let () = if not cofix then begin + let possible_indexes = List.map ComFixpoint.compute_possible_guardness_evidences info in + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, + Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) + in + let indexes = + Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in + List.iteri (fun i _ -> + Inductive.check_fix env + ((indexes,i),fixdecls)) + fixl + end in + let ctx = Evd.evar_universe_context evd in + let kind = match fixkind with + | Obligations.IsFixpoint _ -> (local, poly, Fixpoint) + | Obligations.IsCoFixpoint -> (local, poly, CoFixpoint) + in + Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind + +let do_program_fixpoint local poly l = + let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in + match g, l with + | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> + let recarg = + match n with + | Some n -> mkIdentC (snd n) + | None -> + user_err ~hdr:"do_program_fixpoint" + (str "Recursive argument required for well-founded fixpoints") + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + + | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> + build_wellfounded (id, pl, n, bl, typ, out_def def) poly + (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn + + | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> + let fixl,ntns = extract_fixpoint_components true l in + let fixkind = Obligations.IsFixpoint g in + do_program_recursive local poly fixkind fixl ntns + + | _, _ -> + user_err ~hdr:"do_program_fixpoint" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") + +let extract_cofixpoint_components l = + let fixl, ntnl = List.split l in + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.flatten ntnl + +let check_safe () = + let open Declarations in + let flags = Environ.typing_flags (Global.env ()) in + flags.check_universes && flags.check_guarded + +let do_fixpoint local poly l = + do_program_fixpoint local poly l; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint local poly l = + let fixl,ntns = extract_cofixpoint_components l in + do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli new file mode 100644 index 000000000..943cb8efe --- /dev/null +++ b/vernac/comProgramFixpoint.mli @@ -0,0 +1,12 @@ +open Decl_kinds +open Vernacexpr + +(** Special Fixpoint handling when command is activated. *) + +val do_fixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit diff --git a/vernac/command.ml b/vernac/command.ml deleted file mode 100644 index 373e5a1be..000000000 --- a/vernac/command.ml +++ /dev/null @@ -1,1346 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Pp -open CErrors -open Sorts -open Util -open Constr -open Vars -open Termops -open Environ -open Redexpr -open Declare -open Names -open Libnames -open Globnames -open Nameops -open Constrexpr -open Constrexpr_ops -open Constrintern -open Nametab -open Impargs -open Reductionops -open Indtypes -open Decl_kinds -open Pretyping -open Evarutil -open Evarconv -open Indschemes -open Misctypes -open Vernacexpr -open Context.Rel.Declaration -open Entries - -module RelDecl = Context.Rel.Declaration - -let do_universe poly l = Declare.do_universe poly l -let do_constraint poly l = Declare.do_constraint poly l - -let rec under_binders env sigma f n c = - if Int.equal n 0 then f env sigma (EConstr.of_constr c) else - match Constr.kind c with - | Lambda (x,t,c) -> - mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c) - | LetIn (x,b,t,c) -> - mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) - | _ -> assert false - -let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function - | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) - | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) - | CHole (k, _, _) -> - let (has_no_args,name,params) = a in - if not has_no_args then - user_err ?loc - (strbrk"Cannot infer the non constant arguments of the conclusion of " - ++ Id.print cs ++ str "."); - let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in - CAppExpl ((None,Ident(loc,name),None),List.rev args) - | c -> c - ) - -(* Commands of the interface *) - -(* 1| Constant definitions *) - -let red_constant_entry n ce sigma = function - | None -> ce - | Some red -> - let proof_out = ce.const_entry_body in - let env = Global.env () in - let (redfun, _) = reduction_of_red_expr env red in - let redfun env sigma c = - let (_, c) = redfun env sigma c in - EConstr.Unsafe.to_constr c - in - { ce with const_entry_body = Future.chain proof_out - (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } - -let warn_implicits_in_term = - CWarnings.create ~name:"implicits-in-term" ~category:"implicits" - (fun () -> - strbrk "Implicit arguments declaration relies on type." ++ spc () ++ - strbrk "The term declares more implicits than the type here.") - -let interp_definition pl bl poly red_option c ctypopt = - let env = Global.env() in - let evd, decl = Univdecls.interp_univ_decl_opt env pl in - let evdref = ref evd in - let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in - let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in - let nb_args = Context.Rel.nhyps ctx in - let imps,pl,ce = - match ctypopt with - None -> - let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in - let env_bl = push_rel_context ctx env in - let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in - let c = EConstr.Unsafe.to_constr c in - let nf,subst = Evarutil.e_nf_evars_and_universes evdref in - let body = nf (it_mkLambda_or_LetIn c ctx) in - let vars = Univops.universes_of_constr body in - let evd = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.check_univ_decl ~poly evd decl in - let binders = Evd.universe_binders evd in - imps1@(Impargs.lift_implicits nb_args imps2), binders, - definition_entry ~univs:uctx body - | Some ctyp -> - let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in - let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in - let env_bl = push_rel_context ctx env in - let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in - let c = EConstr.Unsafe.to_constr c in - let nf, subst = Evarutil.e_nf_evars_and_universes evdref in - let body = nf (it_mkLambda_or_LetIn c ctx) in - let ty = EConstr.Unsafe.to_constr ty in - let typ = nf (Term.it_mkProd_or_LetIn ty ctx) in - let beq b1 b2 = if b1 then b2 else not b2 in - let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in - (* Check that all implicit arguments inferable from the term - are inferable from the type *) - let chk (key,va) = - impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) - in - if not (try List.for_all chk imps2 with Not_found -> false) - then warn_implicits_in_term (); - let vars = Univ.LSet.union (Univops.universes_of_constr body) - (Univops.universes_of_constr typ) in - let ctx = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.check_univ_decl ~poly ctx decl in - let binders = Evd.universe_binders evd in - imps1@(Impargs.lift_implicits nb_args impsty), binders, - definition_entry ~types:typ - ~univs:uctx body - in - red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, pl, imps - -let check_definition (ce, evd, _, _, imps) = - check_evars_are_solved (Global.env ()) evd Evd.empty; - ce - -let do_definition ident k univdecl bl red_option c ctypopt hook = - let (ce, evd, univdecl, pl', imps as def) = - interp_definition univdecl bl (pi2 k) red_option c ctypopt - in - if Flags.is_program_mode () then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Safe_typing.empty_private_constants = sideff); - assert(Univ.ContextSet.is_empty ctx); - let typ = match ce.const_entry_type with - | Some t -> t - | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) - in - Obligations.check_evars env evd; - let obls, _, c, cty = - Obligations.eterm_obligations env ident evd 0 c typ - in - let ctx = Evd.evar_universe_context evd in - let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in - ignore(Obligations.add_definition - ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) - else let ce = check_definition def in - ignore(DeclareDef.declare_definition ident k ce pl' imps - (Lemmas.mk_hook - (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) - -(* 2| Variable/Hypothesis/Parameter/Axiom declarations *) - -let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = -match local with -| Discharge when Lib.sections_are_opened () -> - let ctx = match ctx with - | Monomorphic_const_entry ctx -> ctx - | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx - in - let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in - let _ = declare_variable ident decl in - let () = assumption_message ident in - let () = - if not !Flags.quiet && Proof_global.there_are_pending_proofs () then - Feedback.msg_info (str"Variable" ++ spc () ++ Id.print ident ++ - strbrk " is not visible from current goals") - in - let r = VarRef ident in - let () = Typeclasses.declare_instance None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true false in - (r,Univ.Instance.empty,true) - -| Global | Local | Discharge -> - let local = DeclareDef.get_locality ident ~kind:"axiom" local in - let inl = match nl with - | NoInline -> None - | DefaultInline -> Some (Flags.get_inline_level()) - | InlineAt i -> Some i - in - let decl = (ParameterEntry (None,(c,ctx),inl), IsAssumption kind) in - let kn = declare_constant ident ~local decl in - let gr = ConstRef kn in - let () = maybe_declare_manual_implicits false gr imps in - let () = Universes.register_universe_binders gr pl in - let () = assumption_message ident in - let () = Typeclasses.declare_instance None false gr in - let () = if is_coe then Class.try_add_new_coercion gr ~local p in - let inst = match ctx with - | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx - | Monomorphic_const_entry _ -> Univ.Instance.empty - in - (gr,inst,Lib.is_modtype_strict ()) - -let interp_assumption evdref env impls bl c = - let c = mkCProdN ?loc:(local_binders_loc bl) bl c in - let ty, impls = interp_type_evars_impls env evdref ~impls c in - let ty = EConstr.Unsafe.to_constr ty in - (ty, impls) - -(* When monomorphic the universe constraints are declared with the first declaration only. *) -let next_uctx = - let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in - function - | Polymorphic_const_entry _ as uctx -> uctx - | Monomorphic_const_entry _ -> empty_uctx - -let declare_assumptions idl is_coe k (c,uctx) pl imps nl = - let refs, status, _ = - List.fold_left (fun (refs,status,uctx) id -> - let ref',u',status' = - declare_assumption is_coe k (c,uctx) pl imps false nl id in - (ref',u')::refs, status' && status, next_uctx uctx) - ([],true,uctx) idl - in - List.rev refs, status - - -let maybe_error_many_udecls = function - | ((loc,id), Some _) -> - user_err ?loc ~hdr:"many_universe_declarations" - Pp.(str "When declaring multiple axioms in one command, " ++ - str "only the first is allowed a universe binder " ++ - str "(which will be shared by the whole block).") - | (_, None) -> () - -let process_assumptions_udecls kind l = - let udecl, first_id = match l with - | (coe, ((id, udecl)::rest, c))::rest' -> - List.iter maybe_error_many_udecls rest; - List.iter (fun (coe, (idl, c)) -> List.iter maybe_error_many_udecls idl) rest'; - udecl, id - | (_, ([], _))::_ | [] -> assert false - in - let () = match kind, udecl with - | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> - let loc = fst first_id in - let msg = Pp.str "Section variables cannot be polymorphic." in - user_err ?loc msg - | _ -> () - in - udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l - -let do_assumptions kind nl l = - let open Context.Named.Declaration in - let env = Global.env () in - let udecl, l = process_assumptions_udecls kind l in - let evdref, udecl = - let evd, udecl = Univdecls.interp_univ_decl_opt env udecl in - ref evd, udecl - in - let l = - if pi2 kind (* poly *) then - (* Separate declarations so that A B : Type puts A and B in different levels. *) - List.fold_right (fun (is_coe,(idl,c)) acc -> - List.fold_right (fun id acc -> - (is_coe, ([id], c)) :: acc) idl acc) - l [] - else l - in - (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) - let _,l = List.fold_left_map (fun (env,ienv) (is_coe,(idl,c)) -> - let t,imps = interp_assumption evdref env ienv [] c in - let env = - push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in - let ienv = List.fold_right (fun (_,id) ienv -> - let impls = compute_internalization_data env Variable t imps in - Id.Map.add id impls ienv) idl ienv in - ((env,ienv),((is_coe,idl),t,imps))) - (env,empty_internalization_env) l - in - let evd = solve_remaining_evars all_and_fail_flags env !evdref Evd.empty in - (* The universe constraints come from the whole telescope. *) - let evd = Evd.nf_constraints evd in - let nf_evar c = EConstr.to_constr evd (EConstr.of_constr c) in - let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) -> - let t = nf_evar t in - let uvars = Univ.LSet.union uvars (Univops.universes_of_constr t) in - uvars, (coe,t,imps)) - Univ.LSet.empty l - in - let evd = Evd.restrict_universe_context evd uvars in - let uctx = Evd.check_univ_decl ~poly:(pi2 kind) evd udecl in - let ubinders = Evd.universe_binders evd in - pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> - let t = replace_vars subst t in - let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in - let subst' = List.map2 - (fun (_,id) (c,u) -> (id, Universes.constr_of_global_univ (c,u))) - idl refs - in - subst'@subst, status' && status, next_uctx uctx) - ([], true, uctx) l) - -(* 3a| Elimination schemes for mutual inductive definitions *) - -(* 3b| Mutual inductive definitions *) - -let push_types env idl tl = - List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) - env idl tl - -type structured_one_inductive_expr = { - ind_name : Id.t; - ind_univs : Vernacexpr.universe_decl_expr option; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list -} - -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - -let minductive_message warn = function - | [] -> user_err Pp.(str "No inductive definition.") - | [x] -> (Id.print x ++ str " is defined" ++ - if warn then str " as a non-primitive record" else mt()) - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are defined") - -let check_all_names_different indl = - let ind_names = List.map (fun ind -> ind.ind_name) indl in - let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in - let l = List.duplicates Id.equal ind_names in - let () = match l with - | [] -> () - | t :: _ -> raise (InductiveError (SameNamesTypes t)) - in - let l = List.duplicates Id.equal cstr_names in - let () = match l with - | [] -> () - | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) - in - let l = List.intersect Id.equal ind_names cstr_names in - match l with - | [] -> () - | _ -> raise (InductiveError (SameNamesOverlap l)) - -let mk_mltype_data evdref env assums arity indname = - let is_ml_type = is_sort env !evdref (EConstr.of_constr arity) in - (is_ml_type,indname,assums) - -let prepare_param = function - | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t - | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b - -(** Make the arity conclusion flexible to avoid generating an upper bound universe now, - only if the universe does not appear anywhere else. - This is really a hack to stay compatible with the semantics of template polymorphic - inductives which are recognized when a "Type" appears at the end of the conlusion in - the source syntax. *) - -let rec check_anonymous_type ind = - let open Glob_term in - match DAst.get ind with - | GSort (GType []) -> true - | GProd ( _, _, _, e) - | GLetIn (_, _, _, e) - | GLambda (_, _, _, e) - | GApp (e, _) - | GCast (e, _) -> check_anonymous_type e - | _ -> false - -let make_conclusion_flexible evdref ty poly = - if poly && Term.isArity ty then - let _, concl = Term.destArity ty in - match concl with - | Type u -> - (match Univ.universe_level u with - | Some u -> - evdref := Evd.make_flexible_variable !evdref ~algebraic:true u - | None -> ()) - | _ -> () - else () - -let is_impredicative env u = - u = Prop Null || (is_impredicative_set env && u = Prop Pos) - -let interp_ind_arity env evdref ind = - let c = intern_gen IsType env ind.ind_arity in - let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in - let (evd,t) = understand_tcc env !evdref ~expected_type:IsType c in - evdref := evd; - let pseudo_poly = check_anonymous_type c in - let () = if not (Reductionops.is_arity env !evdref t) then - user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") - in - let t = EConstr.Unsafe.to_constr t in - t, pseudo_poly, impls - -let interp_cstrs evdref env impls mldata arity ind = - let cnames,ctyps = List.split ind.ind_lc in - (* Complete conclusions of constructor types if given in ML-style syntax *) - let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in - (* Interpret the constructor types *) - let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls %> on_fst EConstr.Unsafe.to_constr) ctyps') in - (cnames, ctyps'', cimpls) - -let sign_level env evd sign = - fst (List.fold_right - (fun d (lev,env) -> - match d with - | LocalDef _ -> lev, push_rel d env - | LocalAssum _ -> - let s = destSort (Reduction.whd_all env - (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))) - in - let u = univ_of_sort s in - (Univ.sup u lev, push_rel d env)) - sign (Univ.type0m_univ,env)) - -let sup_list min = List.fold_left Univ.sup min - -let extract_level env evd min tys = - let sorts = List.map (fun ty -> - let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys - in sup_list min sorts - -let is_flexible_sort evd u = - match Univ.Universe.level u with - | Some l -> Evd.is_flexible_level evd l - | None -> false - -let inductive_levels env evdref poly arities inds = - let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in - let levels = List.map (fun (x,(ctx,a)) -> - if a = Prop Null then None - else Some (univ_of_sort a)) destarities - in - let cstrs_levels, min_levels, sizes = - CList.split3 - (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> - let len = List.length tys in - let minlev = Sorts.univ_of_sort du in - let minlev = - if len > 1 && not (is_impredicative env du) then - Univ.sup minlev Univ.type0_univ - else minlev - in - let minlev = - (** Indices contribute. *) - if Indtypes.is_indices_matter () && List.length ctx > 0 then ( - let ilev = sign_level env !evdref ctx in - Univ.sup ilev minlev) - else minlev - in - let clev = extract_level env !evdref minlev tys in - (clev, minlev, len)) inds destarities) - in - (* Take the transitive closure of the system of constructors *) - (* level constraints and remove the recursive dependencies *) - let levels' = Universes.solve_constraints_system (Array.of_list levels) - (Array.of_list cstrs_levels) (Array.of_list min_levels) - in - let evd, arities = - CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> - if is_impredicative env du then - (** Any product is allowed here. *) - evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor - *) - (** Constructors contribute. *) - let evd = - if Sorts.is_set du then - if not (Evd.check_leq evd cu Univ.type0_univ) then - raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) - else evd - else evd - (* Evd.set_leq_sort env evd (Type cu) du *) - in - let evd = - if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, - should not land in Prop. Add constraint only if it would - land in Prop directly (no informative arguments as well). *) - Evd.set_leq_sort env evd (Prop Pos) du - else evd - in - let duu = Sorts.univ_of_sort du in - let evd = - if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then - if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd (Prop Null) du - else evd - else Evd.set_eq_sort env evd (Type cu) du - in - (evd, arity :: arities)) - (!evdref,[]) (Array.to_list levels') destarities sizes - in evdref := evd; List.rev arities - -let check_named (loc, na) = match na with -| Name _ -> () -| Anonymous -> - let msg = str "Parameters must be named." in - user_err ?loc msg - - -let check_param = function -| CLocalDef (na, _, _) -> check_named na -| CLocalAssum (nas, Default _, _) -> List.iter check_named nas -| CLocalAssum (nas, Generalized _, _) -> () -| CLocalPattern (loc,_) -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") - -let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = - check_all_names_different indl; - List.iter check_param paramsl; - let env0 = Global.env() in - let pl = (List.hd indl).ind_univs in - let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in - let evdref = ref evd in - let impls, ((env_params, ctx_params), userimpls) = - interp_context_evars env0 evdref paramsl - in - let ctx_params = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx_params in - let indnames = List.map (fun ind -> ind.ind_name) indl in - - (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> Name.get_id) assums in - - (* Interpret the arities *) - let arities = List.map (interp_ind_arity env_params evdref) indl in - - let fullarities = List.map (fun (c, _, _) -> Term.it_mkProd_or_LetIn c ctx_params) arities in - let env_ar = push_types env0 indnames fullarities in - let env_ar_params = push_rel_context ctx_params env_ar in - - (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in - let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in - let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in - let ntn_impls = compute_internalization_env env0 (Inductive (params,true)) indnames fullarities indimpls in - let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in - - let constructors = - Metasyntax.with_syntax_protection (fun () -> - (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; - (* Interpret the constructor types *) - List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) - () in - - (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref Evd.empty in - evdref := sigma; - (* Compute renewed arities *) - let nf,_ = e_nf_evars_and_universes evdref in - let arities = List.map nf arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in - let _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in - let arities = inductive_levels env_ar_params evdref poly arities constructors in - let nf',_ = e_nf_evars_and_universes evdref in - let nf x = nf' (nf x) in - let arities = List.map nf' arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in - let ctx_params = Context.Rel.map nf ctx_params in - let evd = !evdref in - let uctx = Evd.check_univ_decl ~poly evd decl in - List.iter (fun c -> check_evars env_params Evd.empty evd (EConstr.of_constr c)) arities; - Context.Rel.iter (fun c -> check_evars env0 Evd.empty evd (EConstr.of_constr c)) ctx_params; - List.iter (fun (_,ctyps,_) -> - List.iter (fun c -> check_evars env_ar_params Evd.empty evd (EConstr.of_constr c)) ctyps) - constructors; - - (* Build the inductive entries *) - let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { - mind_entry_typename = ind.ind_name; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) indl arities aritypoly constructors in - let impls = - let len = Context.Rel.nhyps ctx_params in - List.map2 (fun indimpls (_,_,cimpls) -> - indimpls, List.map (fun impls -> - userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors - in - let univs = - match uctx with - | Polymorphic_const_entry uctx -> - if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context uctx) - else Polymorphic_ind_entry uctx - | Monomorphic_const_entry uctx -> - Monomorphic_ind_entry uctx - in - (* Build the mutual inductive entry *) - let mind_ent = - { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = None; - mind_entry_finite = finite; - mind_entry_inds = entries; - mind_entry_private = if prv then Some false else None; - mind_entry_universes = univs; - } - in - (if poly && cum then - Inductiveops.infer_inductive_subtyping env_ar evd mind_ent - else mind_ent), Evd.universe_binders evd, impls - -(* Very syntactical equality *) -let eq_local_binders bl1 bl2 = - List.equal local_binder_eq bl1 bl2 - -let extract_coercions indl = - let mkqid (_,((_,id),_)) = qualid_of_ident id in - let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in - List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) - -let extract_params indl = - let paramsl = List.map (fun (_,params,_,_) -> params) indl in - match paramsl with - | [] -> anomaly (Pp.str "empty list of inductive types.") - | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str - "Parameters should be syntactically the same for each inductive type."); - params - -let extract_inductive indl = - List.map (fun (((_,indname),pl),_,ar,lc) -> { - ind_name = indname; ind_univs = pl; - ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; - ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc - }) indl - -let extract_mutual_inductive_declaration_components indl = - let indl,ntnl = List.split indl in - let params = extract_params indl in - let coes = extract_coercions indl in - let indl = extract_inductive indl in - (params,indl), coes, List.flatten ntnl - -let is_recursive mie = - let rec is_recursive_constructor lift typ = - match Constr.kind typ with - | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || - is_recursive_constructor (lift+1) rest - | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest - | _ -> false - in - match mie.mind_entry_inds with - | [ind] -> - let nparams = List.length mie.mind_entry_params in - List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc - | _ -> false - -let declare_mutual_inductive_with_eliminations mie pl impls = - (* spiwack: raises an error if the structure is supposed to be non-recursive, - but isn't *) - begin match mie.mind_entry_finite with - | BiFinite when is_recursive mie -> - if Option.has_some mie.mind_entry_record then - user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") - else - user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) - | _ -> () - end; - let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_, kn), prim = declare_mind mie in - let mind = Global.mind_of_delta_kn kn in - List.iteri (fun i (indimpls, constrimpls) -> - let ind = (mind,i) in - let gr = IndRef ind in - maybe_declare_manual_implicits false gr indimpls; - Universes.register_universe_binders gr pl; - List.iteri - (fun j impls -> - maybe_declare_manual_implicits false - (ConstructRef (ind, succ j)) impls) - constrimpls) - impls; - let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); - if mie.mind_entry_private == None - then declare_default_schemes mind; - mind - -type one_inductive_impls = - Impargs.manual_explicitation list (* for inds *)* - Impargs.manual_explicitation list list (* for constrs *) - -let do_mutual_inductive indl cum poly prv finite = - let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in - (* Interpret the types *) - let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in - (* Declare the mutual inductive block with its associated schemes *) - ignore (declare_mutual_inductive_with_eliminations mie pl impls); - (* Declare the possible notations of inductive types *) - List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; - (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes; - (* If positivity is assumed declares itself as unsafe. *) - if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () - -(* 3c| Fixpoints and co-fixpoints *) - -(* An (unoptimized) function that maps preorders to partial orders... - - Input: a list of associations (x,[y1;...;yn]), all yi distincts - and different of x, meaning x<=y1, ..., x<=yn - - Output: a list of associations (x,Inr [y1;...;yn]), collecting all - distincts yi greater than x, _or_, (x, Inl y) meaning that - x is in the same class as y (in which case, x occurs - nowhere else in the association map) - - partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list -*) - -let rec partial_order cmp = function - | [] -> [] - | (x,xge)::rest -> - let rec browse res xge' = function - | [] -> - let res = List.map (function - | (z, Inr zge) when List.mem_f cmp x zge -> - (z, Inr (List.union cmp zge xge')) - | r -> r) res in - (x,Inr xge')::res - | y::xge -> - let rec link y = - try match List.assoc_f cmp y res with - | Inl z -> link z - | Inr yge -> - if List.mem_f cmp x yge then - let res = List.remove_assoc_f cmp y res in - let res = List.map (function - | (z, Inl t) -> - if cmp t y then (z, Inl x) else (z, Inl t) - | (z, Inr zge) -> - if List.mem_f cmp y zge then - (z, Inr (List.add_set cmp x (List.remove cmp y zge))) - else - (z, Inr zge)) res in - browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) - else - browse res (List.add_set cmp y (List.union cmp xge' yge)) xge - with Not_found -> browse res (List.add_set cmp y xge') xge - in link y - in browse (partial_order cmp rest) [] xge - -let non_full_mutual_message x xge y yge isfix rest = - let reason = - if Id.List.mem x yge then - Id.print y ++ str " depends on " ++ Id.print x ++ strbrk " but not conversely" - else if Id.List.mem y xge then - Id.print x ++ str " depends on " ++ Id.print y ++ strbrk " but not conversely" - else - Id.print y ++ str " and " ++ Id.print x ++ strbrk " are not mutually dependent" in - let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in - let k = if isfix then "fixpoint" else "cofixpoint" in - let w = - if isfix - then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() - else mt () in - strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ - str "(" ++ e ++ str ")." ++ fnl () ++ w - -let warn_non_full_mutual = - CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" - (fun (x,xge,y,yge,isfix,rest) -> - non_full_mutual_message x xge y yge isfix rest) - -let check_mutuality env evd isfix fixl = - let names = List.map fst fixl in - let preorder = - List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' (EConstr.of_constr def)) names)) - fixl in - let po = partial_order Id.equal preorder in - match List.filter (function (_,Inr _) -> true | _ -> false) po with - | (x,Inr xge)::(y,Inr yge)::rest -> - warn_non_full_mutual (x,xge,y,yge,isfix,rest) - | _ -> () - -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : universe_decl_expr option; - fix_annot : Id.t Loc.located option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - -let interp_fix_context env evdref isfix fix = - let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in - let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in - let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(Context.Rel.nhyps ctx) env' evdref after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in - ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) - -let interp_fix_ccl evdref impls (env,_) fix = - let (c, impl) = interp_type_evars_impls ~impls env evdref fix.fix_type in - (c, impl) - -let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = - let open EConstr in - Option.map (fun body -> - let env = push_rel_context ctx env_rec in - let body = interp_casted_constr_evars env evdref ~impls body ccl in - it_mkLambda_or_LetIn body ctx) fix.fix_body - -let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx - -let prepare_recursive_declaration fixnames fixtypes fixdefs = - let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map (fun id -> Name id) fixnames in - (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) - -(* Jump over let-bindings. *) - -let compute_possible_guardness_evidences (ctx,_,recindex) = - (* A recursive index is characterized by the number of lambdas to - skip before finding the relevant inductive argument *) - match recindex with - | Some i -> [i] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - List.interval 0 (Context.Rel.nhyps ctx - 1) - -type recursive_preentry = - Id.t list * constr option list * types list - -(* Wellfounded definition *) - -open Coqlib - -let contrib_name = "Program" -let subtac_dir = [contrib_name] -let fixsub_module = subtac_dir @ ["Wf"] -let tactics_module = subtac_dir @ ["Tactics"] - -let init_reference dir s () = Coqlib.coq_reference "Command" dir s -let init_constant dir s evdref = - let (sigma, c) = Evarutil.new_global !evdref (Coqlib.coq_reference "Command" dir s) - in evdref := sigma; c - -let make_ref l s = init_reference l s -let fix_proto = init_constant tactics_module "fix_proto" -let fix_sub_ref = make_ref fixsub_module "Fix_sub" -let measure_on_R_ref = make_ref fixsub_module "MR" -let well_founded = init_constant ["Init"; "Wf"] "well_founded" -let mkSubset evdref name typ prop = - let open EConstr in - mkApp (Evarutil.e_new_global evdref (delayed_force build_sigma).typ, - [| typ; mkLambda (name, typ, prop) |]) -let sigT = Lazy.from_fun build_sigma_type - -let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) -let lt_ref = make_qref "Init.Peano.lt" - -let rec telescope evdref l = - let open EConstr in - let open Vars in - match l with - | [] -> assert false - | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1 - | LocalAssum (n, t) :: tl -> - let ty, tys, (k, constr) = - List.fold_left - (fun (ty, tys, (k, constr)) decl -> - let t = RelDecl.get_type decl in - let pred = mkLambda (RelDecl.get_name decl, t, ty) in - let ty = Evarutil.e_new_global evdref (Lazy.force sigT).typ in - let intro = Evarutil.e_new_global evdref (Lazy.force sigT).intro in - let sigty = mkApp (ty, [|t; pred|]) in - let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigty, pred :: tys, (succ k, intro))) - (t, [], (2, mkRel 1)) tl - in - let (last, subst) = List.fold_right2 - (fun pred decl (prev, subst) -> - let t = RelDecl.get_type decl in - let p1 = Evarutil.e_new_global evdref (Lazy.force sigT).proj1 in - let p2 = Evarutil.e_new_global evdref (Lazy.force sigT).proj2 in - let proj1 = applist (p1, [t; pred; prev]) in - let proj2 = applist (p2, [t; pred; prev]) in - (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) - (List.rev tys) tl (mkRel 1, []) - in ty, (LocalDef (n, last, t) :: subst), constr - - | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope evdref tl in - ty, (LocalDef (n, b, t) :: subst), lift 1 term - -let nf_evar_context sigma ctx = - List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx - -let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = - let open EConstr in - let open Vars in - let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in - Coqlib.check_required_library ["Coq";"Program";"Wf"]; - let env = Global.env() in - let evd, decl = Univdecls.interp_univ_decl_opt env pl in - let evdref = ref evd in - let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in - let len = List.length binders_rel in - let top_env = push_rel_context binders_rel env in - let top_arity = interp_type_evars top_env evdref arityc in - let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let argtyp, letbinders, make = telescope evdref binders_rel in - let argname = Id.of_string "recarg" in - let arg = LocalAssum (Name argname, argtyp) in - let binders = letbinders @ [arg] in - let binders_env = push_rel_context binders_rel env in - let rel, _ = interp_constr_evars_impls env evdref r in - let relty = Typing.unsafe_type_of env !evdref rel in - let relargty = - let error () = - user_err ?loc:(constr_loc r) - ~hdr:"Command.build_wellfounded" - (Printer.pr_econstr_env env !evdref rel ++ str " is not an homogeneous binary relation.") - in - try - let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in - match ctx, EConstr.kind !evdref ar with - | [LocalAssum (_,t); LocalAssum (_,u)], Sort s - when Sorts.is_prop (ESorts.kind !evdref s) && Reductionops.is_conv env !evdref t u -> t - | _, _ -> error () - with e when CErrors.noncritical e -> error () - in - let relargty = EConstr.Unsafe.to_constr relargty in - let measure = interp_casted_constr_evars binders_env evdref measure relargty in - let wf_rel, wf_rel_fun, measure_fn = - let measure_body, measure = - it_mkLambda_or_LetIn measure letbinders, - it_mkLambda_or_LetIn measure binders - in - let comb = Evarutil.e_new_global evdref (delayed_force measure_on_R_ref) in - let relargty = EConstr.of_constr relargty in - let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in - let wf_rel_fun x y = - mkApp (rel, [| subst1 x measure_body; - subst1 y measure_body |]) - in wf_rel, wf_rel_fun, measure - in - let wf_proof = mkApp (well_founded evdref, [| argtyp ; wf_rel |]) in - let argid' = Id.of_string (Id.to_string argname ^ "'") in - let wfarg len = LocalAssum (Name argid', - mkSubset evdref (Name argid') argtyp - (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) - in - let intern_bl = wfarg 1 :: [arg] in - let _intern_env = push_rel_context intern_bl env in - let proj = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.proj1 in - let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in - let projection = (* in wfarg :: arg :: before *) - mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) - in - let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in - let intern_arity = substl [projection] top_arity_let in - (* substitute the projection of wfarg for something, - now intern_arity is in wfarg :: arg *) - let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in - let curry_fun = - let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let intro = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.intro in - let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in - let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in - let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in - let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in - let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - LocalDef (Name recname, body, ty) - in - let fun_bl = intern_fun_binder :: [arg] in - let lift_lets = lift_rel_context 1 letbinders in - let intern_body = - let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in - let (r, l, impls, scopes) = - Constrintern.compute_internalization_data env - Constrintern.Recursive (EConstr.Unsafe.to_constr full_arity) impls - in - let newimpls = Id.Map.singleton recname - (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], - scopes @ [None]) in - interp_casted_constr_evars (push_rel_context ctx env) evdref - ~impls:newimpls body (EConstr.Unsafe.to_constr (lift 1 top_arity)) - in - let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in - let prop = mkLambda (Name argname, argtyp, top_arity_let) in - let def = - mkApp (Evarutil.e_new_global evdref (delayed_force fix_sub_ref), - [| argtyp ; wf_rel ; - Evarutil.e_new_evar env evdref - ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof; - prop |]) - in - let def = Typing.e_solve_evars env evdref def in - let _ = evdref := Evarutil.nf_evar_map !evdref in - let def = mkApp (def, [|intern_body_lam|]) in - let binders_rel = nf_evar_context !evdref binders_rel in - let binders = nf_evar_context !evdref binders in - let top_arity = Evarutil.nf_evar !evdref top_arity in - let hook, recname, typ = - if List.length binders_rel > 1 then - let name = add_suffix recname "_func" in - let hook l gr _ = - let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in - let ty = it_mkProd_or_LetIn top_arity binders_rel in - let ty = EConstr.Unsafe.to_constr ty in - let univs = Evd.check_univ_decl ~poly !evdref decl in - (*FIXME poly? *) - let ce = definition_entry ~types:ty ~univs (EConstr.to_constr !evdref body) in - (** FIXME: include locality *) - let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in - let gr = ConstRef c in - let () = Universes.register_universe_binders gr (Evd.universe_binders !evdref) in - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] - in - let typ = it_mkProd_or_LetIn top_arity binders in - hook, name, typ - else - let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook l gr _ = - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] - in hook, recname, typ - in - let hook = Lemmas.mk_hook hook in - let fullcoqc = EConstr.to_constr !evdref def in - let fullctyp = EConstr.to_constr !evdref typ in - Obligations.check_evars env !evdref; - let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp - in - let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl - evars_typ ctx evars ~hook) - -let interp_recursive isfix fixl notations = - let open Context.Named.Declaration in - let open EConstr in - let env = Global.env() in - let fixnames = List.map (fun fix -> fix.fix_name) fixl in - - (* Interp arities allowing for unresolved types *) - let all_universes = - List.fold_right (fun sfe acc -> - match sfe.fix_univs , acc with - | None , acc -> acc - | x , None -> x - | Some ls , Some us -> - let lsu = ls.univdecl_instance and usu = us.univdecl_instance in - if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then - user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); - Some us) fixl None in - let evd, decl = Univdecls.interp_univ_decl_opt env all_universes in - let evdref = ref evd in - let fixctxs, fiximppairs, fixannots = - List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in - let fixctximpenvs, fixctximps = List.split fiximppairs in - let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in - let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (fun c -> nf_evar !evdref c) fixtypes in - let fiximps = List.map3 - (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (Context.Rel.nhyps ctx) cclimps)) - fixctximps fixcclimps fixctxs in - let rec_sign = - List.fold_left2 - (fun env' id t -> - if Flags.is_program_mode () then - let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in - let fixprot = - try - let app = mkApp (fix_proto evdref, [|sort; t|]) in - Typing.e_solve_evars env evdref app - with e when CErrors.noncritical e -> t - in - LocalAssum (id,fixprot) :: env' - else LocalAssum (id,t) :: env') - [] fixnames fixtypes - in - let env_rec = push_named_context rec_sign env in - - (* Get interpretation metadatas *) - let fixtypes = List.map EConstr.Unsafe.to_constr fixtypes in - let fixccls = List.map EConstr.Unsafe.to_constr fixccls in - let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in - - (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - Metasyntax.with_syntax_protection (fun () -> - List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; - List.map4 - (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls)) - fixctximpenvs fixctxs fixl fixccls) - () in - - (* Instantiate evars and check all are resolved *) - let evd = solve_unif_constraints_with_heuristics env_rec !evdref in - let evd, nf = nf_evars_and_universes evd in - let fixdefs = List.map (fun c -> Option.map EConstr.Unsafe.to_constr c) fixdefs in - let fixdefs = List.map (Option.map nf) fixdefs in - let fixtypes = List.map nf fixtypes in - let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in - - (* Build the fix declaration block *) - (env,rec_sign,decl,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots - -let check_recursive isfix env evd (fixnames,fixdefs,_) = - check_evars_are_solved env evd Evd.empty; - if List.for_all Option.has_some fixdefs then begin - let fixdefs = List.map Option.get fixdefs in - check_mutuality env evd isfix (List.combine fixnames fixdefs) - end - -let interp_fixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive true l ntns in - check_recursive true env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -let interp_cofixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive false l ntns in - check_recursive false env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let env = Global.env() in - let indexes = search_guard env indexes fixdecls in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let vars = Univops.universes_of_constr (mkFix ((indexes,0),fixdecls)) in - let fixdecls = - List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - fixpoint_message (Some indexes) fixnames; - end; - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns - -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Univops.universes_of_constr (List.hd fixdecls) in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - cofixpoint_message fixnames - end; - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns - -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na - | _ -> user_err Pp.(str - "Only structural decreasing is supported for a non-Program Fixpoint") - -let extract_fixpoint_components limit l = - let fixl, ntnl = List.split l in - let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> - let ann = extract_decreasing_argument limit ann in - {fix_name = id; fix_annot = ann; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl in - fixl, List.flatten ntnl - -let extract_cofixpoint_components l = - let fixl, ntnl = List.split l in - List.map (fun (((_,id),pl),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl, - List.flatten ntnl - -let out_def = function - | Some def -> def - | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") - -let collect_evars_of_term evd c ty = - let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in - Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) - evars (Evd.from_ctx (Evd.evar_universe_context evd)) - -let do_program_recursive local p fixkind fixl ntns = - let isfix = fixkind != Obligations.IsCoFixpoint in - let (env, rec_sign, pl, evd), fix, info = - interp_recursive isfix fixl ntns - in - (* Program-specific code *) - (* Get the interesting evars, those that were not instanciated *) - let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in - (* Solve remaining evars *) - let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = - (* Generalize by the recursive prototypes *) - let def = - EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) - and typ = - EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) - in - let evm = collect_evars_of_term evd def typ in - let evars, _, def, typ = - Obligations.eterm_obligations env id evm - (List.length rec_sign) def typ - in (id, def, typ, imps, evars) - in - let (fixnames,fixdefs,fixtypes) = fix in - let fiximps = List.map pi2 info in - let fixdefs = List.map out_def fixdefs in - let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in - let () = if isfix then begin - let possible_indexes = List.map compute_possible_guardness_evidences info in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), - Array.of_list fixtypes, - Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) - in - let indexes = - Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in - List.iteri (fun i _ -> - Inductive.check_fix env - ((indexes,i),fixdecls)) - fixl - end in - let ctx = Evd.evar_universe_context evd in - let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, p, Fixpoint) - | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) - in - Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind - -let do_program_fixpoint local poly l = - let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in - match g, l with - | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC (snd n) - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - - | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> - build_wellfounded (id, pl, n, bl, typ, out_def def) poly - (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn - - | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in - do_program_recursive local poly fixkind fixl ntns - - | _, _ -> - user_err ~hdr:"do_program_fixpoint" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") - -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - -let do_fixpoint local poly l = - if Flags.is_program_mode () then do_program_fixpoint local poly l - else - let fixl, ntns = extract_fixpoint_components true l in - let (_, _, _, info as fix) = interp_fixpoint fixl ntns in - let possible_indexes = - List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () - -let do_cofixpoint local poly l = - let fixl,ntns = extract_cofixpoint_components l in - if Flags.is_program_mode () then - do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns - else - let cofix = interp_cofixpoint fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/command.mli b/vernac/command.mli deleted file mode 100644 index 070f3e112..000000000 --- a/vernac/command.mli +++ /dev/null @@ -1,163 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Constr -open Entries -open Libnames -open Globnames -open Vernacexpr -open Constrexpr -open Decl_kinds -open Redexpr - -(** This file is about the interpretation of raw commands into typed - ones and top-level declaration of the main Gallina objects *) - -val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> - (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit - -(** {6 Definitions/Let} *) - -val interp_definition : - Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - Univdecls.universe_decl * Universes.universe_binders * Impargs.manual_implicits - -val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> - local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit Lemmas.declaration_hook -> unit - -(** {6 Parameters/Assumptions} *) - -(* val interp_assumption : env -> evar_map ref -> *) -(* local_binder_expr list -> constr_expr -> *) -(* types Univ.in_universe_context_set * Impargs.manual_implicits *) - -(** returns [false] if the assumption is neither local to a section, - nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types in_constant_universes_entry -> - Universes.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> - global_reference * Univ.Instance.t * bool - -val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool - -(* val declare_assumptions : variable Loc.located list -> *) -(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) -(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) - -(** {6 Inductive and coinductive types} *) - -(** Extracting the semantical components out of the raw syntax of mutual - inductive declarations *) - -type structured_one_inductive_expr = { - ind_name : Id.t; - ind_univs : Vernacexpr.universe_decl_expr option; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list -} - -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - -val extract_mutual_inductive_declaration_components : - (one_inductive_expr * decl_notation list) list -> - structured_inductive_expr * (*coercions:*) qualid list * decl_notation list - -(** Typing mutual inductive definitions *) - -type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) - -val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> - mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list - -(** Registering a mutual inductive definition together with its - associated schemes *) - -val declare_mutual_inductive_with_eliminations : - mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> - MutInd.t - -(** Entry points for the vernacular commands Inductive and CoInductive *) - -val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> unit - -(** {6 Fixpoints and cofixpoints} *) - -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : Vernacexpr.universe_decl_expr option; - fix_annot : Id.t Loc.located option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - -(** Extracting the semantical components out of the raw syntax of - (co)fixpoints declarations *) - -val extract_fixpoint_components : bool -> - (fixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -val extract_cofixpoint_components : - (cofixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -(** Typing global fixpoints and cofixpoint_expr *) - -type recursive_preentry = - Id.t list * constr option list * types list - -val interp_fixpoint : - structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - -val interp_cofixpoint : - structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - -(** Registering fixpoints and cofixpoints in the environment *) - -val declare_fixpoint : - locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (Context.Rel.t * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> unit - -val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (Context.Rel.t * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit - -(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) - -val do_fixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit - -val do_cofixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit - -(** Utils *) - -val check_mutuality : Environ.env -> Evd.evar_map -> bool -> (Id.t * types) list -> unit diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 980db4109..dfac78c04 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -36,7 +36,7 @@ let declare_global_definition ident ce local k pl imps = let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in - let () = Universes.register_universe_binders gr pl in + let () = Declare.declare_univ_binders gr pl in let () = definition_message ident in gr @@ -49,6 +49,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = let () = definition_message ident in let gr = VarRef ident in let () = maybe_declare_manual_implicits false gr imps in + let () = Declare.declare_univ_binders gr pl in let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 3a8e8fb43..fc3495796 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -32,6 +32,7 @@ let explain_exn_default = function | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") + | Dynlink.Error e -> hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) | Timeout -> hov 0 (str "Timeout!") | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") (* Exceptions with pre-evaluated error messages *) @@ -75,8 +76,7 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) - | Logic.RefinerError e -> - let sigma, env = Pfedit.get_current_context () in + | Logic.RefinerError (env, sigma, e) -> wrap_vernac_error exn (Himsg.explain_refiner_error env sigma e) | Nametab.GlobalizationError q -> wrap_vernac_error exn diff --git a/vernac/himsg.ml b/vernac/himsg.ml index e8c5aeedd..f00c1e604 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -83,12 +83,12 @@ let rec contract3' env sigma a b c = function (** Ad-hoc reductions *) -let j_nf_betaiotaevar sigma j = +let j_nf_betaiotaevar env sigma j = { uj_val = j.uj_val; - uj_type = Reductionops.nf_betaiota sigma j.uj_type } + uj_type = Reductionops.nf_betaiota env sigma j.uj_type } -let jv_nf_betaiotaevar sigma jl = - Array.map (fun j -> j_nf_betaiotaevar sigma j) jl +let jv_nf_betaiotaevar env sigma jl = + Array.map (fun j -> j_nf_betaiotaevar env sigma j) jl (** Printers *) @@ -258,7 +258,7 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reductionops.nf_betaiota sigma t in + let simp t = Reductionops.nf_betaiota env sigma t in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma c in let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in @@ -295,8 +295,8 @@ let explain_unification_error env sigma p1 p2 = function | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> - let t1 = Reductionops.nf_betaiota sigma t1 in - let t2 = Reductionops.nf_betaiota sigma t2 in + let t1 = Reductionops.nf_betaiota env sigma t1 in + let t2 = Reductionops.nf_betaiota env sigma t2 in if EConstr.eq_constr sigma t1 p1 && EConstr.eq_constr sigma t2 p2 then [] else let env = make_all_name_different env sigma in if not (EConstr.eq_constr sigma t1 p1) || not (EConstr.eq_constr sigma t2 p2) then @@ -336,8 +336,8 @@ let explain_unification_error env sigma p1 p2 = function let explain_actual_type env sigma j t reason = let env = make_all_name_different env sigma in - let j = j_nf_betaiotaevar sigma j in - let t = Reductionops.nf_betaiota sigma t in + let j = j_nf_betaiotaevar env sigma j in + let t = Reductionops.nf_betaiota env sigma t in (** Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in let pc = pr_leconstr_env env sigma (Environ.j_val j) in @@ -351,8 +351,8 @@ let explain_actual_type env sigma j t reason = ppreason ++ str ".") let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = - let randl = jv_nf_betaiotaevar sigma randl in - let actualtyp = Reductionops.nf_betaiota sigma actualtyp in + let randl = jv_nf_betaiotaevar env sigma randl in + let actualtyp = Reductionops.nf_betaiota env sigma actualtyp in let env = make_all_name_different env sigma in let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in let nargs = Array.length randl in diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index e4ca98749..2f4c95aff 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -258,7 +258,7 @@ let declare_one_induction_scheme ind = let declare_induction_schemes kn = let mib = Global.lookup_mind kn in - if mib.mind_finite <> Decl_kinds.CoFinite then begin + if mib.mind_finite <> Declarations.CoFinite then begin for i = 0 to Array.length mib.mind_packets - 1 do declare_one_induction_scheme (kn,i); done; @@ -268,7 +268,7 @@ let declare_induction_schemes kn = let declare_eq_decidability_gen internal names kn = let mib = Global.lookup_mind kn in - if mib.mind_finite <> Decl_kinds.CoFinite then + if mib.mind_finite <> Declarations.CoFinite then ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) @@ -512,7 +512,7 @@ let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done let declare_default_schemes kn = let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets in - if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag) + if !elim_flag && (mib.mind_finite <> Declarations.BiFinite || !bifinite_elim_flag) && mib.mind_typing_flags.check_guarded then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 42631a15b..57436784b 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -13,12 +13,10 @@ open CErrors open Util open Pp open Names -open Term open Constr open Declarations open Declareops open Entries -open Environ open Nameops open Globnames open Decls @@ -88,31 +86,31 @@ let adjust_guardness_conditions const = function (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff) } -let find_mutually_recursive_statements thms = +let find_mutually_recursive_statements sigma thms = let n = List.length thms in let inds = List.map (fun (id,(t,impls)) -> - let (hyps,ccl) = decompose_prod_assum t in + let (hyps,ccl) = EConstr.decompose_prod_assum sigma t in let x = (id,(t,impls)) in - let whnf_hyp_hds = map_rel_context_in_env - (fun env c -> EConstr.Unsafe.to_constr (fst (whd_all_stack env Evd.empty (EConstr.of_constr c)))) + let whnf_hyp_hds = EConstr.map_rel_context_in_env + (fun env c -> fst (Reductionops.whd_all_stack env sigma c)) (Global.env()) hyps in let ind_hyps = List.flatten (List.map_i (fun i decl -> let t = RelDecl.get_type decl in - match Constr.kind t with + match EConstr.kind sigma t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in - mind.mind_finite <> Decl_kinds.CoFinite -> + mind.mind_finite <> Declarations.CoFinite -> [ind,x,i] | _ -> - []) 0 (List.rev (List.filter RelDecl.is_local_assum whnf_hyp_hds))) in + []) 0 (List.rev (List.filter Context.Rel.Declaration.is_local_assum whnf_hyp_hds))) in let ind_ccl = - let cclenv = push_rel_context hyps (Global.env()) in - let whnf_ccl,_ = whd_all_stack cclenv Evd.empty (EConstr.of_constr ccl) in - match Constr.kind (EConstr.Unsafe.to_constr whnf_ccl) with + let cclenv = EConstr.push_rel_context hyps (Global.env()) in + let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in + match EConstr.kind sigma whnf_ccl with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in - Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite -> + Int.equal mind.mind_ntypes n && mind.mind_finite == Declarations.CoFinite -> [ind,x,0] | _ -> [] in @@ -163,21 +161,21 @@ let find_mutually_recursive_statements thms = in (finite,guard,None), ordered_inds -let look_for_possibly_mutual_statements = function +let look_for_possibly_mutual_statements sigma = function | [id,(t,impls)] -> (* One non recursively proved theorem *) None,[id,(t,impls)],None | _::_ as thms -> (* More than one statement and/or an explicit decreasing mark: *) (* we look for a common inductive hyp or a common coinductive conclusion *) - let recguard,ordered_inds = find_mutually_recursive_statements thms in + let recguard,ordered_inds = find_mutually_recursive_statements sigma thms in let thms = List.map pi2 ordered_inds in Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) | [] -> anomaly (Pp.str "Empty list of theorems.") (* Saving a goal *) -let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = +let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in @@ -204,7 +202,7 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = (locality, ConstRef kn) in definition_message id; - Universes.register_universe_binders r (Option.default Universes.empty_binders pl); + Declare.declare_univ_binders r (UState.universe_binders uctx); call_hook (fun exn -> exn) hook l r with e when CErrors.noncritical e -> let e = CErrors.push e in @@ -212,17 +210,16 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = let default_thm_id = Id.of_string "Unnamed_thm" -let compute_proof_name locality = function - | Some ((loc,id),pl) -> - (* We check existence here: it's a bit late at Qed time *) - if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || - locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) - then - user_err ?loc (Id.print id ++ str " already exists."); - id - | None -> - let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in - next_global_ident_away default_thm_id avoid +let fresh_name_for_anonymous_theorem () = + let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in + next_global_ident_away default_thm_id avoid + +let check_name_freshness locality (loc,id) : unit = + (* We check existence here: it's a bit late at Qed time *) + if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || + locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) + then + user_err ?loc (Id.print id ++ str " already exists.") let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in @@ -286,17 +283,17 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = - let id,const,(cstrs,pl),do_guard,persistence,hook = proof in - save ?export_seff id const cstrs pl do_guard persistence hook + let id,const,uctx,do_guard,persistence,hook = proof in + save ?export_seff id const uctx do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") let save_anonymous ?export_seff proof save_ident = - let id,const,(cstrs,pl),do_guard,persistence,hook = proof in + let id,const,uctx,do_guard,persistence,hook = proof in check_anonymity id save_ident; - save ?export_seff save_ident const cstrs pl do_guard persistence hook + save ?export_seff save_ident const uctx do_guard persistence hook (* Admitted *) @@ -312,7 +309,7 @@ let admit (id,k,e) pl hook () = | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id in let () = assumption_message id in - Universes.register_universe_binders (ConstRef kn) (Option.default Universes.empty_binders pl); + Declare.declare_univ_binders (ConstRef kn) pl; call_hook (fun exn -> exn) hook Global (ConstRef kn) (* Starting a goal *) @@ -330,8 +327,8 @@ let get_proof proof do_guard hook opacity = let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function - | Admitted (id,k,pe,(ctx,pl)) -> - admit (id,k,pe) pl (hook (Some ctx)) (); + | Admitted (id,k,pe,ctx) -> + admit (id,k,pe) (UState.universe_binders ctx) (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff = match opaque with @@ -339,7 +336,7 @@ let universe_proof_terminator compute_guard hook = | Vernacexpr.Opaque -> true, false in let proof = get_proof proof compute_guard - (hook (Some (fst proof.Proof_global.universes))) is_opaque in + (hook (Some (proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some (_,id) -> save_anonymous ~export_seff proof id @@ -377,7 +374,7 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_ let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,EConstr.of_constr t)) thms with + match List.map (fun (id,(t,_)) -> (id,t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -385,11 +382,11 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with + in match List.map2 (fun (id,(t,_)) n -> (id,n, t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization kind ctx decl recguard thms snl hook = +let start_proof_with_initialization kind sigma decl recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tacticals.New.tclMAP (function | Name id -> Tactics.intro_mustbe_force id @@ -417,47 +414,45 @@ let start_proof_with_initialization kind ctx decl recguard thms snl hook = | (id,(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with - | None -> Evd.empty_evar_universe_context + | None -> UState.empty | Some ctx -> ctx in let other_thms_data = if List.is_empty other_thms then [] else (* there are several theorems defined mutually *) let body,opaq = retrieve_first_recthm ctx ref in - let subst = Evd.evar_universe_context_subst ctx in - let norm c = Universes.subst_opt_univs_constr subst c in - let ctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in - let body = Option.map norm body in - List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in + let norm c = EConstr.to_constr (Evd.from_ctx ctx) c in + let body = Option.map EConstr.of_constr body in + let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in + List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ~pl:decl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind sigma t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in let decl = fst (List.hd thms) in - let evd, decl = - match decl with - | None -> Evd.from_env env0, Univdecls.default_univ_decl - | Some decl -> - Univdecls.interp_univ_decl_opt env0 (snd decl) in - let evdref = ref evd in - let thms = List.map (fun (sopt,(bl,t)) -> - let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in - let t', imps' = interp_type_evars_impls ~impls env evdref t in + let evd, decl = Univdecls.interp_univ_decl_opt env0 (snd decl) in + let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> + let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in + let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in let flags = all_and_fail_flags in let flags = { flags with use_hook = inference_hook } in - evdref := solve_remaining_evars flags env !evdref Evd.empty; + let evd = solve_remaining_evars flags env evd Evd.empty in let ids = List.map RelDecl.get_name ctx in - (compute_proof_name (pi1 kind) sopt, - (EConstr.Unsafe.to_constr (nf_evar !evdref (EConstr.it_mkProd_or_LetIn t' ctx)), - (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) - thms in - let recguard,thms,snl = look_for_possibly_mutual_statements thms in - let evd, nf = Evarutil.nf_evars_and_universes !evdref in - let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in + check_name_freshness (pi1 kind) id; + (* XXX: The nf_evar is critical !! *) + evd, (snd id, + (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), + (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) + evd thms in + let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in + let evd, _nf = Evarutil.nf_evars_and_universes evd in + (* XXX: This nf_evar is critical too!! We are normalizing twice if + you look at the previous lines... *) + let thms = List.map (fun (n, (t, info)) -> (n, (nf_evar evd t, info))) thms in let () = let open Misctypes in if not (decl.univdecl_extensible_instance && decl.univdecl_extensible_constraints) then @@ -470,7 +465,6 @@ let start_proof_com ?inference_hook kind thms hook = in start_proof_with_initialization kind evd decl recguard thms snl hook - (* Saving a proof *) let keep_admitted_vars = ref true @@ -496,7 +490,7 @@ let save_proof ?proof = function if const_entry_type = None then user_err Pp.(str "Admitted requires an explicit statement"); let typ = Option.get const_entry_type in - let ctx = UState.const_univ_entry ~poly:(pi2 k) (fst universes) in + let ctx = UState.const_univ_entry ~poly:(pi2 k) universes in let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> @@ -518,12 +512,9 @@ let save_proof ?proof = function Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in let decl = Proof_global.get_universe_decl () in - let evd = Evd.from_ctx universes in let poly = pi2 k in - let ctx = Evd.check_univ_decl ~poly evd decl in - let binders = if poly then Some (UState.universe_binders universes) else None in - Admitted(id,k,(sec_vars, (typ, ctx), None), - (universes, binders)) + let ctx = UState.check_univ_decl ~poly universes decl in + Admitted(id,k,(sec_vars, (typ, ctx), None), universes) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 1b1304db5..126dcd8b0 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Constr open Decl_kinds type 'a declaration_hook @@ -37,11 +36,11 @@ val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit -val start_proof_with_initialization : +val start_proof_with_initialization : goal_kind -> Evd.evar_map -> Univdecls.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * - (types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val universe_proof_terminator : @@ -53,10 +52,12 @@ val standard_proof_terminator : Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator +val fresh_name_for_anonymous_theorem : unit -> Id.t + (** {6 ... } *) (** A hook the next three functions pass to cook_proof *) -val set_save_hook : (Proof.proof -> unit) -> unit +val set_save_hook : (Proof.t -> unit) -> unit val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit diff --git a/vernac/locality.ml b/vernac/locality.ml index 681b1ab20..87b411625 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -6,36 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Decl_kinds + (** * Managing locality *) let local_of_bool = function - | true -> Decl_kinds.Local - | false -> Decl_kinds.Global - -(** Extracting the locality flag *) - -(* Commands which supported an inlined Local flag *) - -let warn_deprecated_local_syntax = - CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated" - (fun () -> - Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.") - -let enforce_locality_full locality_flag local = - let local = - match locality_flag with - | Some false when local -> - CErrors.user_err Pp.(str "Cannot be simultaneously Local and Global.") - | Some true when local -> - CErrors.user_err Pp.(str "Use only prefix \"Local\".") - | None -> - if local then begin - warn_deprecated_local_syntax (); - Some true - end else - None - | Some b -> Some b in - local + | true -> Local + | false -> Global + (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -48,15 +26,16 @@ let make_non_locality = function Some false -> false | _ -> true let make_locality = function Some true -> true | _ -> false -let enforce_locality locality_flag local = - make_locality (enforce_locality_full locality_flag local) +let enforce_locality_exp locality_flag discharge = + match locality_flag, discharge with + | Some b, NoDischarge -> local_of_bool b + | None, NoDischarge -> Global + | None, DoDischarge -> Discharge + | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") + | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") -let enforce_locality_exp locality_flag local = - match locality_flag, local with - | None, Some local -> local - | Some b, None -> local_of_bool b - | None, None -> Decl_kinds.Global - | Some _, Some _ -> CErrors.user_err Pp.(str "Local non allowed in this case") +let enforce_locality locality_flag = + make_locality locality_flag (* For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; @@ -65,8 +44,8 @@ let enforce_locality_exp locality_flag local = let make_section_locality = function Some b -> b | None -> Lib.sections_are_opened () -let enforce_section_locality locality_flag local = - make_section_locality (enforce_locality_full locality_flag local) +let enforce_section_locality locality_flag = + make_section_locality locality_flag (** Positioning locality for commands supporting export but not discharge *) @@ -83,5 +62,5 @@ let make_module_locality = function | Some true -> true | None -> false -let enforce_module_locality locality_flag local = - make_module_locality (enforce_locality_full locality_flag local) +let enforce_module_locality locality_flag = + make_module_locality locality_flag diff --git a/vernac/locality.mli b/vernac/locality.mli index bef66d8bc..922538b23 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -8,10 +8,6 @@ (** * Managing locality *) -(** Commands which supported an inlined Local flag *) - -val enforce_locality_full : bool option -> bool -> bool option - (** * Positioning locality for commands supporting discharging and export outside of modules *) @@ -22,16 +18,15 @@ val enforce_locality_full : bool option -> bool -> bool option val make_locality : bool option -> bool val make_non_locality : bool option -> bool -val enforce_locality : bool option -> bool -> bool -val enforce_locality_exp : - bool option -> Decl_kinds.locality option -> Decl_kinds.locality +val enforce_locality_exp : bool option -> Decl_kinds.discharge -> Decl_kinds.locality +val enforce_locality : bool option -> bool (** For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; Local in sections is the default, Local not in section forces non-export *) val make_section_locality : bool option -> bool -val enforce_section_locality : bool option -> bool -> bool +val enforce_section_locality : bool option -> bool (** * Positioning locality for commands supporting export but not discharge *) @@ -40,4 +35,4 @@ val enforce_section_locality : bool option -> bool -> bool Local in sections is the default, Local not in section forces non-export *) val make_module_locality : bool option -> bool -val enforce_module_locality : bool option -> bool -> bool +val enforce_module_locality : bool option -> bool diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 6c3dfec7d..bcffe640c 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -43,13 +43,6 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let entry_buf = Buffer.create 64 -type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry - -let grammars : any_entry list String.Map.t ref = ref String.Map.empty - -let register_grammar name grams = - grammars := String.Map.add name grams !grammars - let pr_entry e = let () = Buffer.clear entry_buf in let ft = Format.formatter_of_buffer entry_buf in @@ -57,11 +50,11 @@ let pr_entry e = str (Buffer.contents entry_buf) let pr_registered_grammar name = - let gram = try Some (String.Map.find name !grammars) with Not_found -> None in + let gram = try Some (Pcoq.find_grammars_by_name name) with Not_found -> None in match gram with | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") | Some entries -> - let pr_one (AnyEntry e) = + let pr_one (Pcoq.AnyEntry e) = str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ pr_entry e in @@ -80,8 +73,8 @@ let pr_grammar = function | "pattern" -> pr_entry Pcoq.Constr.pattern | "vernac" -> - str "Entry vernac is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.vernac ++ + str "Entry vernac_control is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.vernac_control ++ str "Entry command is" ++ fnl () ++ pr_entry Pcoq.Vernac_.command ++ str "Entry syntax is" ++ fnl () ++ @@ -199,36 +192,6 @@ let parse_format ((loc, str) : lstring) = (***********************) (* Analyzing notations *) -type symbol_token = WhiteSpace of int | String of string - -let split_notation_string str = - let push_token beg i l = - if Int.equal beg i then l else - let s = String.sub str beg (i - beg) in - String s :: l - in - let push_whitespace beg i l = - if Int.equal beg i then l else WhiteSpace (i-beg) :: l - in - let rec loop beg i = - if i < String.length str then - if str.[i] == ' ' then - push_token beg i (loop_on_whitespace (i+1) (i+1)) - else - loop beg (i+1) - else - push_token beg i [] - and loop_on_whitespace beg i = - if i < String.length str then - if str.[i] != ' ' then - push_whitespace beg i (loop i (i+1)) - else - loop_on_whitespace beg (i+1) - else - push_whitespace beg i [] - in - loop 0 0 - (* Interpret notations with a recursive component *) let out_nt = function NonTerminal x -> x | _ -> assert false @@ -284,17 +247,6 @@ let quote_notation_token x = if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'" else x -let rec raw_analyze_notation_tokens = function - | [] -> [] - | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl - | String "_" :: _ -> user_err Pp.(str "_ must be quoted.") - | String x :: sl when CLexer.is_ident x -> - NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl - | String s :: sl -> - Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl - | WhiteSpace n :: sl -> - Break n :: raw_analyze_notation_tokens sl - let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> @@ -315,8 +267,8 @@ let rec get_notation_vars onlyprint = function | (Terminal _ | Break _) :: sl -> get_notation_vars onlyprint sl | SProdList _ :: _ -> assert false -let analyze_notation_tokens ~onlyprint l = - let l = raw_analyze_notation_tokens l in +let analyze_notation_tokens ~onlyprint ntn = + let l = decompose_raw_notation ntn in let vars = get_notation_vars onlyprint l in let recvars,l = interp_list_parser [] l in recvars, List.subtract Id.equal vars (List.map snd recvars), l @@ -333,13 +285,17 @@ let prec_assoc = function | LeftA -> (E,L) | NonA -> (L,L) -let precedence_of_entry_type from = function - | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n - | ETConstr (NumLevel n,BorderProd (b,Some a)) -> +let precedence_of_position_and_level from = function + | NumLevel n, BorderProd (_,None) -> n, Prec n + | NumLevel n, BorderProd (b,Some a) -> n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp - | ETConstr (NumLevel n,InternalProd) -> n, Prec n - | ETConstr (NextLevel,_) -> from, L - | _ -> 0, E (* ?? *) + | NumLevel n, InternalProd -> n, Prec n + | NextLevel, _ -> from, L + +let precedence_of_entry_type from = function + | ETConstr x | ETConstrAsBinder (_,x) -> precedence_of_position_and_level from x + | ETPattern (_,n) -> let n = match n with None -> 0 | Some n -> n in n, Prec n + | _ -> 0, E (* should not matter *) (* Some breaking examples *) (* "x = y" : "x /1 = y" (breaks before any symbol) *) @@ -377,8 +333,8 @@ let is_non_terminal = function | NonTerminal _ | SProdList _ -> true | _ -> false -let is_next_non_terminal = function -| [] -> false +let is_next_non_terminal b = function +| [] -> b | pr :: _ -> is_non_terminal pr let is_next_terminal = function Terminal _ :: _ -> true | _ -> false @@ -387,8 +343,9 @@ let is_next_break = function Break _ :: _ -> true | _ -> false let add_break n l = (None,UnpCut (PpBrk(n,0))) :: l -let add_break_if_none n = function - | (((_,UnpCut (PpBrk _)) :: _) | []) as l -> l +let add_break_if_none n b = function + | (_,UnpCut (PpBrk _)) :: _ as l -> l + | [] when not b -> [] | l -> (None,UnpCut (PpBrk(n,0))) :: l let check_open_binder isopen sl m = @@ -403,45 +360,59 @@ let check_open_binder isopen sl m = prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") +let unparsing_metavar i from typs = + let x = List.nth typs (i-1) in + let prec = snd (precedence_of_entry_type from x) in + match x with + | ETConstr _ | ETConstrAsBinder _ | ETReference | ETBigint -> + UnpMetaVar (i,prec) + | ETPattern _ -> + UnpBinderMetaVar (i,prec) + | ETName -> + UnpBinderMetaVar (i,Prec 0) + | ETBinder isopen -> + assert false + | ETOther _ -> failwith "TODO" + (* Heuristics for building default printing rules *) let index_id id l = List.index Id.equal id l let make_hunks etyps symbols from = let vars,typs = List.split etyps in - let rec make = function + let rec make b = function | NonTerminal m :: prods -> let i = index_id m vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in - let u = UnpMetaVar (i,prec) in - if is_next_non_terminal prods then - (None,u) :: add_break_if_none 1 (make prods) + let u = unparsing_metavar i from typs in + if is_next_non_terminal b prods then + (None, u) :: add_break_if_none 1 b (make b prods) else - (None,u) :: make_with_space prods - | Terminal s :: prods when List.exists is_non_terminal prods -> + (None, u) :: make_with_space b prods + | Terminal s :: prods + when (* true to simulate presence of non-terminal *) b || List.exists is_non_terminal prods -> if (is_comma s || is_operator s) then (* Always a breakable space after comma or separator *) - (None,UnpTerminal s) :: add_break_if_none 1 (make prods) + (None, UnpTerminal s) :: add_break_if_none 1 b (make b prods) else if is_right_bracket s && is_next_terminal prods then (* Always no space after right bracked, but possibly a break *) - (None,UnpTerminal s) :: add_break_if_none 0 (make prods) - else if is_left_bracket s && is_next_non_terminal prods then - (None,UnpTerminal s) :: make prods + (None, UnpTerminal s) :: add_break_if_none 0 b (make b prods) + else if is_left_bracket s && is_next_non_terminal b prods then + (None, UnpTerminal s) :: make b prods else if not (is_next_break prods) then (* Add rigid space, no break, unless user asked for something *) - (None,UnpTerminal (s^" ")) :: make prods + (None, UnpTerminal (s^" ")) :: make b prods else (* Rely on user spaces *) - (None,UnpTerminal s) :: make prods + (None, UnpTerminal s) :: make b prods | Terminal s :: prods -> (* Separate but do not cut a trailing sequence of terminal *) (match prods with - | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make prods - | _ -> (None,UnpTerminal s) :: make prods) + | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make b prods + | _ -> (None,UnpTerminal s) :: make b prods) | Break n :: prods -> - add_break n (make prods) + add_break n (make b prods) | SProdList (m,sl) :: prods -> let i = index_id m vars in @@ -451,47 +422,52 @@ let make_hunks etyps symbols from = (* If no separator: add a break *) if List.is_empty sl then add_break 1 [] (* We add NonTerminal for simulation but remove it afterwards *) - else snd (List.sep_last (make (sl@[NonTerminal m]))) in + else make true sl in let hunk = match typ with | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl') | ETBinder isopen -> check_open_binder isopen sl m; UnpBinderListMetaVar (i,isopen,List.map snd sl') | _ -> assert false in - (None,hunk) :: make_with_space prods + (None, hunk) :: make_with_space b prods | [] -> [] - and make_with_space prods = + and make_with_space b prods = match prods with | Terminal s' :: prods'-> if is_operator s' then (* A rigid space before operator and a breakable after *) - (None,UnpTerminal (" "^s')) :: add_break_if_none 1 (make prods') + (None,UnpTerminal (" "^s')) :: add_break_if_none 1 b (make b prods') else if is_comma s' then (* No space whatsoever before comma *) - make prods + make b prods else if is_right_bracket s' then - make prods + make b prods else (* A breakable space between any other two terminals *) - add_break_if_none 1 (make prods) + add_break_if_none 1 b (make b prods) | (NonTerminal _ | SProdList _) :: _ -> (* A breakable space before a non-terminal *) - add_break_if_none 1 (make prods) + add_break_if_none 1 b (make b prods) | Break _ :: _ -> (* Rely on user wish *) - make prods + make b prods | [] -> [] - in make symbols + in make false symbols (* Build default printing rules from explicit format *) let error_format ?loc () = user_err ?loc Pp.(str "The format does not match the notation.") +let warn_format_break = + CWarnings.create ~name:"notation-both-format-and-spaces" ~category:"parsing" + (fun () -> + strbrk "Discarding format implicitly indicated by multiple spaces in notation because an explicit format modifier is given.") + let rec split_format_at_ldots hd = function - | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string ldots_var) -> loc, List.rev hd, fmt + | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string Notation_ops.ldots_var) -> loc, List.rev hd, fmt | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt @@ -538,8 +514,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') -> let i = index_id s vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in - let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l + let symbs, l = aux (symbs,fmt) in symbs, unparsing_metavar i from typs :: l | symbs, (_,UnpBox (a,b)) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in @@ -562,6 +537,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = | _ -> assert false in symbs, hunk :: l | symbs, [] -> symbs, [] + | Break _ :: symbs, fmt -> warn_format_break (); aux (symbs,fmt) | _, fmt -> error_format ?loc:(fst (List.hd fmt)) () in match aux symfmt with @@ -574,8 +550,8 @@ let hunks_of_format (from,(vars,typs)) symfmt = let assoc_of_type n (_,typ) = precedence_of_entry_type n typ let is_not_small_constr = function - ETConstr _ -> true - | ETOther("constr","binder_constr") -> true + ETProdConstr _ -> true + | ETProdOther("constr","binder_constr") -> true | _ -> false let rec define_keywords_aux = function @@ -606,15 +582,15 @@ let distribute a ll = List.map (fun l -> a @ l) ll t;sep;t;...;t;sep;t;...;t;sep;t;LIST1(t,sep) *) let expand_list_rule typ tkl x n p ll = - let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in - let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in + let camlp5_message_name = Some (add_suffix x ("_"^string_of_int n)) in + let main = GramConstrNonTerminal (ETProdConstr typ, camlp5_message_name) in let tks = List.map (fun x -> GramConstrTerminal x) tkl in let rec aux i hds ll = if i < p then aux (i+1) (main :: tks @ hds) ll else if Int.equal i (p+n) then let hds = GramConstrListMark (p+n,true,p) :: hds - @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in + @ [GramConstrNonTerminal (ETProdConstrList (typ,tkl), Some x)] in distribute hds ll else distribute (GramConstrListMark (i+1,false,p) :: hds @ [main]) ll @ @@ -623,7 +599,7 @@ let expand_list_rule typ tkl x n p ll = let is_constr_typ typ x etyps = match List.assoc x etyps with - | ETConstr typ' -> typ = typ' + | ETConstr typ' | ETConstrAsBinder (_,typ') -> typ = typ' | _ -> false let include_possible_similar_trailing_pattern typ etyps sl l = @@ -636,12 +612,21 @@ let include_possible_similar_trailing_pattern typ etyps sl l = with Exit -> n,l in try_aux 0 l +let prod_entry_type = function + | ETName -> ETProdName + | ETReference -> ETProdReference + | ETBigint -> ETProdBigint + | ETBinder _ -> assert false (* See check_binder_type *) + | ETConstr p | ETConstrAsBinder (_,p) -> ETProdConstr p + | ETPattern (_,n) -> ETProdPattern (match n with None -> 0 | Some n -> n) + | ETOther (s,t) -> ETProdOther (s,t) + let make_production etyps symbols = let rec aux = function | [] -> [[]] | NonTerminal m :: l -> let typ = List.assoc m etyps in - distribute [GramConstrNonTerminal (typ, Some m)] (aux l) + distribute [GramConstrNonTerminal (prod_entry_type typ, Some m)] (aux l) | Terminal s :: l -> distribute [GramConstrTerminal (CLexer.terminal s)] (aux l) | Break _ :: l -> @@ -656,8 +641,10 @@ let make_production etyps symbols = let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in expand_list_rule typ tkl x 1 p (aux l') | ETBinder o -> - distribute - [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] (aux l) + check_open_binder o sl x; + let typ = if o then (assert (tkl = []); ETBinderOpen) else ETBinderClosed tkl in + distribute + [GramConstrNonTerminal (ETProdBinderList typ, Some x)] (aux l) | _ -> user_err Pp.(str "Components of recursive patterns in notation must be terms or binders.") in let prods = aux symbols in @@ -675,6 +662,7 @@ let rec find_symbols c_current c_next c_last = function let border = function | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a + | (_,(ETConstrAsBinder(_,(_,BorderProd (_,a))))) :: _ -> a | _ -> None let recompute_assoc typs = @@ -688,17 +676,16 @@ let recompute_assoc typs = (* Registration of syntax extensions (parsing/printing, no interpretation)*) let pr_arg_level from (lev,typ) = - let pplev = match lev with + let pplev = function | (n,L) when Int.equal n from -> str "at next level" | (n,E) -> str "at level " ++ int n | (n,L) -> str "at level below " ++ int n | (n,Prec m) when Int.equal m n -> str "at level " ++ int n | (n,_) -> str "Unknown level" in - let pptyp = match typ with - | NtnInternTypeConstr -> mt () - | NtnInternTypeBinder -> str " " ++ surround (str "binder") - | NtnInternTypeIdent -> str " " ++ surround (str "ident") in - pplev ++ pptyp + Ppvernac.pr_set_entry_type (fun _ -> (*TO CHECK*) mt()) typ ++ + (match typ with + | ETConstr _ | ETConstrAsBinder _ | ETPattern _ -> spc () ++ pplev lev + | _ -> mt ()) let pr_level ntn (from,args,typs) = str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ @@ -830,15 +817,23 @@ let interp_modifiers modl = let open NotationMods in interp { acc with etyps = (id,typ) :: acc.etyps; } l | SetItemLevel ([],n) :: l -> interp acc l + | SetItemLevelAsBinder ([],_,_) :: l -> + interp acc l | SetItemLevel (s::idl,n) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id acc.etyps then user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); - let typ = ETConstr (n,()) in + let typ = ETConstr (Some n) in interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l) + | SetItemLevelAsBinder (s::idl,bk,n) :: l -> + let id = Id.of_string s in + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" + (str s ++ str " is already assigned to an entry or constr level."); + let typ = ETConstrAsBinder (bk,n) in + interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevelAsBinder (idl,bk,n)::l) | SetLevel n :: l -> - interp { acc with level = Some n; } l | SetAssoc a :: l -> if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once."); @@ -902,12 +897,17 @@ let get_compat_version mods = let set_entry_type etyps (x,typ) = let typ = try match List.assoc x etyps, typ with - | ETConstr (n,()), (_,BorderProd (left,_)) -> + | ETConstr (Some n), (_,BorderProd (left,_)) -> ETConstr (n,BorderProd (left,None)) - | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) - | (ETPattern | ETName | ETBigint | ETOther _ | - ETReference | ETBinder _ as t), _ -> t - | (ETBinderList _ |ETConstrList _), _ -> assert false + | ETConstr (Some n), (_,InternalProd) -> ETConstr (n,InternalProd) + | ETConstrAsBinder (bk, Some n), (_,BorderProd (left,_)) -> + ETConstrAsBinder (bk, (n,BorderProd (left,None))) + | ETConstrAsBinder (bk, Some n), (_,InternalProd) -> + ETConstrAsBinder (bk, (n,InternalProd)) + | ETPattern (b,n), _ -> ETPattern (b,n) + | (ETName | ETBigint | ETReference | ETBinder _ | ETOther _ as x), _ -> x + | ETConstr None, _ -> ETConstr typ + | ETConstrAsBinder (bk,None), _ -> ETConstrAsBinder (bk,typ) with Not_found -> ETConstr typ in (x,typ) @@ -927,12 +927,9 @@ let join_auxiliary_recursive_types recvars etyps = recvars etyps let internalization_type_of_entry_type = function - | ETConstr _ -> NtnInternTypeConstr - | ETBigint | ETReference -> NtnInternTypeConstr - | ETBinder _ -> NtnInternTypeBinder - | ETName -> NtnInternTypeIdent - | ETPattern | ETOther _ -> user_err Pp.(str "Not supported.") - | ETBinderList _ | ETConstrList _ -> assert false + | ETBinder _ -> NtnInternTypeOnlyBinder + | ETConstr _ | ETConstrAsBinder _ | ETBigint | ETReference + | ETName | ETPattern _ | ETOther _ -> NtnInternTypeAny let set_internalization_type typs = List.map (fun (_, e) -> internalization_type_of_entry_type e) typs @@ -943,28 +940,36 @@ let make_internalization_vars recvars mainvars typs = maintyps @ extratyps let make_interpretation_type isrec isonlybinding = function - | NtnInternTypeConstr when isrec -> NtnTypeConstrList - | NtnInternTypeConstr | NtnInternTypeIdent -> - if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr - | NtnInternTypeBinder when isrec -> NtnTypeBinderList - | NtnInternTypeBinder -> user_err Pp.(str "Type binder is only for use in recursive notations for binders.") - -let make_interpretation_vars recvars allvars = + | ETConstr _ -> + if isrec then NtnTypeConstrList else + if isonlybinding then + (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *) + NtnTypeBinder (NtnBinderParsedAsConstr AsIdent) + else NtnTypeConstr + | ETConstrAsBinder (bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk) + | ETName -> NtnTypeBinder NtnParsedAsIdent + | ETPattern (ppstrict,_) -> NtnTypeBinder (NtnParsedAsPattern ppstrict) (* Parsed as ident/pattern, primarily interpreted as binder; maybe strict at printing *) + | ETBigint | ETReference | ETOther _ -> NtnTypeConstr + | ETBinder _ -> + if isrec then NtnTypeBinderList + else anomaly Pp.(str "Type binder is only for use in recursive notations for binders.") + +let make_interpretation_vars recvars allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && List.equal String.equal l1 l2 in let check (x, y) = - let (_,scope1, _) = Id.Map.find x allvars in - let (_,scope2, _) = Id.Map.find y allvars in + let (_,scope1) = Id.Map.find x allvars in + let (_,scope2) = Id.Map.find y allvars in if not (eq_subscope scope1 scope2) then error_not_same_scope x y in let () = List.iter check recvars in let useless_recvars = List.map snd recvars in let mainvars = Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in - Id.Map.mapi (fun x (isonlybinding, sc, typ) -> - (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars + Id.Map.mapi (fun x (isonlybinding, sc) -> + (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding (Id.List.assoc x typs))) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then @@ -979,18 +984,27 @@ let warn_notation_bound_to_variable = let warn_non_reversible_notation = CWarnings.create ~name:"non-reversible-notation" ~category:"parsing" - (fun () -> - strbrk "This notation will not be used for printing as it is not reversible.") - -let is_not_printable onlyparse nonreversible = function + (function + | APrioriReversible -> assert false + | HasLtac -> + strbrk "This notation contains Ltac expressions: it will not be used for printing." + | NonInjective ids -> + let n = List.length ids in + strbrk (String.plural n "Variable") ++ spc () ++ pr_enum Id.print ids ++ spc () ++ + strbrk (if n > 1 then "do" else "does") ++ + str " not occur in the right-hand side." ++ spc() ++ + strbrk "The notation will not be used for printing as it is not reversible.") + +let is_not_printable onlyparse reversibility = function | NVar _ -> if not onlyparse then warn_notation_bound_to_variable (); true | _ -> - if not onlyparse && nonreversible then - (warn_non_reversible_notation (); true) + if not onlyparse && reversibility <> APrioriReversible then + (warn_non_reversible_notation reversibility; true) else onlyparse + let find_precedence lev etyps symbols onlyprint = let first_symbol = let rec aux = function @@ -1008,29 +1022,30 @@ let find_precedence lev etyps symbols onlyprint = match first_symbol with | None -> [],0 | Some (NonTerminal x) -> + let test () = + if onlyprint then + if Option.is_empty lev then + user_err Pp.(str "Explicit level needed in only-printing mode when the level of the leftmost non-terminal is given.") + else [],Option.get lev + else + user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") in (try match List.assoc x etyps with - | ETConstr _ -> - if onlyprint then - if Option.is_empty lev then - user_err Pp.(str "Explicit level needed in only-printing mode when the level of the leftmost non-terminal is given.") - else [],Option.get lev - else - user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") - | ETName | ETBigint | ETReference -> + | ETConstr _ -> test () + | ETConstrAsBinder (_,Some _) -> test () + | (ETName | ETBigint | ETReference) -> begin match lev with | None -> ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) | Some 0 -> ([],0) | _ -> - user_err Pp.(str "A notation starting with an atomic expression must be at level 0.") + user_err Pp.(str "A notation starting with an atomic expression must be at level 0.") end - | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) - if Option.is_empty lev then - user_err Pp.(str "Need an explicit level.") - else [],Option.get lev - | ETConstrList _ | ETBinderList _ -> - assert false (* internally used in grammar only *) + | (ETPattern _ | ETBinder _ | ETOther _ | ETConstrAsBinder _) -> + (* Give a default ? *) + if Option.is_empty lev then + user_err Pp.(str "Need an explicit level.") + else [],Option.get lev with Not_found -> if Option.is_empty lev then user_err Pp.(str "A left-recursive notation must have an explicit level.") @@ -1074,7 +1089,7 @@ let remove_curly_brackets l = module SynData = struct - type subentry_types = (Id.t * (production_level, production_position) constr_entry_key_gen) list + type subentry_types = (Id.t * (production_level * production_position) constr_entry_key_gen) list (* XXX: Document *) type syn_data = { @@ -1128,8 +1143,7 @@ let compute_syntax_data df modifiers = let onlyparse = mods.only_parsing in if onlyprint && onlyparse then user_err (str "A notation cannot be both 'only printing' and 'only parsing'."); let assoc = Option.append mods.assoc (Some NonA) in - let toks = split_notation_string df in - let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint toks in + let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in let _ = check_useless_entry_types recvars mainvars mods.etyps in let _ = check_binder_type recvars mods.etyps in @@ -1152,7 +1166,7 @@ let compute_syntax_data df modifiers = let i_typs = set_internalization_type sy_typs in let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in let pp_sy_data = (sy_typs,symbols) in - let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,i_typs),need_squash) in + let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = ntn_for_interp, df' in @@ -1171,7 +1185,7 @@ let compute_syntax_data df modifiers = mainvars; intern_typs = i_typs; - level = (n,prec,i_typs); + level = (n,prec,List.map snd sy_typs); pa_syntax_data = pa_sy_data; pp_syntax_data = pp_sy_data; not_data = sy_fulldata; @@ -1329,10 +1343,10 @@ let add_notation_in_scope local df env c mods scope = ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map sd.recvars; } in - let (acvars, ac, reversible) = interp_notation_constr env nenv c in - let interp = make_interpretation_vars sd.recvars acvars in + let (acvars, ac, reversibility) = interp_notation_constr env nenv c in + let interp = make_interpretation_vars sd.recvars acvars (fst sd.pa_syntax_data) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in + let onlyparse = is_not_printable sd.only_parsing reversibility ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1350,8 +1364,7 @@ let add_notation_in_scope local df env c mods scope = sd.info let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = - let dfs = split_notation_string df in - let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint dfs in + let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let i_typs, onlyprint = if not (is_numeral symbs) then begin let sy = recover_notation_syntax (make_notation_key symbs) in @@ -1363,15 +1376,15 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ (* Declare interpretation *) let path = (Lib.library_dp(), Lib.current_dirpath true) in let df' = (make_notation_key symbs, (path,df)) in - let i_vars = make_internalization_vars recvars mainvars i_typs in + let i_vars = make_internalization_vars recvars mainvars (List.map internalization_type_of_entry_type i_typs) in let nenv = { ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; } in - let (acvars, ac, reversible) = interp_notation_constr env ~impls nenv c in - let interp = make_interpretation_vars recvars acvars in + let (acvars, ac, reversibility) = interp_notation_constr env ~impls nenv c in + let interp = make_interpretation_vars recvars acvars (List.combine mainvars i_typs) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse (not reversible) ac in + let onlyparse = is_not_printable onlyparse reversibility ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1427,8 +1440,7 @@ let add_notation local env c ((loc,df),modifiers) sc = let add_notation_extra_printing_rule df k v = let notk = - let dfs = split_notation_string df in - let _,_, symbs = analyze_notation_tokens ~onlyprint:true dfs in + let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in make_notation_key symbs in Notation.add_notation_extra_printing_rule notk k v @@ -1499,23 +1511,21 @@ let try_interp_name_alias = function | _ -> raise Not_found let add_syntactic_definition env ident (vars,c) local onlyparse = - let nonprintable = ref false in - let vars,pat = - try [], NRef (try_interp_name_alias (vars,c)) + let vars,reversibility,pat = + try [], APrioriReversible, NRef (try_interp_name_alias (vars,c)) with Not_found -> - let fold accu id = Id.Map.add id NtnInternTypeConstr accu in + let fold accu id = Id.Map.add id NtnInternTypeAny accu in let i_vars = List.fold_left fold Id.Map.empty vars in let nenv = { ninterp_var_type = i_vars; ninterp_rec_vars = Id.Map.empty; } in - let nvars, pat, reversible = interp_notation_constr env nenv c in - let () = nonprintable := not reversible in - let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in - List.map map vars, pat + let nvars, pat, reversibility = interp_notation_constr env nenv c in + let map id = let (_,sc) = Id.Map.find id nvars in (id, sc) in + List.map map vars, reversibility, pat in let onlyparse = match onlyparse with - | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current + | None when (is_not_printable false reversibility pat) -> Some Flags.Current | p -> p in Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index b3049f1b7..9137f7a7e 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -51,14 +51,10 @@ val add_syntax_extension : val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> bool -> Flags.compat_version option -> unit -(** Print the Camlp4 state of a grammar *) +(** Print the Camlp5 state of a grammar *) val pr_grammar : string -> Pp.t -type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry - -val register_grammar : string -> any_entry list -> unit - val check_infix_modifiers : syntax_modifier list -> unit val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/vernac/mltop.ml b/vernac/mltop.ml index d3de10235..053b9d070 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -184,10 +184,28 @@ let warn_cannot_open_path = type add_ml = AddNoML | AddTopML | AddRecML -let add_rec_path add_ml ~unix_path ~coq_root ~implicit = +type vo_path_spec = { + unix_path : string; + coq_path : Names.DirPath.t; + implicit : bool; + has_ml : add_ml; +} + +type coq_path_spec = + | VoPath of vo_path_spec + | MlPath of string + +type coq_path = { + path_spec: coq_path_spec; + recursive: bool; +} + +let add_vo_path ~recursive lp = + let unix_path = lp.unix_path in + let implicit = lp.implicit in if exists_dir unix_path then - let dirs = all_subdirs ~unix_path in - let prefix = Names.DirPath.repr coq_root in + let dirs = if recursive then all_subdirs ~unix_path else [] in + let prefix = Names.DirPath.repr lp.coq_path in let convert_dirs (lp, cp) = try let path = List.rev_map convert_string cp @ prefix in @@ -195,17 +213,23 @@ let add_rec_path add_ml ~unix_path ~coq_root ~implicit = with Exit -> None in let dirs = List.map_filter convert_dirs dirs in - let () = match add_ml with + let () = match lp.has_ml with | AddNoML -> () | AddTopML -> add_ml_dir unix_path | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in let add (path, dir) = Loadpath.add_load_path path ~implicit dir in let () = List.iter add dirs in - Loadpath.add_load_path unix_path ~implicit coq_root + Loadpath.add_load_path unix_path ~implicit lp.coq_path else warn_cannot_open_path unix_path +let add_coq_path { recursive; path_spec } = match path_spec with + | VoPath lp -> + add_vo_path ~recursive lp + | MlPath dir -> + if recursive then add_rec_ml_dir dir else add_ml_dir dir + (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = if Filename.check_suffix name ".cmo" then @@ -378,7 +402,7 @@ let unfreeze_ml_modules x = (fun (name,path) -> trigger_ml_object false false false ?path name) x let _ = - Summary.declare_summary Summary.ml_modules + Summary.declare_ml_modules_summary { Summary.freeze_function = (fun _ -> get_loaded_modules ()); Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 324a66d38..e44a7c243 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -42,14 +42,26 @@ val dir_ml_load : string -> unit (** Dynamic interpretation of .ml *) val dir_ml_use : string -> unit -(** Adds a path to the ML paths *) -val add_ml_dir : string -> unit -val add_rec_ml_dir : string -> unit - +(** Adds a path to the Coq and ML paths *) type add_ml = AddNoML | AddTopML | AddRecML -(** Adds a path to the Coq and ML paths *) -val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit +type vo_path_spec = { + unix_path : string; (* Filesystem path contaning vo/ml files *) + coq_path : Names.DirPath.t; (* Coq prefix for the path *) + implicit : bool; (* [implicit = true] avoids having to qualify with [coq_path] *) + has_ml : add_ml; (* If [has_ml] is true, the directory will also be search for plugins *) +} + +type coq_path_spec = + | VoPath of vo_path_spec + | MlPath of string + +type coq_path = { + path_spec: coq_path_spec; + recursive: bool; +} + +val add_coq_path : coq_path -> unit (** List of modules linked to the toplevel *) val add_known_module : string -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 1046d68f8..58e4b00fc 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -429,8 +429,8 @@ let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let from_prg : program_info ProgMap.t ref = - Summary.ref ProgMap.empty ~name:"program-tcc-table" +let from_prg, program_tcc_summary_tag = + Summary.ref_tag ProgMap.empty ~name:"program-tcc-table" let close sec = if not (ProgMap.is_empty !from_prg) then @@ -477,7 +477,10 @@ let declare_definition prg = let fix_exn = Hook.get get_fix_exn () in let typ = nf typ in let body = nf body in - let uvars = Univ.LSet.union (Univops.universes_of_constr typ) (Univops.universes_of_constr body) in + let env = Global.env () in + let uvars = Univ.LSet.union + (Univops.universes_of_constr env typ) + (Univops.universes_of_constr env body) in let uctx = UState.restrict prg.prg_ctx uvars in let univs = UState.check_univ_decl ~poly:(pi2 prg.prg_kind) uctx prg.prg_univdecl in let ce = definition_entry ~fix_exn ~opaque ~types:typ ~univs body in @@ -833,7 +836,7 @@ let obligation_terminator name num guard hook auto pf = let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in let (body, cstr), () = Future.force entry.Entries.const_entry_body in - let sigma = Evd.from_ctx (fst uctx) in + let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) body; (** Declare the obligation ourselves and drop the hook *) @@ -1182,7 +1185,6 @@ let init_program () = Coqlib.check_required_library ["Coq";"Init";"Specif"]; Coqlib.check_required_library ["Coq";"Program";"Tactics"] - let set_program_mode c = if c then if !Flags.program_mode then () diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 0602e52e9..bdc97d48c 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -104,3 +104,6 @@ exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t val set_program_mode : bool -> unit + +type program_info +val program_tcc_summary_tag : program_info Id.Map.t Summary.Dyn.tag diff --git a/vernac/record.ml b/vernac/record.ml index 1d255b08e..16b95a5ef 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -60,23 +60,25 @@ let _ = optread = (fun () -> !typeclasses_unique); optwrite = (fun b -> typeclasses_unique := b); } -let interp_fields_evars env evars impls_env nots l = +let interp_fields_evars env sigma impls_env nots l = List.fold_left2 - (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> - let t', impl = interp_type_evars_impls env evars ~impls t in - let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in + (fun (env, sigma, uimpls, params, impls) no ((loc, i), b, t) -> + let sigma, (t', impl) = interp_type_evars_impls env sigma ~impls t in + let sigma, b' = + Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ + interp_casted_constr_evars_impls env sigma ~impls x t') (sigma,None) b in let impls = match i with | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method (EConstr.to_constr !evars t') impl) impls + | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method (EConstr.to_constr sigma t') impl) impls in let d = match b' with | None -> LocalAssum (i,t') | Some b' -> LocalDef (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation env impls) no; - (EConstr.push_rel d env, impl :: uimpls, d::params, impls)) - (env, [], [], impls_env) nots l + (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) + (env, sigma, [], [], impls_env) nots l let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> @@ -97,10 +99,9 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def id poly pl t ps nots fs = let env0 = Global.env () in - let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in - let evars = ref evd in - let _ = - let error bk (loc, name) = + let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let _ = + let error bk (loc, name) = match bk, name with | Default _, Anonymous -> user_err ?loc ~hdr:"record" (str "Record parameters must be named") @@ -112,63 +113,65 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = | CLocalPattern (loc,(_,_)) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in - let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in - let typ, sort, template = match t with + let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars env0 sigma ps in + let sigma, typ, sort, template = match t with | Some t -> let env = EConstr.push_rel_context newps env0 in let poly = match t with | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in - let s = interp_type_evars env evars ~impls:empty_internalization_env t in - let sred = Reductionops.whd_all env !evars s in - (match EConstr.kind !evars sred with + let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in + let sred = Reductionops.whd_all env sigma s in + (match EConstr.kind sigma sred with | Sort s' -> - let s' = EConstr.ESorts.kind !evars s' in + let s' = EConstr.ESorts.kind sigma s' in (if poly then - match Evd.is_sort_variable !evars s' with - | Some l -> evars := Evd.make_flexible_variable !evars ~algebraic:true l; - s, s', true - | None -> s, s', false - else s, s', false) + match Evd.is_sort_variable sigma s' with + | Some l -> + let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in + sigma, s, s', true + | None -> + sigma, s, s', false + else sigma, s, s', false) | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in - let s = Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars in - EConstr.mkSort s, s, true + let sigma, s = Evd.new_sort_variable uvarkind sigma in + sigma, EConstr.mkSort s, s, true in let arity = EConstr.it_mkProd_or_LetIn typ newps in let env_ar = EConstr.push_rel_context newps (EConstr.push_rel (LocalAssum (Name id,arity)) env0) in let assums = List.filter is_local_assum newps in let params = List.map (RelDecl.get_name %> Name.get_id) assums in - let ty = Inductive (params,(finite != BiFinite)) in - let impls_env = compute_internalization_env env0 ~impls:impls_env ty [id] [EConstr.to_constr !evars arity] [imps] in - let env2,impls,newfs,data = - interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs) + let ty = Inductive (params,(finite != Declarations.BiFinite)) in + let impls_env = compute_internalization_env env0 ~impls:impls_env ty [id] [EConstr.to_constr sigma arity] [imps] in + let env2,sigma,impls,newfs,data = + interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in - let evars = - Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars Evd.empty in - let typ, evars = - let _, univ = compute_constructor_level evars env_ar newfs in + let sigma = + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma Evd.empty in + let sigma, typ = + let _, univ = compute_constructor_level sigma env_ar newfs in if not def && (Sorts.is_prop sort || (Sorts.is_set sort && is_impredicative_set env0)) then - typ, evars + sigma, typ else - let evars = Evd.set_leq_sort env_ar evars (Type univ) sort in + let sigma = Evd.set_leq_sort env_ar sigma (Type univ) sort in if Univ.is_small_univ univ && - Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars sort) then + Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - EConstr.mkSort (Sorts.sort_of_univ univ), - Evd.set_eq_sort env_ar evars (Prop Pos) sort - else typ, evars + Evd.set_eq_sort env_ar sigma (Prop Pos) sort, + EConstr.mkSort (Sorts.sort_of_univ univ) + else sigma, typ in - let evars, nf = Evarutil.nf_evars_and_universes evars in - let newfs = List.map (EConstr.to_rel_decl evars) newfs in - let newps = List.map (EConstr.to_rel_decl evars) newps in - let typ = EConstr.to_constr evars typ in - let ce t = Pretyping.check_evars env0 Evd.empty evars (EConstr.of_constr t) in - let univs = Evd.check_univ_decl ~poly evars decl in - let ubinders = Evd.universe_binders evars in + let sigma, _ = Evarutil.nf_evars_and_universes sigma in + let newfs = List.map (EConstr.to_rel_decl sigma) newfs in + let newps = List.map (EConstr.to_rel_decl sigma) newps in + let typ = EConstr.to_constr sigma typ in + let ce t = Pretyping.check_evars env0 Evd.empty sigma (EConstr.of_constr t) in + let univs = Evd.check_univ_decl ~poly sigma decl in + let ubinders = Evd.universe_binders sigma in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); ubinders, univs, typ, template, imps, newps, impls, newfs @@ -366,26 +369,10 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) -let structure_signature ctx = - let rec deps_to_evar evm l = - match l with [] -> Evd.empty - | [decl] -> - let env = Environ.empty_named_context_val in - let (evm, _) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in - evm - | decl::tl -> - let env = Environ.empty_named_context_val in - let (evm, ev) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in - let new_tl = Util.List.map_i - (fun pos decl -> - RelDecl.map_type (fun t -> EConstr.Unsafe.to_constr (Termops.replace_term evm (EConstr.mkRel pos) (EConstr.mkEvar(ev,[||])) (EConstr.of_constr t))) decl) 1 tl in - deps_to_evar evm new_tl in - deps_to_evar Evd.empty (List.rev ctx) - open Typeclasses let declare_structure finite ubinders univs id idbuild paramimpls params arity template - fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = + fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers = let nparams = List.length params and nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in @@ -420,17 +407,8 @@ let declare_structure finite ubinders univs id idbuild paramimpls params arity t mind_entry_universes = univs; } in - let mie = - match ctx with - | Polymorphic_const_entry ctx -> - let env = Global.env () in - let env' = Environ.push_context ctx env in - let evd = Evd.from_env env' in - Inductiveops.infer_inductive_subtyping env' evd mie - | Monomorphic_const_entry _ -> - mie - in - let kn = Command.declare_mutual_inductive_with_eliminations mie ubinders [(paramimpls,[])] in + let mie = InferCumulativity.infer_inductive (Global.env ()) mie in + let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name coers ubinders fieldimpls fields in @@ -450,7 +428,7 @@ let implicits_of_context ctx = 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) let declare_class finite def cum ubinders univs id idbuild paramimpls params arity - template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = + template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) let len = List.length params in @@ -498,15 +476,15 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari match univs with | Polymorphic_const_entry univs -> if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) + Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context univs) else Polymorphic_ind_entry univs | Monomorphic_const_entry univs -> Monomorphic_ind_entry univs in - let ind = declare_structure BiFinite ubinders univs (snd id) idbuild paramimpls + let ind = declare_structure Declarations.BiFinite ubinders univs (snd id) idbuild paramimpls params arity template fieldimpls fields - ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign + ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) in let coers = List.map2 (fun coe pri -> Option.map (fun b -> @@ -520,7 +498,7 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari let ctx_context = List.map (fun decl -> match Typeclasses.class_of_constr Evd.empty (EConstr.of_constr (RelDecl.get_type decl)) with - | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) + | Some (_, ((cl,_), _)) -> Some cl.cl_impl | None -> None) params, params in @@ -528,6 +506,7 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari match univs with | Polymorphic_const_entry univs -> let usubst, auctx = Univ.abstract_universes univs in + let usubst = Univ.make_instance_subst usubst in let map c = Vars.subst_univs_level_constr usubst c in let fields = Context.Rel.map map fields in let ctx_context = on_snd (fun d -> Context.Rel.map map d) ctx_context in @@ -612,12 +591,11 @@ let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cf let pl, univs, arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> typecheck_params_and_fields finite (kind = Class true) idstruc poly pl s ps notations fs) () in - let sign = structure_signature (fields@params) in - match kind with + let gr = match kind with | Class def -> let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in let gr = declare_class finite def cum pl univs (loc,idstruc) idbuild - implpars params arity template implfs fields is_coe coers priorities sign in + implpars params arity template implfs fields is_coe coers priorities in gr | _ -> let implfs = List.map @@ -628,7 +606,7 @@ let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cf match univs with | Polymorphic_const_entry univs -> if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) + Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context univs) else Polymorphic_ind_entry univs | Monomorphic_const_entry univs -> @@ -636,5 +614,8 @@ let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cf in let ind = declare_structure finite pl univs idstruc idbuild implpars params arity template implfs - fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in + fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) in IndRef ind + in + Declare.declare_univ_binders gr pl; + gr diff --git a/vernac/record.mli b/vernac/record.mli index 9fdd5e1c4..e0a4b8fdd 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -13,9 +13,20 @@ open Globnames val primitive_flag : bool ref +val declare_projections : + inductive -> + Entries.constant_universes_entry -> + ?kind:Decl_kinds.definition_object_kind -> + Id.t -> + bool list -> + Universes.universe_binders -> + Impargs.manual_implicits list -> + Context.Rel.t -> + (Name.t * bool) list * Constant.t option list + val definition_structure : inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * - Decl_kinds.recursivity_kind * ident_decl with_coercion * local_binder_expr list * + Declarations.recursivity_kind * ident_decl with_coercion * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 6a10eb43a..1ad7ead72 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Feedback open Pp (** Pp control also belongs here as the terminal is private to the toplevel *) @@ -138,7 +137,7 @@ let make_body quoter info ?pre_hdr s = (* The empty quoter *) let noq x = x (* Generic logger *) -let gen_logger dbg warn ?pre_hdr level msg = match level with +let gen_logger dbg warn ?pre_hdr level msg = let open Feedback in match level with | Debug -> msgnl_with !std_ft (make_body dbg dbg_hdr ?pre_hdr msg) | Info -> msgnl_with !std_ft (make_body dbg info_hdr ?pre_hdr msg) | Notice -> msgnl_with !std_ft (make_body noq info_hdr ?pre_hdr msg) @@ -288,7 +287,6 @@ let init_terminal_output ~color = *) let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning - (* This is specific to the toplevel *) let pr_loc loc = let fname = loc.Loc.fname in @@ -311,17 +309,23 @@ let print_err_exn ?extra any = std_logger ~pre_hdr Feedback.Error msg let with_output_to_file fname func input = - (* XXX FIXME: redirect std_ft *) - (* let old_logger = !logger in *) let channel = open_out (String.concat "." [fname; "out"]) in - (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *) + let old_fmt = !std_ft, !err_ft, !deep_ft in + let new_ft = Format.formatter_of_out_channel channel in + std_ft := new_ft; + err_ft := new_ft; + deep_ft := new_ft; try let output = func input in - (* logger := old_logger; *) + std_ft := Util.pi1 old_fmt; + err_ft := Util.pi2 old_fmt; + deep_ft := Util.pi3 old_fmt; close_out channel; output with reraise -> let reraise = Backtrace.add_backtrace reraise in - (* logger := old_logger; *) + std_ft := Util.pi1 old_fmt; + err_ft := Util.pi2 old_fmt; + deep_ft := Util.pi3 old_fmt; close_out channel; Exninfo.iraise reraise diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 8673155e2..f001b572a 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -11,7 +11,11 @@ Search Indschemes DeclareDef Obligations -Command +ComDefinition +ComAssumption +ComInductive +ComFixpoint +ComProgramFixpoint Classes Record Assumptions diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 7f3410bc1..fa457c895 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -18,7 +18,6 @@ open Tacmach open Constrintern open Prettyp open Printer -open Command open Goptions open Libnames open Globnames @@ -59,20 +58,20 @@ let show_proof () = let p = Proof_global.give_me_the_proof () in let sigma, env = Pfedit.get_current_context () in let pprf = Proof.partial_proof p in - Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) + Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in let gls,_,_,_,sigma = Proof.proof pfts in - Feedback.msg_notice (pr_evars_int sigma 1 (Evd.undefined_map sigma)) + pr_evars_int sigma 1 (Evd.undefined_map sigma) let show_universes () = let pfts = Proof_global.give_me_the_proof () in let gls,_,_,_,sigma = Proof.proof pfts in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in - Feedback.msg_notice (Termops.pr_evar_universe_context (Evd.evar_universe_context sigma)); - Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx) + Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ + str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) let show_intro all = @@ -84,11 +83,12 @@ let show_intro all = let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in - Feedback.msg_notice (hov 0 (prlist_with_sep spc Id.print lid)) + hov 0 (prlist_with_sep spc Id.print lid) else if not (List.is_empty l) then let n = List.last l in - Feedback.msg_notice (Id.print (List.hd (Tactics.find_intro_names [n] gl))) - end + Id.print (List.hd (Tactics.find_intro_names [n] gl)) + else mt () + end else mt () (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name @@ -147,8 +147,8 @@ let show_match id = let pr_branch l = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" in - Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++ - prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) + v 1 (str "match # with" ++ fnl () ++ + prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ()) (* "Print" commands *) @@ -186,24 +186,24 @@ let print_module r = try let globdir = Nametab.locate_dir qid in match globdir with - DirModule (dirpath,(mp,_)) -> - Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) + DirModule { obj_dir; obj_mp; _ } -> + Printmod.print_module (Printmod.printable_body obj_dir) obj_mp | _ -> raise Not_found with - Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) + Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid) let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in - Feedback.msg_notice (Printmod.print_modtype kn) + Printmod.print_modtype kn with Not_found -> (* Is there a module of this name ? If yes we display its type *) try let mp = Nametab.locate_module qid in - Feedback.msg_notice (Printmod.print_module false mp) + Printmod.print_module false mp with Not_found -> - Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid) + user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) let print_namespace ns = let ns = List.rev (Names.DirPath.repr ns) in @@ -273,7 +273,7 @@ let print_namespace ns = acc ) constants (str"") in - Feedback.msg_notice ((print_list Id.print ns)++str":"++fnl()++constants_in_namespace) + (print_list Id.print ns)++str":"++fnl()++constants_in_namespace let print_strategy r = let open Conv_oracle in @@ -303,7 +303,7 @@ let print_strategy r = else str "Constant strategies" ++ fnl () ++ hov 0 (prlist_with_sep fnl pr_strategy cst_lvl) in - Feedback.msg_notice (var_msg ++ cst_msg) + var_msg ++ cst_msg | Some r -> let r = Smartlocate.smart_global r in let key = match r with @@ -312,7 +312,7 @@ let print_strategy r = | IndRef _ | ConstructRef _ -> user_err Pp.(str "The reference is not unfoldable") in let lvl = get_strategy oracle key in - Feedback.msg_notice (pr_strategy (r, lvl)) + pr_strategy (r, lvl) let dump_universes_gen g s = let output = open_out s in @@ -346,7 +346,7 @@ let dump_universes_gen g s = try UGraph.dump_universes output_constraint g; close (); - Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".") + str "Universes written to file \"" ++ str s ++ str "\"." with reraise -> let reraise = CErrors.push reraise in close (); @@ -361,12 +361,9 @@ let locate_file f = let msg_found_library = function | Library.LibLoaded, fulldir, file -> - Feedback.msg_info (hov 0 - (DirPath.print fulldir ++ strbrk " has been loaded from file " ++ - str file)) + hov 0 (DirPath.print fulldir ++ strbrk " has been loaded from file " ++ str file) | Library.LibInPath, fulldir, file -> - Feedback.msg_info (hov 0 - (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file)) + hov 0 (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file) let err_unmapped_library ?loc ?from qid = let dir = fst (repr_qualid qid) in @@ -409,8 +406,8 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension atts local infix l = - let local = enforce_module_locality atts.locality local in +let vernac_syntax_extension atts infix l = + let local = enforce_module_locality atts.locality in if infix then Metasyntax.check_infix_modifiers (snd l); Metasyntax.add_syntax_extension local l @@ -421,20 +418,20 @@ let vernac_delimiters sc = function let vernac_bind_scope sc cll = Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) -let vernac_open_close_scope ~atts local (b,s) = - let local = enforce_section_locality atts.locality local in +let vernac_open_close_scope ~atts (b,s) = + let local = enforce_section_locality atts.locality in Notation.open_close_scope (local,b,s) let vernac_arguments_scope ~atts r scl = let local = make_section_locality atts.locality in Notation.declare_arguments_scope local (smart_global r) scl -let vernac_infix ~atts local = - let local = enforce_module_locality atts.locality local in +let vernac_infix ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_infix local (Global.env()) -let vernac_notation ~atts local = - let local = enforce_module_locality atts.locality local in +let vernac_notation ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_notation local (Global.env()) (***********) @@ -446,11 +443,13 @@ let start_proof_and_print k l hook = let hook env sigma ev = let tac = !Obligations.default_tactic in let evi = Evd.find sigma ev in + let evi = Evarutil.nf_evar_info sigma evi in let env = Evd.evar_filtered_env evi in try - let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in - let concl = EConstr.of_constr concl in - if Evarutil.has_undefined_evars sigma concl then raise Exit; + let concl = EConstr.of_constr evi.Evd.evar_concl in + if not (Evarutil.is_ground_env sigma env && + Evarutil.is_ground_term sigma concl) + then raise Exit; let c, _, ctx = Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) concl (Tacticals.New.tclCOMPLETE tac) @@ -472,32 +471,40 @@ let vernac_definition_hook p = function | SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition ~atts (local,k) ((loc,id as lid),pl) def = - let local = enforce_locality_exp atts.locality local in - let hook = vernac_definition_hook atts.polymorphic k in - let () = match local with - | Discharge -> Dumpglob.dump_definition lid true "var" - | Local | Global -> Dumpglob.dump_definition lid false "def" +let vernac_definition ~atts discharge kind ((loc, id), pl) def = + let local = enforce_locality_exp atts.locality discharge in + let hook = vernac_definition_hook atts.polymorphic kind in + let () = + match id with + | Anonymous -> () + | Name n -> let lid = (loc, n) in + match local with + | Discharge -> Dumpglob.dump_definition lid true "var" + | Local | Global -> Dumpglob.dump_definition lid false "def" + in + let program_mode = Flags.is_program_mode () in + let name = + match id with + | Anonymous -> fresh_name_for_anonymous_theorem () + | Name n -> n in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local, atts.polymorphic, DefinitionBody k) - [Some (lid,pl), (bl,t)] hook + start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) + [((loc, name), pl), (bl, t)] hook | DefineBody (bl,red_option,c,typ_opt) -> - let red_option = match red_option with + let red_option = match red_option with | None -> None | Some r -> let sigma, env = Pfedit.get_current_context () in Some (snd (Hook.get f_interp_redexp env sigma r)) in - do_definition id (local, atts.polymorphic,k) pl bl red_option c typ_opt hook) + ComDefinition.do_definition ~program_mode name + (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) let vernac_start_proof ~atts kind l = - let local = enforce_locality_exp atts.locality None in + let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then - List.iter (fun (id, _) -> - match id with - | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" - | None -> ()) l; + List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; start_proof_and_print (local, atts.polymorphic, Proof kind) l no_hook let vernac_end_proof ?proof = function @@ -511,8 +518,8 @@ let vernac_exact_proof c = save_proof (Vernacexpr.(Proved(Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom -let vernac_assumption ~atts (local, kind) l nl = - let local = enforce_locality_exp atts.locality local in +let vernac_assumption ~atts discharge kind l nl = + let local = enforce_locality_exp atts.locality discharge in let global = local == Global in let kind = local, atts.polymorphic, kind in List.iter (fun (is_coe,(idl,c)) -> @@ -520,7 +527,7 @@ let vernac_assumption ~atts (local, kind) l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = do_assumptions kind nl l in + let status = ComAssumption.do_assumptions kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let should_treat_as_cumulative cum poly = @@ -592,18 +599,29 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl is_cumulative atts.polymorphic lo finite + ComInductive.do_mutual_inductive indl is_cumulative atts.polymorphic lo finite -let vernac_fixpoint ~atts local l = - let local = enforce_locality_exp atts.locality local in +let vernac_fixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + (* XXX: Switch to the attribute system and match on ~atts *) + let do_fixpoint = if Flags.is_program_mode () then + ComProgramFixpoint.do_fixpoint + else + ComFixpoint.do_fixpoint + in do_fixpoint local atts.polymorphic l -let vernac_cofixpoint ~atts local l = - let local = enforce_locality_exp atts.locality local in +let vernac_cofixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + let do_cofixpoint = if Flags.is_program_mode () then + ComProgramFixpoint.do_cofixpoint + else + ComFixpoint.do_cofixpoint + in do_cofixpoint local atts.polymorphic l let vernac_scheme l = @@ -627,14 +645,14 @@ let vernac_universe ~atts l = user_err ?loc:atts.loc ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - do_universe atts.polymorphic l + Declare.do_universe atts.polymorphic l let vernac_constraint ~atts l = if atts.polymorphic && not (Lib.sections_are_opened ()) then user_err ?loc:atts.loc ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - do_constraint atts.polymorphic l + Declare.do_constraint atts.polymorphic l (**********************) (* Modules *) @@ -812,16 +830,16 @@ let vernac_require from import qidl = let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) -let vernac_coercion ~atts local ref qids qidt = - let local = enforce_locality atts.locality local in +let vernac_coercion ~atts ref qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' ~local atts.polymorphic ~source ~target; Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") -let vernac_identity_coercion ~atts local id qids qidt = - let local = enforce_locality atts.locality local in +let vernac_identity_coercion ~atts id qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in Class.try_add_new_identity_coercion id ~local atts.polymorphic ~source ~target @@ -831,7 +849,8 @@ let vernac_identity_coercion ~atts local id qids qidt = let vernac_instance ~atts abst sup inst props pri = let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~abstract:abst ~global atts.polymorphic sup inst props pri) + let program_mode = Flags.is_program_mode () in + ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri) let vernac_context ~atts l = if not (Classes.context atts.polymorphic l) then Feedback.feedback Feedback.AddedAxiom @@ -893,9 +912,11 @@ let expand filename = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename let vernac_add_loadpath implicit pdir ldiropt = + let open Mltop in let pdir = expand pdir in let alias = Option.default Libnames.default_root_prefix ldiropt in - Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit + add_coq_path { recursive = true; + path_spec = VoPath { unix_path = pdir; coq_path = alias; has_ml = AddTopML; implicit } } let vernac_remove_loadpath path = Loadpath.remove_load_path (expand path) @@ -903,7 +924,8 @@ let vernac_remove_loadpath path = (* Coq syntax for ML or system commands *) let vernac_add_ml_path isrec path = - (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path) + let open Mltop in + add_coq_path { recursive = isrec; path_spec = MlPath (expand path) } let vernac_declare_ml_module ~atts l = let local = make_locality atts.locality in @@ -922,7 +944,6 @@ let vernac_chdir = function end; Flags.if_verbose Feedback.msg_info (str (Sys.getcwd())) - (********************) (* State management *) @@ -947,13 +968,13 @@ let vernac_remove_hints ~atts dbs ids = let local = make_module_locality atts.locality in Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) -let vernac_hints ~atts local lb h = - let local = enforce_module_locality atts.locality local in +let vernac_hints ~atts lb h = + let local = enforce_module_locality atts.locality in Hints.add_hints local lb (Hints.interp_hints atts.polymorphic h) -let vernac_syntactic_definition ~atts lid x local y = +let vernac_syntactic_definition ~atts lid x y = Dumpglob.dump_definition lid false "syndef"; - let local = enforce_module_locality atts.locality local in + let local = enforce_module_locality atts.locality in Metasyntax.add_syntactic_definition (Global.env()) (snd lid) x local y let vernac_declare_implicits ~atts r l = @@ -1368,11 +1389,13 @@ let _ = optread = (fun () -> !Flags.program_mode); optwrite = (fun b -> Flags.program_mode:=b) } +let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] + let _ = declare_bool_option { optdepr = false; optname = "universe polymorphism"; - optkey = ["Universe"; "Polymorphism"]; + optkey = universe_polymorphism_option_name; optread = Flags.is_universe_polymorphism; optwrite = Flags.make_universe_polymorphism } @@ -1570,10 +1593,10 @@ let vernac_check_may_eval ~atts redexp glopt rc = | None -> let evars_of_term c = Evarutil.undefined_evars_of_term sigma' c in let l = Evar.Set.union (evars_of_term j.Environ.uj_val) (evars_of_term j.Environ.uj_type) in - let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in - Feedback.msg_notice (print_judgment env sigma' j ++ - pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ - Printer.pr_universe_ctx_set sigma uctx) + let j = { j with Environ.uj_type = Reductionops.nf_betaiota env sigma' j.Environ.uj_type } in + print_judgment env sigma' j ++ + pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ + Printer.pr_universe_ctx_set sigma uctx | Some r -> let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = @@ -1581,7 +1604,7 @@ let vernac_check_may_eval ~atts redexp glopt rc = let (_, c) = redfun env evm c in c in - Feedback.msg_notice (print_eval redfun env sigma' rc j) + print_eval redfun env sigma' rc j let vernac_declare_reduction ~atts s r = let local = make_locality atts.locality in @@ -1591,13 +1614,14 @@ let vernac_declare_reduction ~atts s r = let vernac_global_check c = let env = Global.env() in let sigma = Evd.from_env env in - let c,ctx = interp_constr env sigma c in + let c,uctx = interp_constr env sigma c in let senv = Global.safe_env() in - let cstrs = snd (UState.context_set ctx) in - let senv = Safe_typing.add_constraints cstrs senv in + let uctx = UState.context_set uctx in + let senv = Safe_typing.push_context_set false uctx senv in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in - Feedback.msg_notice (print_safe_judgment env sigma j) + print_safe_judgment env sigma j ++ + pr_universe_ctx_set sigma uctx let get_nth_goal n = @@ -1605,7 +1629,7 @@ let get_nth_goal n = let gls,_,_,_,sigma = Proof.proof pf in let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in gl - + exception NoHyp (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the @@ -1639,31 +1663,32 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = print_about env sigma ref_or_by_not udecl let vernac_print ~atts env sigma = - let open Feedback in let loc = atts.loc in function - | PrintTables -> msg_notice (print_tables ()) - | PrintFullContext-> msg_notice (print_full_context_typ env sigma) - | PrintSectionContext qid -> msg_notice (print_sec_context_typ env sigma qid) - | PrintInspect n -> msg_notice (inspect env sigma n) - | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent) - | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir) - | PrintModules -> msg_notice (print_modules ()) + | PrintTables -> print_tables () + | PrintFullContext-> print_full_context_typ env sigma + | PrintSectionContext qid -> print_sec_context_typ env sigma qid + | PrintInspect n -> inspect env sigma n + | PrintGrammar ent -> Metasyntax.pr_grammar ent + | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir + | PrintModules -> print_modules () | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid | PrintNamespace ns -> print_namespace ns - | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ()) - | PrintMLModules -> msg_notice (Mltop.print_ml_modules ()) - | PrintDebugGC -> msg_notice (Mltop.print_gc ()) - | PrintName (qid,udecl) -> dump_global qid; msg_notice (print_name env sigma qid udecl) - | PrintGraph -> msg_notice (Prettyp.print_graph()) - | PrintClasses -> msg_notice (Prettyp.print_classes()) - | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) - | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintCoercions -> msg_notice (Prettyp.print_coercions env sigma) + | PrintMLLoadPath -> Mltop.print_ml_path () + | PrintMLModules -> Mltop.print_ml_modules () + | PrintDebugGC -> Mltop.print_gc () + | PrintName (qid,udecl) -> + dump_global qid; + print_name env sigma qid udecl + | PrintGraph -> Prettyp.print_graph env sigma + | PrintClasses -> Prettyp.print_classes() + | PrintTypeClasses -> Prettyp.print_typeclasses() + | PrintInstances c -> Prettyp.print_instances (smart_global c) + | PrintCoercions -> Prettyp.print_coercions env sigma | PrintCoercionPaths (cls,clt) -> - msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) - | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections env sigma) + Prettyp.print_path_between env sigma (cl_of_qualid cls) (cl_of_qualid clt) + | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then UGraph.sort_universes univ else univ in @@ -1672,23 +1697,24 @@ let vernac_print ~atts env sigma = else str"There may remain asynchronous universe constraints" in begin match dst with - | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) + | None -> UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining | Some s -> dump_universes_gen univ s end - | PrintHint r -> msg_notice (Hints.pr_hint_ref env sigma (smart_global r)) - | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) - | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name env sigma s) - | PrintHintDb -> msg_notice (Hints.pr_searchtable env sigma) + | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) + | PrintHintGoal -> Hints.pr_applicable_hint () + | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s + | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> - msg_notice (Notation.pr_scopes (Constrextern.without_symbols (pr_lglob_constr_env env))) + Notation.pr_scopes (Constrextern.without_symbols (pr_lglob_constr_env env)) | PrintScope s -> - msg_notice (Notation.pr_scope (Constrextern.without_symbols (pr_lglob_constr_env env)) s) + Notation.pr_scope (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintVisibility s -> - msg_notice (Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s) + Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> - msg_notice (print_about_hyp_globs ?loc ref_or_by_not udecl glnumopt) + print_about_hyp_globs ?loc ref_or_by_not udecl glnumopt | PrintImplicit qid -> - dump_global qid; msg_notice (print_impargs qid) + dump_global qid; + print_impargs qid | PrintAssumptions (o,t,r) -> (* Prints all the axioms and section variables used by a term *) let gr = smart_global r in @@ -1696,7 +1722,7 @@ let vernac_print ~atts env sigma = let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in - msg_notice (Printer.pr_assumptionset (Global.env ()) nassums) + Printer.pr_assumptionset env sigma nassums | PrintStrategy r -> print_strategy r let global_module r = @@ -1782,19 +1808,18 @@ let vernac_search ~atts s gopt r = | SearchAbout sl -> (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r |> Search.prioritize_search) pr_search -let vernac_locate = let open Feedback in function - | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) - | LocateTerm (AN qid) -> msg_notice (print_located_term qid) +let vernac_locate = function + | LocateAny (AN qid) -> print_located_qualid qid + | LocateTerm (AN qid) -> print_located_term qid | LocateAny (ByNotation (_, (ntn, sc))) (** TODO : handle Ltac notations *) | LocateTerm (ByNotation (_, (ntn, sc))) -> let _, env = Pfedit.get_current_context () in - msg_notice - (Notation.locate_notation - (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc) + Notation.locate_notation + (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid - | LocateModule qid -> msg_notice (print_located_module qid) - | LocateOther (s, qid) -> msg_notice (print_located_other s qid) - | LocateFile f -> msg_notice (locate_file f) + | LocateModule qid -> print_located_module qid + | LocateOther (s, qid) -> print_located_other s qid + | LocateFile f -> locate_file f let vernac_register id r = if Proof_global.there_are_pending_proofs () then @@ -1826,16 +1851,13 @@ let vernac_unfocus () = let vernac_unfocused () = let p = Proof_global.give_me_the_proof () in if Proof.unfocused p then - Feedback.msg_notice (str"The proof is indeed fully unfocused.") + str"The proof is indeed fully unfocused." else user_err Pp.(str "The proof is not fully unfocused.") -(* BeginSubproof / EndSubproof. - BeginSubproof (vernac_subproof) focuses on the first goal, or the goal - given as argument. - EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided - that the proof of the goal has been completed. +(* "{" focuses on the first goal, "n: {" focuses on the n-th goal + "}" unfocuses, provided that the proof of the goal has been completed. *) let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind @@ -1844,7 +1866,9 @@ let vernac_subproof gln = Proof_global.simple_with_current_proof (fun _ p -> match gln with | None -> Proof.focus subproof_cond () 1 p - | Some n -> Proof.focus subproof_cond () n p) + | Some (SelectNth n) -> Proof.focus subproof_cond () n p + | _ -> user_err ~hdr:"bracket_selector" + (str "Brackets only support the single numbered goal selector.")) let vernac_end_subproof () = Proof_global.simple_with_current_proof (fun _ p -> @@ -1854,21 +1878,20 @@ let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_bullet.put p bullet) -let vernac_show = let open Feedback in function +let vernac_show = function | ShowScript -> assert false (* Only the stm knows the script *) | ShowGoal goalref -> let proof = Proof_global.give_me_the_proof () in - let info = match goalref with - | OpenSubgoals -> pr_open_subgoals ~proof - | NthGoal n -> pr_nth_open_subgoal ~proof n - | GoalId id -> pr_goal_by_id ~proof id - in - msg_notice info + begin match goalref with + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id + end | ShowProof -> show_proof () | ShowExistentials -> show_top_evars () | ShowUniverses -> show_universes () | ShowProofNames -> - msg_notice (pr_sequence Id.print (Proof_global.get_all_proof_names())) + pr_sequence Id.print (Proof_global.get_all_proof_names()) | ShowIntros all -> show_intro all | ShowMatch id -> show_match id @@ -1883,8 +1906,7 @@ let vernac_check_guard () = (str "The condition holds up to here") with UserError(_,s) -> (str ("Condition violated: ") ++s) - in - Feedback.msg_notice message + in message exception End_of_input @@ -1920,19 +1942,11 @@ let vernac_load interp fname = * loc is the Loc.t of the vernacular command being interpreted. *) let interp ?proof ~atts ~st c = let open Vernacinterp in - vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); + vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with - (* The below vernac are candidates for removal from the main type - and to be put into a new doc_command datatype: *) | VernacLoad _ -> assert false - (* Done later in this file *) - | VernacFail _ -> assert false - | VernacTime _ -> assert false - | VernacRedirect _ -> assert false - | VernacTimeout _ -> assert false - (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") @@ -1952,33 +1966,30 @@ let interp ?proof ~atts ~st c = (* This one is possible to handle here *) | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") - (* Handled elsewhere *) - | VernacProgram _ - | VernacPolymorphic _ - | VernacLocal _ -> assert false - (* Syntax *) - | VernacSyntaxExtension (infix, local,sl) -> - vernac_syntax_extension atts local infix sl + | VernacSyntaxExtension (infix, sl) -> + vernac_syntax_extension atts infix sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl - | VernacOpenCloseScope (local, s) -> vernac_open_close_scope ~atts local s + | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s) | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope ~atts qid scl - | VernacInfix (local,mv,qid,sc) -> vernac_infix ~atts local mv qid sc - | VernacNotation (local,c,infpl,sc) -> - vernac_notation ~atts local c infpl sc + | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc + | VernacNotation (c,infpl,sc) -> + vernac_notation ~atts c infpl sc | VernacNotationAddFormat(n,k,v) -> Metasyntax.add_notation_extra_printing_rule n k v (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition ~atts k lid d + | VernacDefinition ((discharge,kind),lid,d) -> + vernac_definition ~atts discharge kind lid d | VernacStartTheoremProof (k,l) -> vernac_start_proof ~atts k l | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c - | VernacAssumption (stre,nl,l) -> vernac_assumption ~atts stre l nl + | VernacAssumption ((discharge,kind),nl,l) -> + vernac_assumption ~atts discharge kind l nl | VernacInductive (cum, priv,finite,l) -> vernac_inductive ~atts cum priv finite l - | VernacFixpoint (local, l) -> vernac_fixpoint ~atts local l - | VernacCoFixpoint (local, l) -> vernac_cofixpoint ~atts local l + | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l + | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l | VernacUniverse l -> vernac_universe ~atts l @@ -2003,9 +2014,9 @@ let interp ?proof ~atts ~st c = | VernacRequire (from, export, qidl) -> vernac_require from export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion ~atts local r s t - | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion ~atts local id s t + | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacIdentityCoercion ((_,id),s,t) -> + vernac_identity_coercion ~atts id s t (* Type classes *) | VernacInstance (abst, sup, inst, props, info) -> @@ -2031,10 +2042,10 @@ let interp ?proof ~atts ~st c = (* Commands *) | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb ~atts dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints ~atts dbnames ids - | VernacHints (local,dbnames,hints) -> - vernac_hints ~atts local dbnames hints - | VernacSyntacticDefinition (id,c,local,b) -> - vernac_syntactic_definition ~atts id c local b + | VernacHints (dbnames,hints) -> + vernac_hints ~atts dbnames hints + | VernacSyntacticDefinition (id,c,b) -> + vernac_syntactic_definition ~atts id c b | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits ~atts qid l | VernacArguments (qid, args, more_implicits, nargs, flags) -> @@ -2050,27 +2061,32 @@ let interp ?proof ~atts ~st c = | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key - | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ~atts r g c + | VernacCheckMayEval (r,g,c) -> + Feedback.msg_notice @@ vernac_check_may_eval ~atts r g c | VernacDeclareReduction (s,r) -> vernac_declare_reduction ~atts s r - | VernacGlobalCheck c -> vernac_global_check c + | VernacGlobalCheck c -> + Feedback.msg_notice @@ vernac_global_check c | VernacPrint p -> let sigma, env = Pfedit.get_current_context () in - vernac_print ~atts env sigma p + Feedback.msg_notice @@ vernac_print ~atts env sigma p | VernacSearch (s,g,r) -> vernac_search ~atts s g r - | VernacLocate l -> vernac_locate l + | VernacLocate l -> + Feedback.msg_notice @@ vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) - | VernacGoal t -> vernac_start_proof ~atts Theorem [None,([],t)] | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () - | VernacUnfocused -> vernac_unfocused () + | VernacUnfocused -> + Feedback.msg_notice @@ vernac_unfocused () | VernacBullet b -> vernac_bullet b | VernacSubproof n -> vernac_subproof n | VernacEndSubproof -> vernac_end_subproof () - | VernacShow s -> vernac_show s - | VernacCheckGuard -> vernac_check_guard () + | VernacShow s -> + Feedback.msg_notice @@ vernac_show s + | VernacCheckGuard -> + Feedback.msg_notice @@ vernac_check_guard () | VernacProof (tac, using) -> let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in @@ -2123,10 +2139,6 @@ let check_vernac_supports_polymorphism c p = | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () | Some _, _ -> user_err Pp.(str "This command does not support Polymorphism") -let enforce_polymorphism = function - | None -> Flags.is_universe_polymorphism () - | Some b -> Flags.make_polymorphic_flag b; b - (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2193,56 +2205,64 @@ let with_fail st b f = end let interp ?(verbosely=true) ?proof ~st (loc,c) = + let orig_univ_poly = Flags.is_universe_polymorphism () in let orig_program_mode = Flags.is_program_mode () in - let rec aux ?polymorphism ~atts isprogcmd = function - - | VernacProgram c when not isprogcmd -> - aux ?polymorphism ~atts true c - - | VernacProgram _ -> - user_err Pp.(str "Program mode specified twice") - - | VernacPolymorphic (b, c) when polymorphism = None -> - aux ~polymorphism:b ~atts:atts isprogcmd c - - | VernacPolymorphic (b, c) -> - user_err Pp.(str "Polymorphism specified twice") - - | VernacLocal (b, c) when Option.is_empty atts.locality -> - aux ?polymorphism ~atts:{atts with locality = Some b} isprogcmd c - - | VernacLocal _ -> - user_err Pp.(str "Locality specified twice") - - | VernacFail v -> - with_fail st true (fun () -> aux ?polymorphism ~atts isprogcmd v) - - | VernacTimeout (n,v) -> + let flags f atts = + List.fold_left + (fun (polymorphism, atts) f -> + match f with + | VernacProgram when not atts.program -> + (polymorphism, { atts with program = true }) + | VernacProgram -> + user_err Pp.(str "Program mode specified twice") + | VernacPolymorphic b when polymorphism = None -> + (Some b, atts) + | VernacPolymorphic _ -> + user_err Pp.(str "Polymorphism specified twice") + | VernacLocal b when Option.is_empty atts.locality -> + (polymorphism, { atts with locality = Some b }) + | VernacLocal _ -> + user_err Pp.(str "Locality specified twice") + ) + (None, atts) + f + in + let rec control = function + | VernacExpr (f, v) -> + let (polymorphism, atts) = flags f { loc; locality = None; polymorphic = false; program = orig_program_mode; } in + aux ~polymorphism ~atts v + | VernacFail v -> with_fail st true (fun () -> control v) + | VernacTimeout (n,v) -> current_timeout := Some n; - aux ?polymorphism ~atts isprogcmd v - - | VernacRedirect (s, (_,v)) -> - Topfmt.with_output_to_file s (aux ?polymorphism ~atts isprogcmd) v + control v + | VernacRedirect (s, (_,v)) -> + Topfmt.with_output_to_file s control v + | VernacTime (batch, (_loc,v)) -> + System.with_time ~batch control v; - | VernacTime (_,v) -> - System.with_time !Flags.time (aux ?polymorphism ~atts isprogcmd) v; + and aux ~polymorphism ~atts : _ -> unit = + function - | VernacLoad (_,fname) -> vernac_load (aux ?polymorphism ~atts false) fname + | VernacLoad (_,fname) -> vernac_load control fname | c -> check_vernac_supports_locality c atts.locality; check_vernac_supports_polymorphism c polymorphism; - let polymorphic = enforce_polymorphism polymorphism in - Obligations.set_program_mode isprogcmd; + let polymorphic = Option.default (Flags.is_universe_polymorphism ()) polymorphism in + Flags.make_universe_polymorphism polymorphic; + Obligations.set_program_mode atts.program; try vernac_timeout begin fun () -> let atts = { atts with polymorphic } in if verbosely then Flags.verbosely (interp ?proof ~atts ~st) c else Flags.silently (interp ?proof ~atts ~st) c; - if orig_program_mode || not !Flags.program_mode || isprogcmd then + (* If the command is `(Un)Set Program Mode` or `(Un)Set Universe Polymorphism`, + we should not restore the previous state of the flag... *) + if orig_program_mode || not !Flags.program_mode || atts.program then Flags.program_mode := orig_program_mode; - ignore (Flags.use_polymorphic_flag ()) + if (Flags.is_universe_polymorphism() = polymorphic) then + Flags.make_universe_polymorphism orig_univ_poly; end with | reraise when @@ -2253,18 +2273,21 @@ let interp ?(verbosely=true) ?proof ~st (loc,c) = let e = CErrors.push reraise in let e = locate_if_not_already ?loc e in let () = restore_timeout () in + Flags.make_universe_polymorphism orig_univ_poly; Flags.program_mode := orig_program_mode; - ignore (Flags.use_polymorphic_flag ()); iraise e in - let atts = { loc; locality = None; polymorphic = false; } in if verbosely - then Flags.verbosely (aux ~atts orig_program_mode) c - else aux ~atts orig_program_mode c + then Flags.verbosely control c + else control c -(* XXX: There is a bug here in case of an exception, see @gares - comments on the PR *) +(* Be careful with the cache here in case of an exception. *) let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; - interp ?verbosely ?proof ~st cmd; - Vernacstate.freeze_interp_state `No + try + interp ?verbosely ?proof ~st cmd; + Vernacstate.freeze_interp_state `No + with exn -> + let exn = CErrors.push exn in + Vernacstate.invalidate_cache (); + iraise exn diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index a559912a0..e99a62fe6 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -18,7 +18,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - st:Vernacstate.t -> Vernacexpr.vernac_expr Loc.located -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_control Loc.located -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name @@ -36,3 +36,5 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t + +val universe_polymorphism_option_name : string list diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index c0b93c163..c40ca27db 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -16,6 +16,7 @@ type atts = { loc : Loc.t option; locality : bool option; polymorphic : bool; + program : bool; } type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index ab3d4bfc5..c5e610f89 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -14,6 +14,7 @@ type atts = { loc : Loc.t option; locality : bool option; polymorphic : bool; + program : bool; } type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 3cff1f14c..3932d1c7b 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -11,42 +11,48 @@ open Vernacexpr +let rec under_control = function + | VernacExpr (_, c) -> c + | VernacRedirect (_,(_,c)) + | VernacTime (_,(_,c)) + | VernacFail c + | VernacTimeout (_,c) -> under_control c + +let rec has_Fail = function + | VernacExpr _ -> false + | VernacRedirect (_,(_,c)) + | VernacTime (_,(_,c)) + | VernacTimeout (_,c) -> has_Fail c + | VernacFail _ -> true + (* Navigation commands are allowed in a coqtop session but not in a .v file *) -let rec is_navigation_vernac = function +let is_navigation_vernac_expr = function | VernacResetInitial | VernacResetName _ | VernacBacktrack _ | VernacBackTo _ | VernacBack _ -> true - | VernacRedirect (_, (_,c)) - | VernacTime (_,c) -> - is_navigation_vernac c (* Time Back* is harmless *) - | c -> is_deep_navigation_vernac c + | _ -> false + +let is_navigation_vernac c = + is_navigation_vernac_expr (under_control c) -and is_deep_navigation_vernac = function +let rec is_deep_navigation_vernac = function + | VernacTime (_,(_,c)) -> is_deep_navigation_vernac c + | VernacRedirect (_, (_,c)) | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c - | _ -> false + | VernacExpr _ -> false (* NB: Reset is now allowed again as asked by A. Chlipala *) let is_reset = function - | VernacResetInitial | VernacResetName _ -> true + | VernacExpr ( _, VernacResetInitial) + | VernacExpr (_, VernacResetName _) -> true | _ -> false -let is_debug cmd = match cmd with +let is_debug cmd = match under_control cmd with | VernacSetOption (["Ltac";"Debug"], _) -> true | _ -> false -let is_query cmd = match cmd with - | VernacChdir None - | VernacMemOption _ - | VernacPrintOption _ - | VernacCheckMayEval _ - | VernacGlobalCheck _ - | VernacPrint _ - | VernacSearch _ - | VernacLocate _ -> true - | _ -> false - -let is_undo cmd = match cmd with +let is_undo cmd = match under_control cmd with | VernacUndo _ | VernacUndoTo _ -> true | _ -> false diff --git a/vernac/vernacprop.mli b/vernac/vernacprop.mli index fbdba6bac..df739f96a 100644 --- a/vernac/vernacprop.mli +++ b/vernac/vernacprop.mli @@ -11,9 +11,16 @@ open Vernacexpr -val is_navigation_vernac : vernac_expr -> bool -val is_deep_navigation_vernac : vernac_expr -> bool -val is_reset : vernac_expr -> bool -val is_query : vernac_expr -> bool -val is_debug : vernac_expr -> bool -val is_undo : vernac_expr -> bool +(* Return the vernacular command below control (Time, Timeout, Redirect, Fail). + Beware that Fail can change many properties of the underlying command, since + a success of Fail means the command was backtracked over. *) +val under_control : vernac_control -> vernac_expr + +val has_Fail : vernac_control -> bool + +val is_navigation_vernac : vernac_control -> bool +val is_deep_navigation_vernac : vernac_control -> bool +val is_reset : vernac_control -> bool +val is_debug : vernac_control -> bool +val is_undo : vernac_control -> bool + diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index eb1359d52..4980333b5 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -8,22 +8,34 @@ type t = { system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) + proof : Proof_global.t; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } -let s_cache = ref (States.freeze ~marshallable:`No) -let s_proof = ref (Proof_global.freeze ~marshallable:`No) +let s_cache = ref None +let s_proof = ref None let invalidate_cache () = - s_cache := Obj.magic 0; - s_proof := Obj.magic 0 + s_cache := None; + s_proof := None + +let update_cache rf v = + rf := Some v; v + +let do_if_not_cached rf f v = + match !rf with + | None -> + rf := Some v; f v + | Some vc when vc != v -> + rf := Some v; f v + | Some _ -> + () let freeze_interp_state marshallable = - { system = (s_cache := States.freeze ~marshallable; !s_cache); - proof = (s_proof := Proof_global.freeze ~marshallable; !s_proof); + { system = update_cache s_cache (States.freeze ~marshallable); + proof = update_cache s_proof (Proof_global.freeze ~marshallable); shallow = marshallable = `Shallow } let unfreeze_interp_state { system; proof } = - if (!s_cache != system) then (s_cache := system; States.unfreeze system); - if (!s_proof != proof) then (s_proof := proof; Proof_global.unfreeze proof) + do_if_not_cached s_cache States.unfreeze system; + do_if_not_cached s_proof Proof_global.unfreeze proof diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index bcfa49aa3..3ed27ddb7 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -8,7 +8,7 @@ type t = { system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) + proof : Proof_global.t; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } |
