diff options
161 files changed, 3695 insertions, 1342 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 8dbdf43e52..bb0beb142a 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -23,6 +23,7 @@ /dev/ci/ @coq/ci-maintainers /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers +/.github/workflows @coq/ci-maintainers /azure-pipelines.yml @coq/ci-maintainers /Makefile.ci @coq/ci-maintainers @@ -33,6 +34,8 @@ # Trick to avoid getting review requests # each time someone adds an overlay +/dev/bench/ @coq/bench-maintainers + ########## Documentation ########## /README.md @coq/doc-maintainers diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index aec6cd0a21..c564105c9c 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -3,7 +3,9 @@ #### Description of the problem <!-- If you can, it's helpful to provide self-contained example of some code -that reproduces the bug. If not, a link to a larger example is also helpful. --> +that reproduces the bug. If not, a link to a larger example is also helpful. +You can generate a shorter version of your program by following these +instructions: https://github.com/coq/coq/wiki/Coqbot-minimize-feature. --> #### Coq Version diff --git a/.github/workflows/check-conflicts.yml b/.github/workflows/check-conflicts.yml new file mode 100644 index 0000000000..33ed944488 --- /dev/null +++ b/.github/workflows/check-conflicts.yml @@ -0,0 +1,13 @@ +name: "Check conflicts" +on: [push] +# Only on push because @coqbot already takes care of checking for +# conflicts when PRs are opened or synchronized + +jobs: + main: + runs-on: ubuntu-latest + steps: + - uses: eps1lon/actions-label-merge-conflict@b8bf8341285ec9a4567d4318ba474fee998a6919 + with: + dirtyLabel: "needs: rebase" + repoToken: "${{ secrets.GITHUB_TOKEN }}" diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 32b05ec746..ab06123aed 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -19,7 +19,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-07-21-V38" + CACHEKEY: "bionic_coq-V2020-08-18-V29" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -612,12 +612,6 @@ test-suite:edge:dune:dev: expire_in: 2 week allow_failure: true -test-suite:4.11+trunk+dune: - extends: .test-suite:ocaml+beta+dune-template - variables: - OCAMLVER: 4.11.0+trunk - -# Pending on https://github.com/ocaml/dune/pull/3585 # test-suite:4.12+trunk+dune: # extends: .test-suite:ocaml+beta+dune-template # variables: @@ -927,3 +921,35 @@ plugin:ci-rewriter: name: "$CI_JOB_NAME" paths: - _build_ci + +bench: + stage: stage-1 + when: manual + before_script: + - printenv -0 | sort -z | tr '\0' '\n' + script: + - . ~/.opam/opam-init/init.sh + - ./dev/bench/gitlab.sh + tags: + - timing + variables: + GIT_DEPTH: "" + coq_pr_number: "" + coq_pr_comment_id: "" + new_ocaml_switch: "ocaml-base-compiler.4.07.1" + old_ocaml_switch: "ocaml-base-compiler.4.07.1" + new_coq_repository: "https://gitlab.com/coq/coq.git" + old_coq_repository: "https://gitlab.com/coq/coq.git" + new_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + old_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + new_coq_opam_archive_git_branch: "master" + old_coq_opam_archive_git_branch: "master" + num_of_iterations: 1 + coq_opam_packages: "coq-performance-tests coq-engine-bench coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast" + artifacts: + name: "$CI_JOB_NAME" + paths: + - _bench/html/**/*.v.html + - _bench/logs + when: always + expire_in: 1 year diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index d561ec8a12..a96b93154c 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -791,10 +791,12 @@ organization, because of a limitation of GitHub). #### Additional notes for pull request reviewers and assignees #### -- NEVER USE GITHUB'S MERGE BUTTON. Instead, we provide a script - [`dev/tools/merge-pr.sh`][merge-pr] which you should use to merge a - PR (requires having configured gpg with git). In the future, we - will also support merging through a command to **@coqbot**. +- NEVER USE GITHUB'S MERGE BUTTON. Instead, you should either: + - run the [`dev/tools/merge-pr.sh`][merge-pr] script (requires + having configured gpg with git); + - or post a comment containing "@coqbot: merge now" (this is + especially convenient for developers who do not have a GPG key and + for when you do not have access to a console). - PR authors or co-authors cannot review, self-assign, or merge the PR they contributed to. However, reviewers may push small fixes to the diff --git a/default.nix b/default.nix index 6b0e396d23..df1c43101b 100644 --- a/default.nix +++ b/default.nix @@ -43,7 +43,7 @@ stdenv.mkDerivation rec { hostname python3 time # coq-makefile timing tools ] - ++ (with ocamlPackages; [ ocaml findlib num ]) + ++ (with ocamlPackages; [ ocaml findlib ]) ++ optionals buildIde [ ocamlPackages.lablgtk3-sourceview3 glib gnome3.defaultIconTheme wrapGAppsHook @@ -69,6 +69,12 @@ stdenv.mkDerivation rec { ++ [ dune_2 ] # Maybe the next build system ); + # Since #12604, ocamlfind looks for num when building plugins + # This follows a similar change in the nixpkgs repo (cf. NixOS/nixpkgs#94230) + propagatedBuildInputs = [ + ocamlPackages.num + ]; + src = if shell then null else diff --git a/dev/README.md b/dev/README.md index 0c6b8020f1..0a6b196ec0 100644 --- a/dev/README.md +++ b/dev/README.md @@ -22,14 +22,12 @@ | [`dev/doc/changes.md`](doc/changes.md) | (partial) Per-version summary of the evolution of Coq ML source | | [`dev/doc/style.txt`](doc/style.txt) | A few style recommendations for writing Coq ML files | | [`dev/doc/debugging.md`](doc/debugging.md) | Help for debugging or profiling | -| [`dev/doc/universes.txt`](doc/universes.txt) | Help for debugging universes | -| [`dev/doc/extensions.txt`](doc/extensions.txt) | Some help about TACTIC EXTEND | -| [`dev/doc/perf-analysis`](doc/perf-analysis)| Analysis of perfs measured on the compilation of user contribs | +| [`dev/doc/universes.md`](doc/universes.md) | Help for debugging universes | | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | +| [`dev/doc/parsing.md`](doc/parsing.md) | Grammar and parsing overview | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | | [`dev/doc/xml-protocol.md`](doc/xml-protocol.md) | XML protocol that coqtop and IDEs use to communicate | -| [`dev/doc/MERGING.md`](doc/MERGING.md) | How pull requests should be merged into `master` | | [`dev/doc/release-process.md`](doc/release-process.md) | Process of creating a new Coq release | diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh new file mode 100755 index 0000000000..15f5c01ac6 --- /dev/null +++ b/dev/bench/gitlab.sh @@ -0,0 +1,511 @@ +#! /usr/bin/env bash + +# ASSUMPTIONS: +# - the OPAM packages, specified by the user, are topologically sorted wrt. to the dependency relationship. +# - all the variables below are set. + +set -e + +BENCH_DEBUG=1 + +r='\033[0m' # reset (all attributes off) +b='\033[1m' # bold +u='\033[4m' # underline +nl=$'\n' + +number_of_processors=$(cat /proc/cpuinfo | grep '^processor *' | wc -l) + +program_name="$0" +program_path=$(readlink -f "${program_name%/*}") + +coqbot_url_prefix="https://coqbot.herokuapp.com/pendulum/" + +# Check that the required arguments are provided + +check_variable () { + if [ ! -v "$1" ] + then + echo "Variable $1 should be set" + exit 1 + fi +} + +echo $PWD + +#check_variable "BUILD_ID" +#check_variable "BUILD_URL" +#check_variable "JOB_NAME" +#check_variable "JENKINS_URL" +check_variable "coq_pr_number" +check_variable "coq_pr_comment_id" +check_variable "new_ocaml_switch" +check_variable "new_coq_repository" +check_variable "new_coq_opam_archive_git_uri" +check_variable "new_coq_opam_archive_git_branch" +check_variable "old_ocaml_switch" +check_variable "old_coq_repository" +check_variable "old_coq_opam_archive_git_uri" +check_variable "old_coq_opam_archive_git_branch" +check_variable "num_of_iterations" +check_variable "coq_opam_packages" + +new_coq_commit=$(git rev-parse HEAD^2) +old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) + +if which jq > /dev/null; then + : +else + echo > /dev/stderr + echo "ERROR: \"jq\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if echo "$num_of_iterations" | grep '^[1-9][0-9]*$' 2> /dev/null > /dev/null; then + : +else + echo + echo "ERROR: num_of_iterations \"$num_of_iterations\" is not a positive integer." > /dev/stderr + print_man_page_hint + exit 1 +fi + +mkdir -p "_bench" +working_dir="$PWD/_bench" + +log_dir=$working_dir/logs +mkdir "$log_dir" + +if [ ! -z "${coq_pr_number}" ]; then + github_response="$(curl "https://api.github.com/repos/coq/coq/pulls/${coq_pr_number}")" + new_coq_repository="$(echo "${github_response}" | jq -r '.head.repo.clone_url')" + new_coq_commit="$(echo "${github_response}" | jq -r '.head.sha')" + old_coq_repository="$(echo "${github_response}" | jq -r '.base.repo.clone_url')" + old_coq_commit="$(echo "${github_response}" | jq -r '.base.sha')" + coq_pr_title="$(echo "${github_response}" | jq -r '.title')" + # for coqbot parsing purposes, coq_pr_number and coq_pr_comment_id must not have newlines + coq_pr_number="$(echo "${coq_pr_number}" | tr -d '\n' | tr -d '\r')" + coq_pr_comment_id="$(echo "${coq_pr_comment_id}" | tr -d '\n' | tr -d '\r')" + + for val in "${new_coq_repository}" "${new_coq_commit}" "${old_coq_repository}" "${old_coq_commit}" "${coq_pr_title}"; do + if [ -z "$val" ] || [ "val" == "null" ]; then + echo 'ERROR: Invalid Response:' > /dev/stderr + echo "${github_response}" > /dev/stderr + echo "Info:" > /dev/stderr + curl -i "https://api.github.com/repos/coq/coq/pulls/${coq_pr_number}" > /dev/stderr + exit 1 + fi + done + + if [ -z "$BENCH_DEBUG" ]; then # if it's non-empty, this'll get + # printed later anyway. But we + # want to see it always if we're + # automatically computing values + echo "DEBUG: new_coq_repository = $new_coq_repository" + echo "DEBUG: new_coq_commit = $new_coq_commit" + echo "DEBUG: old_coq_repository = $old_coq_repository" + echo "DEBUG: old_coq_commit = $old_coq_commit" + fi + +fi + +if [ ! -z "$BENCH_DEBUG" ] +then + echo "DEBUG: ocaml -version = `ocaml -version`" + echo "DEBUG: working_dir = $working_dir" + echo "DEBUG: new_ocaml_switch = $new_ocaml_switch" + echo "DEBUG: new_coq_repository = $new_coq_repository" + echo "DEBUG: new_coq_commit = $new_coq_commit" + echo "DEBUG: new_coq_opam_archive_git_uri = $new_coq_opam_archive_git_uri" + echo "DEBUG: new_coq_opam_archive_git_branch = $new_coq_opam_archive_git_branch" + echo "DEBUG: old_ocaml_switch = $old_ocaml_switch" + echo "DEBUG: old_coq_repository = $old_coq_repository" + echo "DEBUG: old_coq_commit = $old_coq_commit" + echo "DEBUG: old_coq_opam_archive_git_uri = $old_coq_opam_archive_git_uri" + echo "DEBUG: old_coq_opam_archive_git_branch = $old_coq_opam_archive_git_branch" + echo "DEBUG: num_of_iterations = $num_of_iterations" + echo "DEBUG: coq_opam_packages = $coq_opam_packages" + echo "DEBUG: coq_pr_number = $coq_pr_number" + echo "DEBUG: coq_pr_comment_id = $coq_pr_comment_id" +fi + +# -------------------------------------------------------------------------------- + +# Some sanity checks of command-line arguments provided by the user that can be done right now. + +if which perf > /dev/null; then + echo -n +else + echo > /dev/stderr + echo "ERROR: \"perf\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if which curl > /dev/null; then + : +else + echo > /dev/stderr + echo "ERROR: \"curl\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -e "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" does not exist." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -d "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" is not a directory." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -w "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" is not writable." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +coq_opam_packages_on_separate_lines=$(echo "$coq_opam_packages" | sed 's/ /\n/g') +if [ $(echo "$coq_opam_packages_on_separate_lines" | wc -l) != $(echo "$coq_opam_packages_on_separate_lines" | sort | uniq | wc -l) ]; then + echo "ERROR: The provided set of OPAM packages contains duplicates." + exit 1 +fi + +# -------------------------------------------------------------------------------- + +# Tell coqbot to update the initial comment, if we know which one to update +function coqbot_update_comment() { + is_done="$1" + comment_body="$2" + uninstallable_packages="$3" + + if [ ! -z "${coq_pr_number}" ]; then + comment_text="" + + if [ -z "${is_done}" ]; then + comment_text="in progress, " + else + comment_text="" + fi + comment_text="Benchmarking ${comment_text}log available [here](${BUILD_URL}/console), workspace available [here](${JENKINS_URL}/view/benchmarking/job/${JOB_NAME}/ws/${BUILD_ID})" + + if [ ! -z "${comment_body}" ]; then + comment_text="${comment_text}${nl}"'```'"${nl}${comment_body}${nl}"'```' + fi + + if [ ! -z "${uninstallable_packages}" ]; then + comment_text="${comment_text}${nl}The following packages failed to install: ${uninstallable_packages}" + fi + + # if there's a comment id, we update the comment while we're + # in progress; otherwise, we wait until the end to post a new + # comment + if [ ! -z "${coq_pr_comment_id}" ]; then + # Tell coqbot to update the in-progress comment + curl -X POST --data-binary "${coq_pr_number}${nl}${coq_pr_comment_id}${nl}${comment_text}" "${coqbot_url_prefix}/update-comment" + elif [ ! -z "${is_done}" ]; then + # Tell coqbot to post a new comment that we're done benchmarking + curl -X POST --data-binary "${coq_pr_number}${nl}${comment_text}" "${coqbot_url_prefix}/new-comment" + fi + if [ ! -z "${is_done}" ]; then + # Tell coqbot to remove the `needs: benchmarking` label + curl -X POST --data-binary "${coq_pr_number}" "${coqbot_url_prefix}/benchmarking-done" + fi + fi +} + +# initial update to the comment, to say that we're in progress +coqbot_update_comment "" "" "" + +# -------------------------------------------------------------------------------- + +# Clone the indicated git-repository. + +coq_dir="$working_dir/coq" +git clone -q "$new_coq_repository" "$coq_dir" +cd "$coq_dir" +git remote rename origin new_coq_repository +git remote add old_coq_repository "$old_coq_repository" +git fetch -q "$old_coq_repository" +git checkout -q $new_coq_commit + +official_coq_branch=master +coq_opam_version=dev + +# -------------------------------------------------------------------------------- + +new_opam_root="$working_dir/opam.NEW" +old_opam_root="$working_dir/opam.OLD" + +# -------------------------------------------------------------------------------- + +old_coq_opam_archive_dir="$working_dir/old_coq_opam_archive" +git clone -q --depth 1 -b "$old_coq_opam_archive_git_branch" "$old_coq_opam_archive_git_uri" "$old_coq_opam_archive_dir" +new_coq_opam_archive_dir="$working_dir/new_coq_opam_archive" +git clone -q --depth 1 -b "$new_coq_opam_archive_git_branch" "$new_coq_opam_archive_git_uri" "$new_coq_opam_archive_dir" + +initial_opam_packages="num ocamlfind dune" + +# Create an opam root and install Coq +# $1 = root_name {ex: NEW / OLD} +# $2 = compiler name +# $3 = git hash of Coq to be installed +# $4 = directory of coq opam archive +create_opam() { + + local RUNNER="$1" + local OPAM_DIR="$working_dir/opam.$RUNNER" + local OPAM_COMP="$2" + local COQ_HASH="$3" + local OPAM_COQ_DIR="$4" + + export OPAMROOT="$OPAM_DIR" + + opam init --disable-sandboxing -qn -j$number_of_processors --bare + # Allow beta compiler switches + opam repo add -q --set-default beta https://github.com/ocaml/ocaml-beta-repository.git + # Allow experimental compiler switches + opam repo add -q --set-default ocaml-pr https://github.com/ejgallego/ocaml-pr-repository.git + # Rest of default switches + opam repo add -q --set-default iris-dev "https://gitlab.mpi-sws.org/FP/opam-dev.git" + + opam switch create -qy -j$number_of_processors "$OPAM_COMP" + eval $(opam env) + + # For some reason opam guesses an incorrect upper bound on the + # number of jobs available on Travis, so we set it here manually: + opam config set-global jobs $number_of_processors + if [ ! -z "$BENCH_DEBUG" ]; then opam config list; fi + + opam repo add -q --this-switch coq-extra-dev "$OPAM_COQ_DIR/extra-dev" + opam repo add -q --this-switch coq-released "$OPAM_COQ_DIR/released" + + opam install -qy -j$number_of_processors $initial_opam_packages + if [ ! -z "$BENCH_DEBUG" ]; then opam repo list; fi + + cd "$coq_dir" + if [ ! -z "$BENCH_DEBUG" ]; then echo "DEBUG: $1_coq_commit = $COQ_HASH"; fi + + git checkout -q $COQ_HASH + COQ_HASH_LONG=$(git log --pretty=%H | head -n 1) + + echo "$1_coq_commit_long = $COQ_HASH_LONG" + + _RES=0 + /usr/bin/time -o "$log_dir/coq.$RUNNER.1.time" --format="%U %M %F" \ + perf stat -e instructions:u,cycles:u -o "$log_dir/coq.$RUNNER.1.perf" \ + opam pin add -y -b -j "$number_of_processors" --kind=path coq.dev . \ + 3>$log_dir/coq.$RUNNER.opam_install.1.stdout 1>&3 \ + 4>$log_dir/coq.$RUNNER.opam_install.1.stderr 2>&4 || \ + _RES=$? + if [ $_RES = 0 ]; then + echo "Coq ($RUNNER) installed successfully" + else + echo "ERROR: \"opam install coq.$coq_opam_version\" has failed (for the $RUNNER commit = $COQ_HASH_LONG)." + exit 1 + fi + + # we don't multi compile coq for now (TODO some other time) + # the render needs all the files so copy them around + for it in $(seq 2 $num_of_iterations); do + cp "$log_dir/coq.$RUNNER.1.time" "$log_dir/coq.$RUNNER.$it.time" + cp "$log_dir/coq.$RUNNER.1.perf" "$log_dir/coq.$RUNNER.$it.perf" + done + +} + +# Create an OPAM-root to which we will install the NEW version of Coq. +create_opam "NEW" "$new_ocaml_switch" "$new_coq_commit" "$new_coq_opam_archive_dir" +new_coq_commit_long="$COQ_HASH_LONG" + +# Create an OPAM-root to which we will install the OLD version of Coq. +create_opam "OLD" "$old_ocaml_switch" "$old_coq_commit" "$old_coq_opam_archive_dir" +old_coq_commit_long="$COQ_HASH_LONG" +# -------------------------------------------------------------------------------- +# Measure the compilation times of the specified OPAM packages in both switches + +# Sort the opam packages +sorted_coq_opam_packages=$("${program_path}/sort-by-deps.sh" ${coq_opam_packages}) +if [ ! -z "$BENCH_DEBUG" ] +then + echo "DEBUG: sorted_coq_opam_packages = ${sorted_coq_opam_packages}" +fi + +# Generate per line timing info in devs that use coq_makefile +export TIMING=1 + +# The following variable will be set in the following cycle: +installable_coq_opam_packages=coq + +for coq_opam_package in $sorted_coq_opam_packages; do + + if [ ! -z "$BENCH_DEBUG" ]; then + opam list + echo "DEBUG: coq_opam_package = $coq_opam_package" + opam show $coq_opam_package || continue 2 + else + # cause to skip with error if unknown package + opam show $coq_opam_package >/dev/null || continue 2 + fi + + for RUNNER in NEW OLD; do + + # perform measurements for the NEW/OLD commit (provided by the user) + if [ $RUNNER = "NEW" ]; then + export OPAMROOT="$new_opam_root" + echo "Testing NEW commit: $(date)" + else + export OPAMROOT="$old_opam_root" + echo "Testing OLD commit: $(date)" + fi + + eval $(opam env) + + # If a given OPAM-package was already installed (as a + # dependency of some OPAM-package that we have benchmarked + # before), remove it. + opam uninstall -q $coq_opam_package + + # OPAM 2.0 likes to ignore the -j when it feels like :S so we + # workaround that here. + opam config set-global jobs $number_of_processors + + opam install $coq_opam_package -v -b -j$number_of_processors --deps-only -y \ + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stdout 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stderr 2>&4 || continue 2 + + opam config set-global jobs 1 + + if [ ! -z "$BENCH_DEBUG" ]; then ls -l $working_dir; fi + + for iteration in $(seq $num_of_iterations); do + _RES=0 + /usr/bin/time -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.time" --format="%U %M %F" \ + perf stat -e instructions:u,cycles:u -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.perf" \ + opam install -v -b -j1 $coq_opam_package \ + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stdout 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stderr 2>&4 || \ + _RES=$? + if [ $_RES = 0 ]; + then + echo $_RES > $log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.exit_status + # "opam install" was successful. + + # Remove the benchmarked OPAM-package, unless this is the + # very last iteration (we want to keep this OPAM-package + # because other OPAM-packages we will benchmark later + # might depend on it --- it would be a waste of time to + # remove it now just to install it later) + if [ $iteration != $num_of_iterations ]; then + opam uninstall -q $coq_opam_package + fi + else + # "opam install" failed. + echo $_RES > $log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.exit_status + continue 3 + fi + done + done + + installable_coq_opam_packages="$installable_coq_opam_packages $coq_opam_package" + + # -------------------------------------------------------------- + + # Print the intermediate results after we finish benchmarking each OPAM package + if [ "$coq_opam_package" = "$(echo $sorted_coq_opam_packages | sed 's/ /\n/g' | tail -n 1)" ]; then + + # It does not make sense to print the intermediate results when + # we finished bechmarking the very last OPAM package because the + # next thing will do is that we will print the final results. + # It would look lame to print the same table twice. + : + else + + echo "DEBUG: $program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages" + if [ ! -z "$BENCH_DEBUG" ]; then + cat $log_dir/$coq_opam_package.$RUNNER.1.time || true + cat $log_dir/$coq_opam_package.$RUNNER.1.perf || true + fi + rendered_results="$($program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages)" + echo "${rendered_results}" + # update the comment + coqbot_update_comment "" "${rendered_results}" "" + fi + + # Generate HTML report for LAST run + + # N.B. Not all packages end in .dev, e.g., coq-lambda-rust uses .dev.timestamp. + # So we use a wildcard to catch such packages. This will have to be updated if + # ever there is a package that uses some different naming scheme. + new_base_path=$new_ocaml_switch/.opam-switch/build/$coq_opam_package.dev*/ + old_base_path=$old_ocaml_switch/.opam-switch/build/$coq_opam_package.dev*/ + for vo in `cd $new_opam_root/$new_base_path/; find -name '*.vo'`; do + if [ -e $old_opam_root/$old_base_path/${vo%%o}.timing -a \ + -e $new_opam_root/$new_base_path/${vo%%o}.timing ]; then + mkdir -p $working_dir/html/$coq_opam_package/`dirname $vo`/ + $program_path/timelog2html $new_opam_root/$new_base_path/${vo%%o} \ + $old_opam_root/$old_base_path/${vo%%o}.timing \ + $new_opam_root/$new_base_path/${vo%%o}.timing > \ + $working_dir/html/$coq_opam_package/${vo%%o}.html + fi + done +done + +# The following directories in $working_dir are no longer used: +# +# - coq, opam.OLD, opam.NEW + +# Measured data for each `$coq_opam_package`, `$iteration`, `status \in {NEW,OLD}`: +# +# - $working_dir/$coq_opam_package.$status.$iteration.time +# => output of /usr/bin/time --format="%U" ... +# +# - $working_dir/$coq_opam_package.NEW.$iteration.perf +# => output of perf stat -e instructions:u,cycles:u ... +# +# The next script processes all these files and prints results in a table. + +echo "INFO: workspace = https://ci.inria.fr/coq/view/benchmarking/job/$JOB_NAME/ws/$BUILD_ID" + +# Print the final results. +if [ -z "$installable_coq_opam_packages" ]; then + # Tell the user that none of the OPAM-package(s) the user provided + # /are installable. + printf "\n\nINFO: failed to install: $sorted_coq_opam_packages" + coqbot_update_comment "done" "" "$sorted_coq_opam_packages" + exit 1 +else + echo "DEBUG: $program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages" + rendered_results="$($program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages)" + echo "${rendered_results}" + + echo "INFO: per line timing: https://ci.inria.fr/coq/job/$JOB_NAME/ws/$BUILD_ID/html/" + + cd "$coq_dir" + echo INFO: Old Coq version + git log -n 1 "$old_coq_commit" + echo INFO: New Coq version + git log -n 1 "$new_coq_commit" + + not_installable_coq_opam_packages=`comm -23 <(echo $sorted_coq_opam_packages | sed 's/ /\n/g' | sort | uniq) <(echo $installable_coq_opam_packages | sed 's/ /\n/g' | sort | uniq) | sed 's/\t//g'` + + coqbot_update_comment "done" "${rendered_results}" "${not_installable_coq_opam_packages}" + + exit_code=0 + + if [ ! -z "$not_installable_coq_opam_packages" ]; then + # Tell the user that some of the provided OPAM-package(s) + # is/are not installable. + printf '\n\nINFO: failed to install %s\n' "$not_installable_coq_opam_packages" + exit_code=1 + fi + + exit 0 +fi diff --git a/dev/bench/render_results b/dev/bench/render_results new file mode 100755 index 0000000000..72affd70b2 --- /dev/null +++ b/dev/bench/render_results @@ -0,0 +1,434 @@ +#! /usr/bin/env ocaml + +(* ASSUMPTIONS: + - the 1-st command line argument (working directory): + - designates an existing readable directory + - which contains *.time and *.perf files produced by bench.sh script + - the 2-nd command line argument (number of iterations): + - is a positive integer + - the 3-rd command line argument (minimal user time): + - is a positive floating point number + - the 4-th command line argument determines the name of the column according to which the resulting table will be sorted. + Valid values are: + - package_name + - user_time_pdiff + - the rest of the command line-arguments + - are names of benchamarked Coq OPAM packages for which bench.sh script generated *.time and *.perf files + *) + +#use "topfind";; +#require "unix";; +#print_depth 100000000;; +#print_length 100000000;; + +open Printf +open Unix +;; + +let _ = Printexc.record_backtrace true +;; + +type ('a,'b) pkg_timings = { + user_time : 'a; + num_instr : 'b; + num_cycles : 'b; + num_mem : 'b; + num_faults : 'b; +} +;; + +let reduce_pkg_timings (m_f : 'a list -> 'c) (m_a : 'b list -> 'd) (t : ('a,'b) pkg_timings list) : ('c,'d) pkg_timings = + { user_time = m_f @@ List.map (fun x -> x.user_time) t + ; num_instr = m_a @@ List.map (fun x -> x.num_instr) t + ; num_cycles = m_a @@ List.map (fun x -> x.num_cycles) t + ; num_mem = m_a @@ List.map (fun x -> x.num_mem) t + ; num_faults = m_a @@ List.map (fun x -> x.num_faults) t + } +;; + +(******************************************************************************) +(* BEGIN Copied from batteries, to remove *) +(******************************************************************************) +let run_and_read cmd = + (* This code is before the open of BatInnerIO + to avoid using batteries' wrapped IOs *) + let string_of_file fn = + let buff_size = 1024 in + let buff = Buffer.create buff_size in + let ic = open_in fn in + let line_buff = Bytes.create buff_size in + begin + let was_read = ref (input ic line_buff 0 buff_size) in + while !was_read <> 0 do + Buffer.add_subbytes buff line_buff 0 !was_read; + was_read := input ic line_buff 0 buff_size; + done; + close_in ic; + end; + Buffer.contents buff + in + let tmp_fn = Filename.temp_file "" "" in + let cmd_to_run = cmd ^ " > " ^ tmp_fn in + let status = Unix.system cmd_to_run in + let output = string_of_file tmp_fn in + Unix.unlink tmp_fn; + (status, output) +;; + +let ( %> ) f g x = g (f x) +;; + +let run = run_and_read %> snd +;; + +module Float = struct + let nan = Pervasives.nan +end + +module Tuple4 = struct + + let first (x,_,_,_) = x + let second (_,y,_,_) = y + let third (_,_,z,_) = z + let fourth (_,_,_,z) = z + +end +;; + +module List = struct + include List + + let rec init_tailrec_aux acc i n f = + if i >= n then acc + else init_tailrec_aux (f i :: acc) (i+1) n f + + let rec init_aux i n f = + if i >= n then [] + else + let r = f i in + r :: init_aux (i+1) n f + + let rev_init_threshold = + match Sys.backend_type with + | Sys.Native | Sys.Bytecode -> 10_000 + (* We don't known the size of the stack, better be safe and assume it's small. *) + | Sys.Other _ -> 50 + + let init len f = + if len < 0 then invalid_arg "List.init" else + if len > rev_init_threshold then rev (init_tailrec_aux [] 0 len f) + else init_aux 0 len f + + let rec drop n = function + | _ :: l when n > 0 -> drop (n-1) l + | l -> l + + let reduce f = function + | [] -> + invalid_arg "List.reduce: Empty List" + | h :: t -> + fold_left f h t + + let min l = reduce Pervasives.min l + let max l = reduce Pervasives.max l + +end +;; + +module String = struct + + include String + + let rchop ?(n = 1) s = + if n < 0 then + invalid_arg "String.rchop: number of characters to chop is negative" + else + let slen = length s in + if slen <= n then "" else sub s 0 (slen - n) + +end +;; + +(******************************************************************************) +(* END Copied from batteries, to remove *) +(******************************************************************************) + +let mk_pkg_timings work_dir pkg_name suffix iteration = + let command_prefix = "cat " ^ work_dir ^ "/" ^ pkg_name ^ suffix ^ string_of_int iteration in + let time_command_output = command_prefix ^ ".time" |> run |> String.rchop ~n:1 |> String.split_on_char ' ' in + + let nth x i = List.nth i x in + + { user_time = time_command_output |> nth 0 |> float_of_string + (* Perf can indeed be not supported in some systems, so we must fail gracefully *) + ; num_instr = + (try command_prefix ^ ".perf | grep instructions:u | awk '{print $1}' | sed 's/,//g'" |> + run |> String.rchop ~n:1 |> int_of_string + with Failure _ -> 0) + ; num_cycles = + (try command_prefix ^ ".perf | grep cycles:u | awk '{print $1}' | sed 's/,//g'" |> + run |> String.rchop ~n:1 |> int_of_string + with Failure _ -> 0) + ; num_mem = time_command_output |> nth 1 |> int_of_string + ; num_faults = time_command_output |> nth 2 |> int_of_string + } +;; + +(* process command line paramters *) +assert (Array.length Sys.argv > 5); +let work_dir = Sys.argv.(1) in +let num_of_iterations = int_of_string Sys.argv.(2) in +let new_coq_version = Sys.argv.(3) in +let old_coq_version = Sys.argv.(4) in +let minimal_user_time = float_of_string Sys.argv.(5) in +let sorting_column = Sys.argv.(6) in +let coq_opam_packages = Sys.argv |> Array.to_list |> List.drop 7 in + +(* ASSUMPTIONS: + + "working_dir" contains all the files produced by the following command: + + two_points_on_the_same_branch.sh $working_directory $coq_repository $coq_branch[:$new:$old] $num_of_iterations coq_opam_package_1 coq_opam_package_2 ... coq_opam_package_N +-sf +*) + +(* Run a given bash command; + wait until it termines; + check if its exit status is 0; + return its whole stdout as a string. *) + +let proportional_difference_of_integers new_value old_value = + if old_value = 0 + then Float.nan + else float_of_int (new_value - old_value) /. float_of_int old_value *. 100.0 +in + +let count_number_of_digits_before_decimal_point = + log10 %> floor %> int_of_float %> succ %> max 1 +in + +(* parse the *.time and *.perf files *) +coq_opam_packages +|> List.map + (fun package_name -> + package_name,(* compilation_results_for_NEW : (float * int * int * int) list *) + List.init num_of_iterations succ |> List.map (mk_pkg_timings work_dir package_name ".NEW."), + List.init num_of_iterations succ |> List.map (mk_pkg_timings work_dir package_name ".OLD.")) + +(* from the list of measured values, select just the minimal ones *) + +|> List.map + (fun ((package_name : string), + (new_measurements : (float, int) pkg_timings list), + (old_measurements : (float, int) pkg_timings list)) -> + let f_min : float list -> float = List.min in + let i_min : int list -> int = List.min in + package_name, + reduce_pkg_timings f_min i_min new_measurements, + reduce_pkg_timings f_min i_min old_measurements + ) + +(* compute the "proportional differences in % of the NEW measurement and the OLD measurement" of all measured values *) +|> List.map + (fun (package_name, new_t, old_t) -> + package_name, new_t, old_t, + { user_time = (new_t.user_time -. old_t.user_time) /. old_t.user_time *. 100.0 + ; num_instr = proportional_difference_of_integers new_t.num_instr old_t.num_instr + ; num_cycles = proportional_difference_of_integers new_t.num_cycles old_t.num_cycles + ; num_mem = proportional_difference_of_integers new_t.num_mem old_t.num_mem + ; num_faults = proportional_difference_of_integers new_t.num_faults old_t.num_faults + }) + +(* sort the table with results *) +|> List.sort + (match sorting_column with + | "user_time_pdiff" -> + fun (_,_,_,perf1) (_,_,_,perf2) -> + compare perf1.user_time perf2.user_time + | "package_name" -> + fun (n1,_,_,_) (n2,_,_,_) -> compare n1 n2 + | _ -> + assert false + ) + +(* Keep only measurements that took at least "minimal_user_time" (in seconds). *) + +|> List.filter + (fun (_, new_t, old_t, _) -> + minimal_user_time <= new_t.user_time && minimal_user_time <= old_t.user_time) + +(* Below we take the measurements and format them to stdout. *) + +|> fun measurements -> + + let precision = 2 in + + (* the labels that we will print *) + let package_name__label = "package_name" in + let new__label = "NEW" in + let old__label = "OLD" in + let proportional_difference__label = "PDIFF" in + + (* the lengths of labels that we will print *) + let new__label__length = String.length new__label in + let proportional_difference__label__length = String.length proportional_difference__label in + + (* widths of individual columns of the table *) + let package_name__width = + max (measurements |> List.map (Tuple4.first %> String.length) |> List.max) + (String.length package_name__label) in + + let llf proj = + let lls = count_number_of_digits_before_decimal_point (List.max proj) + 1 + precision in + max lls new__label__length in + + let lli proj = + let lls = count_number_of_digits_before_decimal_point (float_of_int (List.(max proj))) + 1 + precision in + max lls new__label__length in + + let new_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.second measurements in + let old_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.third measurements in + + let llp proj = + let lls = + count_number_of_digits_before_decimal_point List.(max List.(map abs_float proj)) + 2 + precision in + max lls proportional_difference__label__length in + + let perc_timing_width = reduce_pkg_timings llp llp @@ List.map Tuple4.fourth measurements in + + (* print the table *) + let rec make_dashes = function + | 0 -> "" + | count -> "─" ^ make_dashes (pred count) + in + + let vertical_separator left_glyph middle_glyph right_glyph = + sprintf "%s─%s─%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s\n" + left_glyph + (make_dashes package_name__width) + middle_glyph + (make_dashes new_timing_width.user_time) + (make_dashes old_timing_width.user_time) + (make_dashes perc_timing_width.user_time) + middle_glyph + (make_dashes new_timing_width.num_cycles) + (make_dashes old_timing_width.num_cycles) + (make_dashes perc_timing_width.num_cycles) + middle_glyph + (make_dashes new_timing_width.num_instr) + (make_dashes old_timing_width.num_instr) + (make_dashes perc_timing_width.num_instr) + middle_glyph + (make_dashes new_timing_width.num_mem) + (make_dashes old_timing_width.num_mem) + (make_dashes perc_timing_width.num_mem) + middle_glyph + (make_dashes new_timing_width.num_faults) + (make_dashes old_timing_width.num_faults) + (make_dashes perc_timing_width.num_faults) + right_glyph + in + + let center_string string width = + let string_length = String.length string in + let width = max width string_length in + let left_hfill = (width - string_length) / 2 in + let right_hfill = width - left_hfill - string_length in + String.make left_hfill ' ' ^ string ^ String.make right_hfill ' ' + in + printf "\n"; + print_string (vertical_separator "┌" "┬" "┐"); + "│" ^ String.make (1 + package_name__width + 1) ' ' ^ "│" + ^ center_string "user time [s]" (1 + new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) ^ "│" + ^ center_string "CPU cycles" (1 + new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) ^ "│" + ^ center_string "CPU instructions" (1 + new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) ^ "│" + ^ center_string "max resident mem [KB]" (1 + new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) ^ "│" + ^ center_string "mem faults" (1 + new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) + ^ "│\n" |> print_string; + printf "│%*s │ %*s│ %*s│ %*s│ %*s│ %*s│\n" + (1 + package_name__width) "" + (new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) "" + (new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) "" + (new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) "" + (new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) "" + (new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) ""; + printf "│ %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │\n" + package_name__width package_name__label + new_timing_width.user_time new__label + old_timing_width.user_time old__label + perc_timing_width.user_time proportional_difference__label + new_timing_width.num_cycles new__label + old_timing_width.num_cycles old__label + perc_timing_width.num_cycles proportional_difference__label + new_timing_width.num_instr new__label + old_timing_width.num_instr old__label + perc_timing_width.num_instr proportional_difference__label + new_timing_width.num_mem new__label + old_timing_width.num_mem old__label + perc_timing_width.num_mem proportional_difference__label + new_timing_width.num_faults new__label + old_timing_width.num_faults old__label + perc_timing_width.num_faults proportional_difference__label; + measurements |> List.iter + (fun (package_name, new_t, old_t, perc) -> + print_string (vertical_separator "├" "┼" "┤"); + printf "│ %*s │ %*.*f %*.*f %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │\n" + package_name__width package_name + new_timing_width.user_time precision new_t.user_time + old_timing_width.user_time precision old_t.user_time + perc_timing_width.user_time precision perc.user_time + new_timing_width.num_cycles new_t.num_cycles + old_timing_width.num_cycles old_t.num_cycles + perc_timing_width.num_cycles precision perc.num_cycles + new_timing_width.num_instr new_t.num_instr + old_timing_width.num_instr old_t.num_instr + perc_timing_width.num_instr precision perc.num_instr + new_timing_width.num_mem new_t.num_mem + old_timing_width.num_mem old_t.num_mem + perc_timing_width.num_mem precision perc.num_mem + new_timing_width.num_faults new_t.num_faults + old_timing_width.num_faults old_t.num_faults + perc_timing_width.num_faults precision perc.num_faults); + +print_string (vertical_separator "└" "┴" "┘"); + +(* ejgallego: disable this as it is very verbose and brings up little info in the log. *) +if false then begin +printf " + +PDIFF = proportional difference between measurements done for the NEW and the OLD Coq version + = (NEW_measurement - OLD_measurement) / OLD_measurement * 100%% + +NEW = %s +OLD = %s + +Columns: + + 1. user time [s] + + Total number of CPU-seconds that the process used directly (in user mode), in seconds. + (In other words, \"%%U\" quantity provided by the \"/usr/bin/time\" command.) + + 2. CPU cycles + + Total number of CPU-cycles that the process used directly (in user mode). + (In other words, \"cycles:u\" quantity provided by the \"/usr/bin/perf\" command.) + + 3. CPU instructions + + Total number of CPU-instructions that the process used directly (in user mode). + (In other words, \"instructions:u\" quantity provided by the \"/usr/bin/perf\" command.) + + 4. max resident mem [KB] + + Maximum resident set size of the process during its lifetime, in Kilobytes. + (In other words, \"%%M\" quantity provided by the \"/usr/bin/time\" command.) + + 5. mem faults + + Number of major, or I/O-requiring, page faults that occurred while the process was running. + These are faults where the page has actually migrated out of primary memory. + (In other words, \"%%F\" quantity provided by the \"/usr/bin/time\" command.) + +" new_coq_version old_coq_version; +end diff --git a/dev/bench/sort-by-deps b/dev/bench/sort-by-deps new file mode 100644 index 0000000000..e1da4e0ed5 --- /dev/null +++ b/dev/bench/sort-by-deps @@ -0,0 +1,33 @@ +#!/usr/bin/env ocaml + +let get_pkg_name arg = + List.nth (String.split_on_char ':' arg) 0 + +let get_pkg_deps arg = + String.split_on_char ',' (List.nth (String.split_on_char ':' arg) 1) + +let split_pkg arg = get_pkg_name arg, get_pkg_deps arg + +let depends_on arg1 arg2 = + let pkg1, deps1 = split_pkg arg1 in + let pkg2, deps2 = split_pkg arg2 in + pkg1 != pkg2 && List.mem pkg2 deps1 + +let rec sort = function + | [], [] -> [] + | [], deferred -> sort (List.rev deferred, []) + | arg :: rest, deferred -> + (* check if any remaining package reverse-depends on this one *) + if List.exists (fun other_arg -> depends_on arg other_arg) rest + then (* defer this package *) + sort (rest, arg :: deferred) + else (* emit this package, and then try again with any deferred packages *) + arg :: sort (List.rev deferred @ rest, []) + +let main () = + let args = Array.to_list Sys.argv in + let pkgs = List.tl args in + let sorted_pkgs = sort (pkgs, []) in + Printf.printf "%s\n%!" (String.concat " " (List.map get_pkg_name sorted_pkgs)) + +let () = main () diff --git a/dev/bench/sort-by-deps.sh b/dev/bench/sort-by-deps.sh new file mode 100755 index 0000000000..075976c17d --- /dev/null +++ b/dev/bench/sort-by-deps.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +program_name="$0" +program_path=$(readlink -f "${program_name%/*}") + +# We add || true (which may not be needed without set -e) to be +# explicit about the fact that this script does not fail even if `opam +# install --show-actions` does, e.g., because of a non-existent +# package +# +# TODO: Figure out how to use the OPAM API +# (https://opam.ocaml.org/doc/api/) to call this from OCaml. +for i in "$@"; do + echo -n "$i:"; ((echo -n "$(opam install --show-actions "$i" | grep -o '∗\s*install\s*[^ ]*' | sed 's/∗\s*install\s*//g')" | tr '\n' ',') || true); echo +done | xargs ocaml "${program_path}/sort-by-deps" diff --git a/dev/bench/timelog2html b/dev/bench/timelog2html new file mode 100755 index 0000000000..abbeb5936d --- /dev/null +++ b/dev/bench/timelog2html @@ -0,0 +1,141 @@ +#!/usr/bin/env lua5.1 + +args = {...} + +vfile = assert(args[1], "arg1 missing: .v file") +table.remove(args,1) +assert(#args > 0, "arg missing: at lease one aux file") +data_files = args + +source = assert(io.open(vfile), "unable to open "..vfile):read("*a") + +function htmlescape(s) + return (s:gsub("&","&"):gsub("<","<"):gsub(">",">")) +end + +colors = { + '#F08080', '#EEE8AA', '#98FB98' +} + +assert(#data_files <= #colors, "only ".. #colors .." data files are supported") + +vname = vfile:match("([^/]+.v)$") + +print([[ +<html> +<head> +<title>]]..vname..[[</title> +<style>]]) +for i,k in ipairs(colors) do + print( + ".time" .. i .. " {".. + "background-color: " .. k .. ";".. + "height: ".. 100 / #data_files .."%;".. + "top: " .. 100 / #data_files * (i - 1) .. "%;".. + "z-index: -1; position: absolute; opacity: 50%; }") +end +print([[.code { + z-index: 0; + position: relative; + border-style: solid; + border-color: transparent; + border-width: 1px; +} +.code:hover { + border-color: black; +} +pre { + display: inline; +} +</style> +</head> +<body> +<h1>Timings for ]]..vname..[[</h1> +<ol> +]]) +for i,data_file in ipairs(data_files) do + print('<li style="background-color: '..colors[i]..'">' .. data_file .. "</li>") +end +print("</ol>") + +all_data = {} + +for _, data_file in ipairs(data_files) do + local data = {} + local last_end = -1 + local lines = 1 + for l in io.lines(data_file) do + local b,e,t = l:match('^Chars ([%d]+) %- ([%d]+) %S+ ([%d%.]+) secs') + if b then + if tonumber(b) > last_end + 1 then + local text = string.sub(source,last_end+1,b-1) + if not text:match('^%s+$') then + local _, n = text:gsub('\n','') + data[#data+1] = { + start = last_end+1; stop = b-1; time = 0; + text = text; lines = lines + } + lines = lines + n + last_end = b + end + end + local text = string.sub(source,last_end+1,e) + local _, n = text:gsub('\n','') + local _, eoln = text:match('^[%s\n]*'):gsub('\n','') + data[#data+1] = { + start = b; stop = e; time = tonumber(t); text = text; + lines = lines + } + lines = lines + n + last_end = tonumber(e) + end + end + if last_end + 1 <= string.len(source) then + local text = string.sub(source,last_end+1,string.len(source)) + data[#data+1] = { + start = last_end+1; stop = string.len(source); time = 0; + text = text; lines = lines+1 + } + end +all_data[#all_data+1] = data +end + +max = 0; +for _, data in ipairs(all_data) do + for _,d in ipairs(data) do + max = math.max(max,d.time) + end +end + +data = all_data[1] +for j,d in ipairs(data) do + print('<div class="code" title="File: '..vname.. + '\nLine: '..d.lines..'\n') + for k=1,#all_data do + print('Time'..k..': '..all_data[k][j].time..'s') + end + print('">') + for k=1,#all_data do + print('<div class="time'..k..'" style="width: '.. + all_data[k][j].time * 100 / max ..'%"></div>') + end + if d.text == '\n' then + print('<pre>\n\n</pre>') + elseif d.text:match('\n$') then + print('<pre>'..htmlescape(d.text)..'\n</pre>') + else + print('<pre>'..htmlescape(d.text)..'</pre>') + end + print("</div>") +end + +print [[ +</body> +</html> +]] + +-- vim: set ts=4: + +--for i = 1,#data do +-- io.stderr:write(data[i].text) +--end diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 577ce35aae..fd6ea9bb09 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -55,7 +55,7 @@ IF DEFINED HTTP_PROXY ( )
REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
+SET CYGWIN_REPOSITORY=https://mirrors.kernel.org/sourceware/cygwin
REM see -cygcache in ReadMe.txt
SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
diff --git a/dev/ci/ci-coqtail.sh b/dev/ci/ci-coqtail.sh index b8b5c6c724..ab538ecc07 100755 --- a/dev/ci/ci-coqtail.sh +++ b/dev/ci/ci-coqtail.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download coqtail -( cd "${CI_BUILD_DIR}/coqtail" && PYTHONPATH=python python3 -m pytest tests/test_coqtop.py ) +( cd "${CI_BUILD_DIR}/coqtail" && PYTHONPATH=python python3 -m pytest tests/coq ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 1302065961..27876d68de 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download metacoq -( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make ci-local && make install ) +( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make .merlin && make ci-local && make install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 7570b17095..67a8415891 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-07-21-V38" +# CACHEKEY: "bionic_coq-V2020-08-18-V29" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -38,7 +38,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.1 ounit.2.2.2 odoc.1.5.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.11.0" diff --git a/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh b/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh new file mode 100644 index 0000000000..7c04608403 --- /dev/null +++ b/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12565" ] || [ "$CI_BRANCH" = "fix-tc-search-opacity" ]; then + + coqhammer_CI_REF=fix-tc-search-opacity + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh b/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh new file mode 100644 index 0000000000..56a69abbf7 --- /dev/null +++ b/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12709" ] || [ "$CI_BRANCH" = "hint-pattern-out" ]; then + + coqhammer_CI_REF=hint-pattern-out + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh b/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh new file mode 100644 index 0000000000..e57f95ef19 --- /dev/null +++ b/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12720" ] || [ "$CI_BRANCH" = "factor-class-hint-clenv" ]; then + + coqhammer_CI_REF=factor-class-hint-clenv + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh b/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh new file mode 100644 index 0000000000..54fdd87566 --- /dev/null +++ b/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "12756" ] || [ "$CI_BRANCH" = "dont-refresh-argument-names" ]; then + + mathcomp_CI_REF=dont-refresh-argument-names-overlay + mathcomp_CI_GITURL=https://github.com/jashug/math-comp + + oddorder_CI_REF=dont-refresh-argument-names-overlay + oddorder_CI_GITURL=https://github.com/jashug/odd-order + +fi diff --git a/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh b/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh new file mode 100644 index 0000000000..6a9cf78687 --- /dev/null +++ b/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh @@ -0,0 +1,8 @@ +if [ "$CI_PULL_REQUEST" = "12801" ] || [ "$CI_BRANCH" = "CyclicSet" ]; then + + bignums_CI_REF=CyclicSet + bignums_CI_GITURL=https://github.com/VincentSe/bignums + + coqprime_CI_REF=CyclicSet + coqprime_CI_GITURL=https://github.com/VincentSe/coqprime +fi diff --git a/dev/doc/parsing.md b/dev/doc/parsing.md new file mode 100644 index 0000000000..f8b4537e77 --- /dev/null +++ b/dev/doc/parsing.md @@ -0,0 +1,397 @@ +# Parsing + +Coq's parser is based on Camlp5 using an extensible grammar. Somewhat helpful +Camlp5 documentation is available [here](http://camlp5.github.io/doc/htmlc/grammars.html). +However, the Camlp5 code has been copied into the Coq source tree and may differ +from the Camlp5 release. + +Notable attributes of the parser include: + +* The grammar is extensible at run time. This is essential for supporting notations + and optionally-loaded plugins that extend the grammar. + +* The grammar is split into multiple source files. Nonterminals can be local to a file + or global. + +* While 95% of the nonterminals and almost all the productions are defined in the grammar, + a few are defined directly in OCaml code. Since many developers have worked on the parser + over the years, this code can be idiosyncratic, reflecting various coding styles. + +* The parser is a recursive descent parser that, by default, only looks at the next token + to make a parsing decision. It's possible to hand-code additional lookahead where + necessary by writing OCaml code. + +* There's no code that checks whether a grammar is ambiguous or whether every production + can be recognized. Developers who modify the grammar may, in some cases, need to structure their + added productions in specific ways to ensure that their additions are parsable and that they + don't break existing productions. + +## Contents ## + +- [Grammars: `*.mlg` File Structure](#grammars-mlg-file-structure) +- [Grammars: Nonterminals and Productions](#grammars-nonterminals-and-productions) + - [Alternate production syntax](#alternate-production-syntax) +- [Usage notes](#usage-notes) + - [Other components](#other-components) + - [Parsing productions](#parsing-productions) + - [Lookahead](#lookahead) + +## Grammars: `*.mlg` File Structure ## + +Grammars are defined in `*.mlg` files, which `coqpp` compiles into `*.ml` files at build time. +`coqpp` code is in the `coqpp` directory. `coqpp` uses yacc and lex to parse the grammar files. +You can examine its yacc and lex input files in `coqpp_lex.mll` and `coqpp_parse.mly` for +details not fully covered here. + +In addition, there is a `doc_grammar` build utility that uses the `coqpp` parser to extract the +grammar, then edits and inserts it into the documentation. This is described in +[`doc/tools/docgram/README.md`](../../doc/tools/docgram/README.md). +`doc_grammar` generates +[`doc/tools/docgram/fullGrammar`](../../doc/tools/docgram/fullGrammar), +which has the full grammar for Coq +(not including some optionally-loaded plugins). This may be easier to read since everything is +in one file and the parser action routines and other OCaml code are omitted. + +`*.mlg` files contain the following types of nodes (See `node` in the yacc grammar). This part is +very specific to Coq (not so similar to Camlp5): + +* OCaml code - OCaml code enclosed in curly braces, which is copied verbatim to the generated `*.ml` file + +* Comments - comments in the `*.mlg` file in the form `(* … *)`, which are not copied + to the generated `*.ml` file. Comments in OCaml code are preserved. + +* `DECLARE_PLUGIN "*_plugin"` - associates the file with a specific plugin, for example "ltac_plugin" + +* `GRAMMAR EXTEND` - adds additional nonterminals and productions to the grammar and declares global + nonterminals referenced in the `GRAMMAR EXTEND`: + + ``` + GRAMMAR EXTEND Gram + GLOBAL: + bignat bigint …; + <nonterminal definitions> + END + ``` + + Global nonterminals are declared in `pcoq.ml`, e.g. `let bignat = Entry.create "Prim.bignat"`. + All the `*.mlg` files include `open Pcoq` and often its modules, e.g. `open Pcoq.Prim`. + + `GRAMMAR EXTEND` should be used only for large syntax additions. To add new commands + and tactics, use these instead: + + - `VERNAC COMMAND EXTEND` to add new commands + - `TACTIC EXTEND` to add new tactics + - `ARGUMENT EXTEND` to add new nonterminals + + These constructs provide essential semantic information that's provided in a more complex, + less readable way with `GRAMMAR EXTEND`. + +* `VERNAC COMMAND EXTEND` - adds new command syntax by adding productions to the + `command` nonterminal. For example: + + ``` + VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY + | [ "Extraction" "Library" ident(m) ] + -> { extraction_library false m } + END + ``` + + Productions here are represented with alternate syntax, described later. + + New commands should be added using this construct rather than `GRAMMAR EXTEND` so + they are correctly registered, such as having the correct command classifier. + + TODO: explain "ExtractionLibrary", CLASSIFIED AS, CLASSIFIED BY, "{ tactic_mode }", STATE + +* `VERNAC { … } EXTEND` - TODO. A variant. The `{ … }` is a block of OCaml code. + +* `TACTIC EXTEND` - adds new tactic syntax by adding productions to `simple_tactic`. + For example: + + ``` + TACTIC EXTEND btauto + | [ "btauto" ] -> { Refl_btauto.Btauto.tac } + END + ``` + + adds a new nonterminal `btauto`. + + New tactics should be added using this construct rather than `GRAMMAR EXTEND`. + + TODO: explain DEPRECATED, LEVEL (not shown) + +* `ARGUMENT EXTEND` - defines a new nonterminal + + ``` + ARGUMENT EXTEND ast_closure_term + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) constr(c) ] -> { mk_ast_closure_term a c } + END + ``` + + See comments in `tacentries.mli` for partial information on the various + arguments. + +* `VERNAC ARGUMENT EXTEND` - (part of `argument_extend` in the yacc grammar) defines + productions for a single nonterminal. For example: + + ``` + VERNAC ARGUMENT EXTEND language + PRINTED BY { pr_language } + | [ "Ocaml" ] -> { let _ = warn_deprecated_ocaml_spelling () in Ocaml } + | [ "OCaml" ] -> { Ocaml } + | [ "Haskell" ] -> { Haskell } + | [ "Scheme" ] -> { Scheme } + | [ "JSON" ] -> { JSON } + END + ``` + + TODO: explain PRINTED BY, CODE + +* DOC_GRAMMAR - Used in `doc_grammar`-generated files to permit simplified syntax + +Note that you can reverse engineer many details by comparing the `.mlg` input file with +the `.ml` generated by `coqpp`. + +## Grammars: Nonterminals and Productions + +Here's a simple nonterminal definition in the Camlp5 format: + + ``` + universe: + [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> { ids } + | u = universe_expr -> { [u] } ] ] + ; + ``` + +In which: +* `universe` is the nonterminal being defined +* productions are separated by `|` and, as a group, are enclosed in `[ [ … ] ];` +* `u = universe_expr` refers to the `universe_expr` nonterminal. `u` is bound to + the value returned by that nonterminal's action routine, which can be + referred to in the action routine. For `ids = LIST1 universe_expr SEP ","`, + `ids` is bound to the list of values returned by `universe_expr`. +* `-> { … }` contains the OCaml action routine, which is executed when the production is recognized + and returns a value +* Semicolons separate adjacent grammatical elements (nonterminals, strings or other constructs) + +Grammatical elements that appear in productions are: + +- nonterminal names - identifiers in the form `[a-zA-Z0-9_]*`. These correspond to variables in + the generated `.ml` code. In some cases a qualified name, such as `Prim.name`, is used. +- `"…"` - a literal string that becomes a keyword and cannot be used as an `ident`. + The string doesn't have to be a valid identifier; frequently the string will contain only + punctuation characters. Generally we try to avoid adding new keywords that are also valid + identifiers--though there is an unresolved debate among the developers about whether having more + such keywords in general is good (e.g. it makes it easier to highlight keywords in GUIs) + or bad (more keywords for the user to avoid and new keywords may require changes to existing + proof files). +- `IDENT "…"` - a literal string that has the form of an `ident` that doesn't become + a keyword +- `OPT element` - optionally include `element` (e.g. a nonterminal, IDENT "…" or "…"). + The value is of type `'a option`. +- `LIST1 element` - a list of one or more `element`s. The value is of type `'a list`. +- `LIST0 element` - an optional list of `element`s +- `LIST1 element SEP sep` - a list of `element`s separated by `sep` +- `LIST0 element SEP sep` - an optional list of `element`s separated by `sep` +- `( elements )` - grouping to represent a series of elements as a unit, + useful within `OPT` and `LIST*`. +- `[ elements1 | elements2 | … ]` - alternatives (either `elements1` or `elements2` or …), + actually nested productions, each of which can have its own action routines + +Nonterminals can also be defined with multiple levels to specify precedence and associativity +of its productions. This is described in the Coq documentation under the `Print Grammar` +command. The first square bracket around a nonterminal definition is for grouping +level definitions, which are separated with `|`, for example: + + ``` + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> { te } ] + | "4" LEFTA + : + ``` + +Grammar extensions can specify what level they are modifying, for example: + + ``` + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + ] ]; + ``` + +### Alternate production syntax ### + +Except for `GRAMMAR EXTEND`, the `EXTEND` nodes in the `*.mlg`s use simplified syntax in +productions that's similar to what's used in the `Tactic Notation` and +`Ltac2 Notation` commands. For example: + + ``` + TACTIC EXTEND cc + | [ "congruence" ] -> { congruence_tac 1000 [] } + | [ "congruence" integer(n) ] -> { congruence_tac n [] } + | [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l } + | [ "congruence" integer(n) "with" ne_constr_list(l) ] -> + { congruence_tac n l } + END + ``` + +Nonterminals appearing in the alternate production syntax are accessed through `wit_*` symbols +defined in the OCaml code. Some commonly used symbols are defined in `stdarg.ml`. +Others are defined in the code generated by `ARGUMENT EXTEND` and `VERNAC ARGUMENT EXTEND` +constructs. References to nonterminals that don't have `wit_*` symbols cause +compilation errors. + +The differences are: +* The outer `: [ … ];` is omitted. Each production is enclosed in `| [ … ]`. +* The action routine is outside the square brackets +* Literal strings that are valid identifiers don't become reserved keywords +* No semicolons separating elements of the production +* `integer(n)` is used to bind a nonterminal value to a variable instead of `n = integer` +* Alternate forms of constructs are used: + * `ne_entry_list` for `LIST1 entry` + * `entry_list` for `LIST0 entry` + * `ne_entry_list_sep(var, sep)` for `LIST1 entry SEP sep` where the list is bound to `var` + * `entry_list_sep(var, sep)` for `LIST0 entry SEP sep` where the list is bound to `var` + * `entry_opt` for OPT entry +* There's no way to define `LEVEL`s +* There's no equivalent to `( elements )` or `[ elements1 | elements2 | … ]`, which may + require repeating similar syntax several times. For example, this single production + is equivalent to 8 productions in `TACTIC EXTEND` representing all possible expansions of + three `OPT`s: + + ``` + | IDENT "Add"; IDENT "Parametric"; IDENT "Relation"; LIST0 binder; ":"; constr; constr; + OPT [ IDENT "reflexivity"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + OPT [ IDENT "symmetry"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + OPT [ IDENT "transitivity"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + IDENT "as"; ident -> { … } + ``` + +## Usage notes + +### Other components + +Coq's lexer is in `clexer.ml`. Its 10 token types are defined in `tok.ml`. + +The parser is in `grammar.ml`. The extensive use of GADT (generalized algebraic datatypes) +makes it harder for the uninitiated to understand it. + +When the parser is invoked, the call tells the parser which nonterminal to parse. `vernac_control` +is the start symbol for commands. `tactic_mode` is the start symbol for tactics. +Tactics give syntax errors if Coq is not in proof mode. There are additional details +not mentioned here. + +### Parsing productions + +Some thoughts, not to be taken as identifying all the issues: + +Since the parser examines only the next token to make a parsing decision (and perhaps +because of other potentially fixable limitations), some productions have to be ordered +or structured in a particular way to parse correctly in all cases. + +For example, consider these productions: + + ``` + command: [ [ + | IDENT "Print"; p = printable -> { VernacPrint p } + | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> { VernacPrint (PrintName (qid,l)) } + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + { VernacPrint (PrintModuleType qid) } + | IDENT "Print"; IDENT "Module"; qid = global -> + { VernacPrint (PrintModule qid) } + | IDENT "Print"; IDENT "Namespace" ; ns = dirpath -> + { VernacPrint (PrintNamespace ns) } + : + + printable: + [ [ IDENT "Term"; qid = smart_global; l = OPT univ_name_list -> { PrintName (qid,l) } + | IDENT "All" -> { PrintFullContext } + | IDENT "Section"; s = global -> { PrintSectionContext s } + : + ``` + +Reversing the order of the first two productions in `command` causes the `All` in `Print All` to +be parsed incorrectly as a `smart_global`, making that command unavailable. `Print Namespace nat.` +still works correctly, though. + +Similarly, the production for `Print Module Type` has to appear before `Print Module <global>` +in order to be reachable. + +Internally, the parser generates a tree that represents the possible prefixes for the +productions of a nonterminal as described in +[the Camlp5 documentation](http://camlp5.github.io/doc/htmlc/grammars.html#b:Rules-insertion). + +Here's another example in which the way the productions are written matters. `OPT` at +the beginning of a production doesn't always work well: + + ``` + command: [ [ + | IDENT "Foo"; n = natural -> { VernacBack 1 } + | OPT (IDENT "ZZ"); IDENT "Foo" -> { VernacBack 1 } + : + ``` + +`Foo.` looks like it should be accepted, but it gives a parse error: + + ``` + Unnamed_thm < Foo. + Toplevel input, characters 3-4: + > Foo. + > ^ + Error: + Syntax error: [prim:natural] expected after 'Foo' (in [vernac:command]). + ``` + +Reversing the order of the productions doesn't help, but splitting +the 'OPT' production into 2 productions works: + + ``` + | IDENT "Foo" -> { VernacBack 1 } + | IDENT "ZZ"; IDENT "Foo" -> { VernacBack 1 } + | IDENT "Foo"; n = natural -> { VernacBack 1 } + + ``` + +On the other hand, `OPT` works just fine when the parser has already found the +right production. For example `Back` and `Back <natural>` can be combined using +an `OPT`: + + ``` + | IDENT "Back"; n = OPT natural -> { VernacBack (Option.default 1 n) } + ``` + +### Lookahead + +It's possible to look ahead more than one symbol using OCaml code. Generally we +avoid doing this unless there's a strong reason to do so. For example, this +code defines a new nonterminal `local_test_lpar_id_colon` that checks that +the next 3 tokens are `"("` `ident` and `":"` without consuming any input: + + ``` + let local_test_lpar_id_colon = + let open Pcoq.Lookahead in + to_entry "lpar_id_colon" begin + lk_kw "(" >> lk_ident >> lk_kw ":" + end + ``` + +This one checks that the next 2 tokens are `"["` and `"|"` with no space between. +This is a special case: intropatterns can have sequences like `"[|]"` that are +3 different tokens with empty nonterminals between them. Making `"[|"` a keyword +would break existing code with "[|]": + + ``` + let test_array_opening = + let open Pcoq.Lookahead in + to_entry "test_array_opening" begin + lk_kw "[" >> lk_kw "|" >> check_no_space + end + ``` + +TODO: how to add a tactic or command diff --git a/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst b/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst new file mode 100644 index 0000000000..1bf62de3fd --- /dev/null +++ b/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst @@ -0,0 +1,5 @@ +- **Fixed:** Incompleteness of conversion checking on problems + involving :ref:`eta-expansion` and :ref:`cumulative universe + polymorphic inductive types <cumulative>` (`#12738 + <https://github.com/coq/coq/pull/12738>`_, fixes `#7015 + <https://github.com/coq/coq/issues/7015>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst b/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst new file mode 100644 index 0000000000..b0cf4ca4e3 --- /dev/null +++ b/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst @@ -0,0 +1,9 @@ +- **Changed:** + Tweaked the algorithm giving default names to arguments. + Should reduce the frequency that argument names get an + unexpected suffix. + Also makes :flag:`Mangle Names` not mess up argument names. + (`#12756 <https://github.com/coq/coq/pull/12756>`_, + fixes `#12001 <https://github.com/coq/coq/issues/12001>`_ + and `#6785 <https://github.com/coq/coq/issues/6785>`_, + by Jasper Hugunin). diff --git a/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst b/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst new file mode 100644 index 0000000000..289d17167d --- /dev/null +++ b/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Anomaly with :tacn:`injection` involving artificial + dependencies disappearing by reduction + (`#12816 <https://github.com/coq/coq/pull/12816>`_, + fixes `#12787 <https://github.com/coq/coq/issues/12787>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-tools/12754-master+fix-coqdoc-index-escaping.rst b/doc/changelog/08-tools/12754-master+fix-coqdoc-index-escaping.rst new file mode 100644 index 0000000000..a05829b720 --- /dev/null +++ b/doc/changelog/08-tools/12754-master+fix-coqdoc-index-escaping.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Special symbols now escaped in the index produced by coqdoc, + avoiding collision with the syntax of the output format + (`#12754 <https://github.com/coq/coq/pull/12754>`_, + fixes `#12752 <https://github.com/coq/coq/issues/12752>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-tools/12772-fix-details.rst b/doc/changelog/08-tools/12772-fix-details.rst new file mode 100644 index 0000000000..67ee061285 --- /dev/null +++ b/doc/changelog/08-tools/12772-fix-details.rst @@ -0,0 +1,5 @@ +- **Fixed:** + The `details` environment added in the 8.12 release can now be used + as advertised in the reference manual + (`#12772 <https://github.com/coq/coq/pull/12772>`_, + by Thomas Letan). diff --git a/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst b/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst new file mode 100644 index 0000000000..208855b4c8 --- /dev/null +++ b/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst @@ -0,0 +1,9 @@ +- **Changed:** + Int63 notations now match up with the rest of the standard library: :g:`a \% + m`, :g:`m == n`, :g:`m < n`, :g:`m <= n`, and :g:`m ≤ n` have been replaced + with :g:`a mod m`, :g:`m =? n`, :g:`m <? n`, :g:`m <=? n`, and :g:`m ≤? n`. + The old notations are still available as deprecated notations. Additionally, + there is now a ``Coq.Numbers.Cyclic.Int63.Int63.Int63Notations`` module that + users can import to get the ``Int63`` notations without unqualifying the + various primitives (`#12479 <https://github.com/coq/coq/pull/12479>`_, fixes + `#12454 <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst b/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst new file mode 100644 index 0000000000..1709cf1eae --- /dev/null +++ b/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst @@ -0,0 +1,9 @@ +- **Changed:** + PrimFloat notations now match up with the rest of the standard library: :g:`m + == n`, :g:`m < n`, and :g:`m <= n` have been replaced with :g:`m =? n`, :g:`m + <? n`, and :g:`m <=? n`. The old notations are still available as deprecated + notations. Additionally, there is now a + ``Coq.Floats.PrimFloat.PrimFloatNotations`` module that users can import to + get the ``PrimFloat`` notations without unqualifying the various primitives + (`#12556 <https://github.com/coq/coq/pull/12556>`_, fixes `#12454 + <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12716-curry.rst b/doc/changelog/10-standard-library/12716-curry.rst new file mode 100644 index 0000000000..51b59e4a94 --- /dev/null +++ b/doc/changelog/10-standard-library/12716-curry.rst @@ -0,0 +1,4 @@ +- **Deprecated:** + ``prod_curry`` and ``prod_uncurry``, in favor of ``uncurry`` and ``curry`` + (`#12716 <https://github.com/coq/coq/pull/12716>`_, + by Yishuai Li). diff --git a/doc/changelog/10-standard-library/12799-list-repeat.rst b/doc/changelog/10-standard-library/12799-list-repeat.rst new file mode 100644 index 0000000000..adfc48f67b --- /dev/null +++ b/doc/changelog/10-standard-library/12799-list-repeat.rst @@ -0,0 +1,4 @@ +- **Added:** + New lemmas about ``repeat`` in ``List`` and ``Permutation``: ``repeat_app``, ``repeat_eq_app``, ``repeat_eq_cons``, ``repeat_eq_elt``, ``Forall_eq_repeat``, ``Permutation_repeat`` + (`#12799 <https://github.com/coq/coq/pull/12799>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12801-cyclic-set.rst b/doc/changelog/10-standard-library/12801-cyclic-set.rst new file mode 100644 index 0000000000..9a07d78144 --- /dev/null +++ b/doc/changelog/10-standard-library/12801-cyclic-set.rst @@ -0,0 +1,5 @@ +- **Changed:** + Change the sort of cyclic numbers from Type to Set. For backward compatibility, a dynamic sort was defined in the 3 packages bignums, coqprime and color. + See for example commit 6f62bda in bignums. + (`#12801 <https://github.com/coq/coq/pull/12801>`_, + by Vincent Semeria). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst b/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst new file mode 100644 index 0000000000..c754826e62 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst @@ -0,0 +1,5 @@ +- **Fixed:** + ``make approve-output`` in the test-suite now correctly handles + ``output-coqtop`` and ``output-coqchk`` tests (`#12864 + <https://github.com/coq/coq/pull/12864>`_, fixes `#12863 + <https://github.com/coq/coq/issues/12863>`_, by Jason Gross). diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 41b726b069..ce68274036 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -99,12 +99,15 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Extraction Language {| OCaml | Haskell | Scheme } +.. cmd:: Extraction Language {| OCaml | Haskell | Scheme | JSON } :name: Extraction Language The ability to fix target language is the first and more important of the extraction options. Default is ``OCaml``. + The JSON output is mostly for development or debugging: + it contains the raw ML term produced as an intermediary target. + Inlining and optimizations ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index f9d24fde0e..c27eb216e8 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -40,7 +40,7 @@ in the |Coq| root directory; this includes the modules ``Datatypes``, ``Specif``, ``Peano``, -``Wf`` and +``Wf`` and ``Tactics``. Module ``Logic_Type`` also makes it in the initial state. @@ -175,7 +175,7 @@ Quantifiers Then we find first-order quantifiers: .. coqtop:: in - + Definition all (A:Set) (P:A -> Prop) := forall x:A, P x. Inductive ex (A: Set) (P:A -> Prop) : Prop := ex_intro (x:A) (_:P x). @@ -256,12 +256,12 @@ Finally, a few easy lemmas are provided. single: f_equal2 ... f_equal5 (term) The theorem ``f_equal`` is extended to functions with two to five -arguments. The theorem are names ``f_equal2``, ``f_equal3``, +arguments. The theorem are names ``f_equal2``, ``f_equal3``, ``f_equal4`` and ``f_equal5``. For instance ``f_equal3`` is defined the following way. .. coqtop:: in abort - + Theorem f_equal3 : forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), @@ -324,7 +324,7 @@ Programming Note that zero is the letter ``O``, and *not* the numeral ``0``. -The predicate ``identity`` is logically +The predicate ``identity`` is logically equivalent to equality but it lives in sort ``Type``. It is mainly maintained for compatibility. @@ -367,7 +367,7 @@ infix notation ``||``), ``xorb``, ``implb`` and ``negb``. Specification ~~~~~~~~~~~~~ -The following notions defined in module ``Specif.v`` allow to build new data-types and specifications. +The following notions defined in module ``Specif.v`` allow to build new data-types and specifications. They are available with the syntax shown in the previous section :ref:`datatypes`. For instance, given :g:`A:Type` and :g:`P:A->Prop`, the construct @@ -393,11 +393,11 @@ provided. .. coqtop:: in Inductive sig (A:Set) (P:A -> Prop) : Set := exist (x:A) (_:P x). - Inductive sig2 (A:Set) (P Q:A -> Prop) : Set := + Inductive sig2 (A:Set) (P Q:A -> Prop) : Set := exist2 (x:A) (_:P x) (_:Q x). A *strong (dependent) sum* :g:`{x:A & P x}` may be also defined, -when the predicate ``P`` is now defined as a +when the predicate ``P`` is now defined as a constructor of types in ``Type``. .. index:: @@ -556,7 +556,7 @@ section :tacn:`refine`). This scope is opened by default. Now comes the content of module ``Peano``: .. coqdoc:: - + Theorem eq_S : forall x y:nat, x = y -> S x = S y. Definition pred (n:nat) : nat := match n with @@ -628,7 +628,7 @@ induction principle. .. coqdoc:: Theorem nat_case : - forall (n:nat) (P:nat -> Prop), + forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n. Theorem nat_double_ind : forall R:nat -> nat -> Prop, @@ -640,7 +640,7 @@ induction principle. Well-founded recursion ~~~~~~~~~~~~~~~~~~~~~~ -The basic library contains the basics of well-founded recursion and +The basic library contains the basics of well-founded recursion and well-founded induction, in module ``Wf.v``. .. index:: @@ -669,7 +669,7 @@ well-founded induction, in module ``Wf.v``. forall P:A -> Prop, (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a. -The automatically generated scheme ``Acc_rect`` +The automatically generated scheme ``Acc_rect`` can be used to define functions by fixpoints using well-founded relations to justify termination. Assuming extensionality of the functional used for the recursive call, the @@ -741,7 +741,7 @@ The standard library Survey ~~~~~~ -The rest of the standard library is structured into the following +The rest of the standard library is structured into the following subdirectories: * **Logic** : Classical logic and dependent equality @@ -751,8 +751,8 @@ subdirectories: * **ZArith** : Basic relative integer arithmetic * **Numbers** : Various approaches to natural, integer and cyclic numbers (currently axiomatically and on top of 2^31 binary words) * **Bool** : Booleans (basic functions and results) - * **Lists** : Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with co-inductive types) - * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) + * **Lists** : Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with co-inductive types) + * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) * **FSets** : Specification and implementations of finite sets and finite maps (by lists and by AVL trees) * **Reals** : Axiomatization of real numbers (classical, basic functions, integer part, fractional part, limit, derivative, Cauchy series, power series and results,...) * **Floats** : Machine implementation of floating-point arithmetic (for the binary64 format) @@ -903,7 +903,7 @@ tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR :name: discrR - + Proves that two real integer constants are different. .. example:: @@ -931,7 +931,7 @@ tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: split_Rmult :name: split_Rmult - + Splits a condition that a product is non null into subgoals corresponding to the condition on each operand of the product. @@ -963,7 +963,7 @@ List library single: fold_left (term) single: fold_right (term) -Some elementary operations on polymorphic lists are defined here. +Some elementary operations on polymorphic lists are defined here. They can be accessed by requiring module ``List``. It defines the following notions: @@ -1052,9 +1052,9 @@ Notation Interpretation ``_ + _`` ``add`` ``_ * _`` ``mul`` ``_ / _`` ``div`` -``_ == _`` ``eqb`` -``_ < _`` ``ltb`` -``_ <= _`` ``leb`` +``_ =? _`` ``eqb`` +``_ <? _`` ``ltb`` +``_ <=? _`` ``leb`` ``_ ?= _`` ``compare`` =========== ============== diff --git a/doc/sphinx/language/core/variants.rst b/doc/sphinx/language/core/variants.rst index d00a2f4100..8e2bf32dd6 100644 --- a/doc/sphinx/language/core/variants.rst +++ b/doc/sphinx/language/core/variants.rst @@ -57,6 +57,11 @@ Private (matching) inductive types Definition by cases: match -------------------------- +Objects of inductive types can be destructured by a case-analysis +construction called *pattern matching* expression. A pattern matching +expression is used to analyze the structure of an inductive object and +to apply specific treatments accordingly. + .. insertprodn term_match pattern0 .. prodn:: @@ -77,10 +82,12 @@ Definition by cases: match | @numeral | @string -Objects of inductive types can be destructured by a case-analysis -construction called *pattern matching* expression. A pattern matching -expression is used to analyze the structure of an inductive object and -to apply specific treatments accordingly. +Note that the :n:`@pattern ::= @pattern10 : @term` production +is not supported in :n:`match` patterns. Trying to use it will give this error: + +.. exn:: Casts are not supported in this pattern. + :undocumented: + This paragraph describes the basic form of pattern matching. See Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index 40e0898871..20f4310d13 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -13,13 +13,13 @@ Existential variables | ?[ ?@ident ] | ?@ident {? @%{ {+; @ident := @term } %} } -|Coq| terms can include existential variables which represents unknown -subterms to eventually be replaced by actual subterms. +|Coq| terms can include existential variables that represent unknown +subterms that are eventually replaced with actual subterms. -Existential variables are generated in place of unsolvable implicit +Existential variables are generated in place of unsolved implicit arguments or “_” placeholders when using commands such as ``Check`` (see Section :ref:`requests-to-the-environment`) or when using tactics such as -:tacn:`refine`, as well as in place of unsolvable instances when using +:tacn:`refine`, as well as in place of unsolved instances when using tactics such that :tacn:`eapply`. An existential variable is defined in a context, which is the context of variables of the placeholder which generated the existential variable, and a type, @@ -43,22 +43,18 @@ existential variable is represented by “?” followed by an identifier. Check identity _ (fun x => _). In the general case, when an existential variable :n:`?@ident` appears -outside of its context of definition, its instance, written under the -form :n:`{ {*; @ident := @term} }` is appending to its name, indicating +outside its context of definition, its instance, written in the +form :n:`{ {*; @ident := @term} }`, is appended to its name, indicating how the variables of its defining context are instantiated. -The variables of the context of the existential variables which are -instantiated by themselves are not written, unless the :flag:`Printing Existential Instances` flag -is on (see Section :ref:`explicit-display-existentials`), and this is why an -existential variable used in the same context as its context of definition is written with no instance. +Only the variables that are defined in another context are displayed: +this is why an existential variable used in the same context as its +context of definition is written with no instance. +This behaviour may be changed: see :ref:`explicit-display-existentials`. .. coqtop:: all Check (fun x y => _) 0 1. - Set Printing Existential Instances. - - Check (fun x y => _) 0 1. - Existential variables can be named by the user upon creation using the syntax :n:`?[@ident]`. This is useful when the existential variable needs to be explicitly handled later in the script (e.g. @@ -88,6 +84,14 @@ Explicit displaying of existential instances for pretty-printing context of an existential variable is instantiated at each of the occurrences of the existential variable. +.. coqtop:: all + + Check (fun x y => _) 0 1. + + Set Printing Existential Instances. + + Check (fun x y => _) 0 1. + .. _tactics-in-terms: Solving existential variables using tactics diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index bbd486e3ba..ca69072cb9 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -70,7 +70,7 @@ is said *contextual* if it can be inferred only from the knowledge of the type of the context of the current expression. For instance, the only argument of:: - nil : forall A:Set, list A` + nil : forall A:Set, list A is contextual. Similarly, both arguments of a term of type:: @@ -539,7 +539,7 @@ with free variables into a closed statement where these variables are quantified explicitly. Use the :cmd:`Generalizable` command to designate which variables should be generalized. -It is activated for a binder by prefixing a \`, and for terms by +It is activated within a binder by prefixing it with \`, and for terms by surrounding it with \`{ }, or \`[ ] or \`( ). Terms surrounded by \`{ } introduce their free variables as maximally diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index b4558ef07f..d6a828521f 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -94,7 +94,7 @@ The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` performs case analysis on :n:`@term__0` whose type must be an inductive type with exactly one constructor. The number of variables :n:`@ident__i` must correspond to the number of arguments of this -contrustor. Then, in :n:`@term__1`, these variables are bound to the +constructor. Then, in :n:`@term__1`, these variables are bound to the arguments of the constructor in :n:`@term__0`. For instance, the definition diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 058b8ccd5c..ec182ce08f 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -81,8 +81,7 @@ loading of the resource file with the option ``-q``. By environment variables ~~~~~~~~~~~~~~~~~~~~~~~~~ -Load path can be specified to the |Coq| system by setting up ``$COQPATH`` -environment variable. It is a list of directories separated by +``$COQPATH`` can be used to specify the load path. It is a list of directories separated by ``:`` (``;`` on Windows). |Coq| will also honor ``$XDG_DATA_HOME`` and ``$XDG_DATA_DIRS`` (see Section :ref:`libraries-and-filesystem`). @@ -92,7 +91,7 @@ not set, they look for the commands in the executable path. .. _COQ_COLORS: -The ``$COQ_COLORS`` environment variable can be used to specify the set +``$COQ_COLORS`` can be used to specify the set of colors used by ``coqtop`` to highlight its output. It uses the same syntax as the ``$LS_COLORS`` variable from GNU’s ls, that is, a colon-separated list of assignments of the form :n:`name={*; attr}` where @@ -108,6 +107,22 @@ sets the highlights for added text in diffs to underlined (the 4) with a backgro color (0, 0, 240) and for removed text in diffs to a red background. Note that if you specify ``COQ_COLORS``, the predefined attributes are ignored. +.. _OCAMLRUNPARAM: + +``$OCAMLRUNPARAM``, described +`here <https://caml.inria.fr/pub/docs/manual-ocaml/runtime.html#s:ocamlrun-options>`_, +can be used to specify certain runtime and memory usage parameters. In most cases, +experimenting with these settings will likely not cause a significant performance difference +and should be harmless. + +If the variable is not set, |Coq| uses the +`default values <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEcontrol>`_, +except that ``space_overhead`` is set to 120 and ``minor_heap_size`` is set to 32Mwords +(256MB with 64-bit executables or 128MB with 32-bit executables). + +.. todo: Using the same text "here" for both of the links in the last 2 paragraphs generates + an incorrect warning: coq-commands.rst:4: WARNING: Duplicate explicit target name: "here". + The warning doesn't even have the right line number. :-( .. _command-line-options: diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 00aafe1266..4480b10319 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -858,19 +858,28 @@ Controlling the effect of proof editing commands Controlling memory usage ------------------------ +.. cmd:: Print Debug GC + + Prints heap usage statistics, which are values from the `stat` type of the `Gc` module + described + `here <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEstat>`_ + in the OCaml documentation. + The `live_words`, `heap_words` and `top_heap_words` values give the basic information. + Words are 8 bytes or 4 bytes, respectively, for 64- and 32-bit executables. + When experiencing high memory usage the following commands can be used to force |Coq| to optimize some of its internal data structures. - .. cmd:: Optimize Proof - This command forces |Coq| to shrink the data structure used to represent - the ongoing proof. + Shrink the data structure used to represent the current proof. .. cmd:: Optimize Heap - This command forces the |OCaml| runtime to perform a heap compaction. - This is in general an expensive operation. - See: `OCaml Gc <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ + Perform a heap compaction. This is generally an expensive operation. + See: `OCaml Gc.compact <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ There is also an analogous tactic :tacn:`optimize_heap`. + +Memory usage parameters can be set through the :ref:`OCAMLRUNPARAM <OCAMLRUNPARAM>` +environment variable. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 7b3670164b..4eaca8634f 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1211,6 +1211,8 @@ The move tactic. :tacn:`revert`, :tacn:`rename`, :tacn:`clear` and :tacn:`pattern` tactics. +.. _the_case_tactic_ssr: + The case tactic ``````````````` @@ -1235,7 +1237,17 @@ The case tactic x = 1 -> y = 2 -> G. - Note also that the case of |SSR| performs :g:`False` elimination, even + The :tacn:`case` can generate the following warning: + + .. warn:: SSReflect: cannot obtain new equations out of ... + + The tactic was run on an equation that cannot generate simpler equations, + for example `x = 1`. + + The warning can be silenced or made fatal by using the :opt:`Warnings` option + and the `spurious-ssr-injection` key. + + Finally the :tacn:`case` tactic of |SSR| performs :g:`False` elimination, even if no branch is generated by this case operation. Hence the tactic :tacn:`case` on a goal of the form :g:`False -> G` will succeed and prove the goal. @@ -2280,7 +2292,7 @@ to the others. Iteration ~~~~~~~~~ -.. tacn:: do {? @num } {| @tactic | [ {+| @tactic } ] } +.. tacn:: do {? @mult } {| @tactic | [ {+| @tactic } ] } :name: do (ssreflect) This tactical offers an accurate control on the repetition of tactics. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 25c4de7389..8635add0e1 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -2227,9 +2227,6 @@ and an explanation of the underlying technique. then :n:`injection @ident` first introduces the hypothesis in the local context using :n:`intros until @ident`. - .. exn:: Not a projectable equality but a discriminable one. - :undocumented: - .. exn:: Nothing to do, it is an equality between convertible terms. :undocumented: @@ -2237,7 +2234,8 @@ and an explanation of the underlying technique. :undocumented: .. exn:: Nothing to inject. - :undocumented: + + This error is given when one side of the equality is not a constructor. .. tacv:: injection @num @@ -2821,19 +2819,12 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. only in the conclusion of the goal. The clause argument must not contain any ``type of`` nor ``value of``. - .. tacv:: cutrewrite <- (@term = @term’) + .. tacv:: cutrewrite {? {| <- | -> } } (@term__1 = @term__2) {? in @ident } :name: cutrewrite .. deprecated:: 8.5 - This tactic can be replaced by :n:`enough (@term = @term’) as <-`. - - .. tacv:: cutrewrite -> (@term = @term’) - - .. deprecated:: 8.5 - - This tactic can be replaced by :n:`enough (@term = @term’) as ->`. - + Use :tacn:`replace` instead. .. tacn:: subst @ident :name: subst diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 18149a690a..9e8e5e5fa5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -425,16 +425,98 @@ Displaying information about notations (corresponding to :token:`ltac_expr` in the documentation). - `vernac` - for :token:`command`\s - The first three of these give the precedence and associativity for each construct. - For example, these lines printed by `Print Grammar tactic` indicates that the `try` construct - is at level 3 and right-associative. `SELF` represents the `tactic_expr` nonterminal - at level 5 (the top level):: - + This command doesn't display all nonterminals of the grammar. For example, + productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` + and `tactic_then_gen` which are not shown and can't be printed. + + The prefixes `tactic:`, `prim:`, `constr:` appearing in the output are meant to identify + what part of the grammar a nonterminal is from. If you examine nonterminal definitions + in the source code, they are identified only by the name following the colon. + + Most of the grammar in the documentation was updated in 8.12 to make it accurate and + readable. This was done using a new developer tool that extracts the grammar from the + source code, edits it and inserts it into the documentation files. While the + edited grammar is equivalent to the original, for readability some nonterminals + have been renamed and others have been eliminated by substituting the nonterminal + definition where the nonterminal was referenced. This command shows the original grammar, + so it won't exactly match the documentation. + + The |Coq| parser is based on Camlp5. The documentation for + `Extensible grammars <http://camlp5.github.io/doc/htmlc/grammars.html>`_ is the + most relevant but it assumes considerable knowledge. Here are the essentials: + + Productions can contain the following elements: + + - nonterminal names - identifiers in the form `[a-zA-Z0-9_]*` + - `"…"` - a literal string that becomes a keyword and cannot be used as an :token:`ident`. + The string doesn't have to be a valid identifier; frequently the string will contain only + punctuation characters. + - `IDENT "…"` - a literal string that has the form of an :token:`ident` + - `OPT element` - optionally include `element` (e.g. a nonterminal, IDENT "…" or "…") + - `LIST1 element` - a list of one or more `element`\s + - `LIST0 element` - an optional list of `element`\s + - `LIST1 element SEP sep` - a list of `element`\s separated by `sep` + - `LIST0 element SEP sep` - an optional list of `element`\s separated by `sep` + - `[ elements1 | elements2 | … ]` - alternatives (either `elements1` or `elements2` or …) + + Nonterminals can have multiple **levels** to specify precedence and associativity + of its productions. This feature of grammars makes it simple to parse input + such as `1+2*3` in the usual way as `1+(2*3)`. However, most nonterminals have a single level. + + For example, this output from `Print Grammar tactic` shows the first 3 levels for + `tactic_expr`, designated as "5", "4" and "3". Level 3 is right-associative, + which applies to the productions within it, such as the `try` construct:: + + Entry tactic:tactic_expr is + [ "5" RIGHTA + [ tactic:binder_tactic ] + | "4" LEFTA + [ SELF; ";"; tactic:binder_tactic + | SELF; ";"; SELF + | SELF; ";"; tactic_then_locality; tactic_then_gen; "]" ] | "3" RIGHTA [ IDENT "try"; SELF + : + + The interpretation of `SELF` depends on its position in the production and the + associativity of the level: + + - At the beginning of a production, `SELF` means the next level. In the + fragment shown above, the next level for `try` is "2". (This is defined by the order + of appearance in the grammar or output; the levels could just as well be + named "foo" and "bar".) + - In the middle of a production, `SELF` means the top level ("5" in the fragment) + - At the end of a production, `SELF` means the next level within + `LEFTA` levels and the current level within `RIGHTA` levels. + + `NEXT` always means the next level. `nonterminal LEVEL "…"` is a reference to the specified level + for `nonterminal`. + + `Associativity <http://camlp5.github.io/doc/htmlc/grammars.html#b:Associativity>`_ + explains `SELF` and `NEXT` in somewhat more detail. + + The output for `Print Grammar constr` includes :cmd:`Notation` definitions, + which are dynamically added to the grammar at run time. + For example, in the definition for `operconstr`, the production on the second line shown + here is defined by a :cmd:`Reserved Notation` command in `Notations.v`:: + + | "50" LEFTA + [ SELF; "||"; NEXT + + Similarly, `Print Grammar tactic` includes :cmd:`Tactic Notation`\s, such as :tacn:`dintuition`. + + The file + `doc/tools/docgram/fullGrammar <http://github.com/coq/coq/blob/master/doc/tools/docgram/fullGrammar>`_ + in the source tree extracts the full grammar for + |Coq| (not including notations and tactic notations defined in `*.v` files nor some optionally-loaded plugins) + in a single file with minor changes to handle nonterminals using multiple levels (described in + `doc/tools/docgram/README.md <http://github.com/coq/coq/blob/master/doc/tools/docgram/README.md>`_). + This is complete and much easier to read than the grammar source files. + `doc/tools/docgram/orderedGrammar <http://github.com/coq/coq/blob/master/doc/tools/docgram/orderedGrammar>`_ + has the edited grammar that's used in the documentation. - Note that the productions printed by this command are represented in the form used by - |Coq|'s parser (coqpp), which differs from how productions are shown in the documentation. + Developer documentation for parsing is in + `dev/doc/parsing.md <http://github.com/coq/coq/blob/master/dev/doc/parsing.md>`_. .. _locating-notations: @@ -872,7 +954,7 @@ where ``x`` is any expression parsed in entry the given rule) and ``y`` is any expression parsed in entry ``expr`` at level strictly less than ``2``. -Rules associated to an entry can refer different sub-entries. The +Rules associated with an entry can refer different sub-entries. The grammar entry name ``constr`` can be used to refer to the main grammar of term as in the rule @@ -958,7 +1040,7 @@ up to the insertion of a pair of curly brackets. .. cmd:: Print Custom Grammar @ident :name: Print Custom Grammar - This displays the state of the grammar for terms associated to + This displays the state of the grammar for terms associated with the custom entry :token:`ident`. .. _NotationSyntax: diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 334c23c963..36297fe243 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -743,6 +743,9 @@ let match_named_context_val : match unsafe_eq with | Refl -> match_named_context_val +let identity_subst_val : named_context_val -> t list = + match unsafe_eq with Refl -> fun ctx -> ctx.env_named_var + let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in evd, t diff --git a/engine/eConstr.mli b/engine/eConstr.mli index d0f675319d..a018f4064f 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -326,6 +326,8 @@ val map_rel_context_in_env : val match_named_context_val : named_context_val -> (named_declaration * lazy_val * named_context_val) option +val identity_subst_val : named_context_val -> t list + (* 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 b4b2032dd2..01c4e5fd72 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -386,14 +386,12 @@ let push_rel_decl_to_named_context let push_rel_context_to_named_context ?hypnaming env sigma typ = (* compute the instances relative to the named context and rel_context *) - let open Context.Named.Declaration in let open EConstr in - let ids = List.map get_id (named_context env) in - let inst_vars = List.map mkVar ids in + let inst_vars = EConstr.identity_subst_val (named_context_val env) in if List.is_empty (Environ.rel_context env) then (named_context_val env, typ, inst_vars, empty_csubst) else - let avoid = List.fold_right Id.Set.add ids Id.Set.empty in + let avoid = Environ.ids_of_named_context_val (named_context_val env) 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 *) @@ -409,8 +407,9 @@ let push_rel_context_to_named_context ?hypnaming env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole -let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) - ?candidates ?(naming = IntroAnonymous) ?typeclass_candidate ?(principal=false) sign evd typ = +let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?identity + ?(abstract_arguments = Abstraction.identity) ?candidates + ?(naming = IntroAnonymous) ?typeclass_candidate ?(principal=false) sign evd typ = let name = match naming with | IntroAnonymous -> None | IntroIdentifier id -> Some id @@ -419,6 +418,10 @@ let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_a let id = Namegen.next_ident_away_from id has_name in Some id in + let identity = match identity with + | None -> Identity.none () + | Some inst -> Identity.make inst + in let evi = { evar_hyps = sign; evar_concl = typ; @@ -426,7 +429,9 @@ let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_a evar_filter = filter; evar_abstract_arguments = abstract_arguments; evar_source = src; - evar_candidates = candidates } + evar_candidates = candidates; + evar_identity = identity; + } in let typeclass_candidate = if principal then Some false else typeclass_candidate in let (evd, newevk) = Evd.new_evar evd ?name ?typeclass_candidate evi in @@ -447,7 +452,8 @@ let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_can match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in - let (evd, evk) = new_pure_evar sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming + let identity = if Int.equal (Environ.nb_rel env) 0 then Some instance else None in + let (evd, evk) = new_pure_evar sign evd typ' ?src ?filter ?identity ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal in (evd, EConstr.mkEvar (evk, instance)) diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 41b58d38b0..a8fc9ef5e2 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -40,8 +40,18 @@ val new_evar : ?principal:bool -> ?hypnaming:naming_mode -> env -> evar_map -> types -> evar_map * EConstr.t +(** Low-level interface to create an evar. + @param src User-facing source for the evar + @param filter See {!Evd.Filter}, must be the same length as [named_context_val] + @param identity See {!Evd.Identity}, must be the name projection of [named_context_val] + @param naming A naming scheme for the evar + @param principal Whether the evar is the principal goal + @param named_context_val The context of the evar + @param types The type of conclusion of the evar +*) val new_pure_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?identity:EConstr.t list -> ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> diff --git a/engine/evd.ml b/engine/evd.ml index c570f75c6b..92657c41a9 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -139,6 +139,29 @@ module Abstraction = struct let abstract_last l = Abstract :: l end +module Identity : +sig + type t + val make : econstr list -> t + val none : unit -> t + val repr : named_context_val -> Filter.t -> t -> econstr list + val is_identity : econstr list -> t -> bool +end = +struct + type t = econstr list option ref + let make s = ref (Some s) + let none () = ref None + let repr sign filter s = match !s with + | None -> + let ans = Filter.filter_list filter sign.env_named_var in + let () = s := Some ans in + ans + | Some s -> s + let is_identity l s = match !s with + | None -> false + | Some s -> s == l +end + (* The kinds of existential variables are now defined in [Evar_kinds] *) (* The type of mappings for existential variables *) @@ -158,7 +181,9 @@ type evar_info = { evar_filter : Filter.t; evar_abstract_arguments : Abstraction.t; evar_source : Evar_kinds.t Loc.located; - evar_candidates : constr list option; (* if not None, list of allowed instances *)} + evar_candidates : constr list option; (* if not None, list of allowed instances *) + evar_identity : Identity.t; +} let make_evar hyps ccl = { evar_concl = ccl; @@ -167,7 +192,9 @@ let make_evar hyps ccl = { evar_filter = Filter.identity; evar_abstract_arguments = Abstraction.identity; evar_source = Loc.tag @@ Evar_kinds.InternalHole; - evar_candidates = None; } + evar_candidates = None; + evar_identity = Identity.none (); +} let instance_mismatch () = anomaly (Pp.str "Signature and its instance do not match.") @@ -216,6 +243,9 @@ let evar_filtered_env env evi = match Filter.repr (evar_filter evi) with in make_env filter (evar_context evi) +let evar_identity_subst evi = + Identity.repr evi.evar_hyps evi.evar_filter evi.evar_identity + let map_evar_body f = function | Evar_empty -> Evar_empty | Evar_defined d -> Evar_defined (f d) @@ -256,7 +286,9 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) args let make_evar_instance_array info args = - evar_instance_array (NamedDecl.get_id %> isVarId) info args + if Identity.is_identity args info.evar_identity then [] + else + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -779,16 +811,17 @@ let declare_restricted_evar evar_flags evk evk' = let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in + let id_inst = Filter.filter_list filter evar_info.evar_hyps.env_named_var in let evar_info' = { evar_info with evar_filter = filter; evar_candidates = candidates; - evar_source = (match src with None -> evar_info.evar_source | Some src -> src) } in + evar_source = (match src with None -> evar_info.evar_source | Some src -> src); + evar_identity = Identity.make id_inst; + } in let last_mods = match evd.conv_pbs with | [] -> evd.last_mods | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in - let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = List.map (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in let evar_flags = declare_restricted_evar evd.evar_flags evk evk' in @@ -987,11 +1020,6 @@ let check_constraints evd csts = let fix_undefined_variables evd = { evd with universes = UState.fix_undefined_variables evd.universes } -let refresh_undefined_universes evd = - let uctx', subst = UState.refresh_undefined_univ_variables evd.universes in - let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in - evd', subst - let nf_univ_variables evd = let subst, uctx' = UState.normalize_variables evd.universes in let evd' = {evd with universes = uctx'} in diff --git a/engine/evd.mli b/engine/evd.mli index 679173ca72..d338b06e0e 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -89,6 +89,15 @@ module Abstraction : sig val abstract_last : t -> t end +module Identity : +sig + type t + (** Identity substitutions *) + + val make : econstr list -> t + val none : unit -> t +end + (** {6 Evar infos} *) type evar_body = @@ -114,6 +123,9 @@ type evar_info = { (** Information about the evar. *) evar_candidates : econstr list option; (** List of possible solutions when known that it is a finite list *) + evar_identity : Identity.t; + (** Default evar instance, i.e. a list of Var nodes projected from the + filtered environment. *) } val make_evar : named_context_val -> etypes -> evar_info @@ -127,6 +139,7 @@ val evar_candidates : evar_info -> constr list option val evar_filter : evar_info -> Filter.t val evar_env : env -> evar_info -> env val evar_filtered_env : env -> evar_info -> env +val evar_identity_subst : evar_info -> econstr list val map_evar_body : (econstr -> econstr) -> evar_body -> evar_body val map_evar_info : (econstr -> econstr) -> evar_info -> evar_info @@ -643,8 +656,6 @@ val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val fix_undefined_variables : evar_map -> evar_map -val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst - (** Universe minimization *) val minimize_universes : evar_map -> evar_map diff --git a/engine/proofview.ml b/engine/proofview.ml index de38104ecd..fd8512d73e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1032,6 +1032,9 @@ module Unsafe = struct let mark_as_unresolvables p evs = { p with solution = mark_in_evm ~goal:false p.solution evs } + let update_sigma_env pv env = + { pv with solution = Evd.update_sigma_env pv.solution env } + end module UnsafeRepr = Proof.Unsafe diff --git a/engine/proofview.mli b/engine/proofview.mli index d0a2b37a69..0f49d2f5d8 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -503,6 +503,9 @@ module Unsafe : sig val undefined : Evd.evar_map -> Proofview_monad.goal_with_state list -> Proofview_monad.goal_with_state list + (** [update_sigma_env] lifts [Evd.update_sigma_env] to the proofview *) + val update_sigma_env : proofview -> Environ.env -> proofview + end (** This module gives access to the innards of the monad. Its use is diff --git a/engine/uState.ml b/engine/uState.ml index d4cb59da26..ca0a21acf7 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -718,35 +718,6 @@ let fix_undefined_variables uctx = { uctx with univ_variables = vars'; univ_algebraic = algs' } -let refresh_undefined_univ_variables uctx = - let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.local in - let subst_fn u = subst_univs_level_level subst u in - let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) - uctx.univ_algebraic LSet.empty - in - let vars = - LMap.fold - (fun u v acc -> - LMap.add (subst_fn u) - (Option.map (subst_univs_level_universe subst) v) acc) - uctx.univ_variables LMap.empty - in - let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.weak_constraints UPairSet.empty in - let lbound = uctx.universes_lbound in - let declare g = LSet.fold (fun u g -> UGraph.add_universe u ~lbound ~strict:false g) - (ContextSet.levels ctx') g in - let initial = declare uctx.initial_universes in - let univs = declare UGraph.initial_universes in - let uctx' = {names = uctx.names; - local = ctx'; - seff_univs = uctx.seff_univs; - univ_variables = vars; univ_algebraic = alg; - universes = univs; - universes_lbound = lbound; - initial_universes = initial; - weak_constraints = weak; } in - uctx', subst - let minimize uctx = let open UnivMinim in let lbound = uctx.universes_lbound in diff --git a/engine/uState.mli b/engine/uState.mli index 45a0f9964e..607c6c9452 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -154,8 +154,6 @@ val abstract_undefined_variables : t -> t val fix_undefined_variables : t -> t -val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst - (** Universe minimization *) val minimize : t -> t diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index 57cdccce6d..0e237b74fe 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -544,6 +544,7 @@ struct let coercions = BoolOpt ["Printing"; "Coercions"] let raw_matching = BoolOpt ["Printing"; "Matching"] let notations = BoolOpt ["Printing"; "Notations"] + let parentheses = BoolOpt ["Printing"; "Parentheses"] let all_basic = BoolOpt ["Printing"; "All"] let existential = BoolOpt ["Printing"; "Existential"; "Instances"] let universes = BoolOpt ["Printing"; "Universes"] @@ -558,7 +559,7 @@ struct { opts = [raw_matching]; init = true; label = "Display raw _matching expressions" }; { opts = [notations]; init = true; label = "Display _notations" }; - { opts = [notations]; init = true; label = "Display _parentheses" }; + { opts = [parentheses]; init = true; label = "Display _parentheses" }; { opts = [all_basic]; init = false; label = "Display _all basic low-level contents" }; { opts = [existential]; init = false; diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 6d4ab8b4d6..1d3b1bbb24 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1724,8 +1724,7 @@ let drop_notations_pattern looked_for genv = the domains of lambdas in the encoding of match in constr. This check is here and not in the parser because it would require duplicating the levels of the [pattern] rule. *) - CErrors.user_err ?loc ~hdr:"drop_notations_pattern" - (Pp.strbrk "Casts are not supported in this pattern.") + CErrors.user_err ?loc (Pp.strbrk "Casts are not supported in this pattern.") and in_pat_sc scopes x = in_pat false (x,snd scopes) and in_not top loc scopes (subst,substlist as fullsubst) args = function | NVar id -> diff --git a/interp/impargs.ml b/interp/impargs.ml index db102470b0..48961c6c8a 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -20,7 +20,6 @@ open Lib open Libobject open EConstr open Reductionops -open Namegen open Constrexpr module NamedDecl = Context.Named.Declaration @@ -247,24 +246,15 @@ let is_rigid env sigma t = is_rigid_head sigma t | _ -> true -let find_displayed_name_in sigma all avoid na (env, b) = - let envnames_b = (env, b) in - let flag = RenamingElsewhereFor envnames_b in - if all then compute_and_force_displayed_name_in sigma flag avoid na b - else compute_displayed_name_in sigma flag avoid na b - -let compute_implicits_names_gen all env sigma t = +let compute_implicits_names env sigma t = let open Context.Rel.Declaration in - let rec aux env avoid names t = + let rec aux env names t = let t = whd_all env sigma t in match kind sigma t with | Prod (na,a,b) -> - let na',avoid' = find_displayed_name_in sigma all avoid na.Context.binder_name (names,b) in - aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b + aux (push_rel (LocalAssum (na,a)) env) (na.Context.binder_name::names) b | _ -> List.rev names - in aux env Id.Set.empty [] t - -let compute_implicits_names = compute_implicits_names_gen true + in aux env [] t let compute_implicits_explanation_gen strict strongly_strict revpat contextual env sigma t = let open Context.Rel.Declaration in @@ -291,9 +281,9 @@ let compute_implicits_explanation_flags env sigma f t = (f.strict || f.strongly_strict) f.strongly_strict f.reversible_pattern f.contextual env sigma t -let compute_implicits_flags env sigma f all t = +let compute_implicits_flags env sigma f t = List.combine - (compute_implicits_names_gen all env sigma t) + (compute_implicits_names env sigma t) (compute_implicits_explanation_flags env sigma f t) let compute_auto_implicits env sigma flags enriching t = @@ -361,10 +351,10 @@ let positions_of_implicits (_,impls) = let rec prepare_implicits i f = function | [] -> [] - | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") - | (Name id, Some imp)::imps -> + | (na, Some imp)::imps -> let imps' = prepare_implicits (i+1) f imps in - Some (ExplByName id,imp,(set_maximality Silent (Name id) i imps' f.maximal,true)) :: imps' + let expl = match na with Name id -> ExplByName id | Anonymous -> ExplByPos (i,None) in + Some (expl,imp,(set_maximality Silent na i imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits (i+1) f imps let set_manual_implicits silent flags enriching autoimps l = @@ -393,7 +383,7 @@ let set_manual_implicits silent flags enriching autoimps l = let compute_semi_auto_implicits env sigma f t = if not f.auto then [DefaultImpArgs, []] - else let l = compute_implicits_flags env sigma f false t in + else let l = compute_implicits_flags env sigma f t in [DefaultImpArgs, prepare_implicits 1 f l] (*s Constants. *) diff --git a/kernel/environ.ml b/kernel/environ.ml index e75ccbb252..03c9cb4be6 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -87,6 +87,7 @@ let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) type named_context_val = { env_named_ctx : Constr.named_context; env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; + env_named_var : Constr.t list; } type rel_context_val = { @@ -109,6 +110,7 @@ type env = { let empty_named_context_val = { env_named_ctx = []; env_named_map = Id.Map.empty; + env_named_var = []; } let empty_rel_context_val = { @@ -183,6 +185,7 @@ let push_named_context_val_val d rval ctxt = { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; + env_named_var = mkVar (NamedDecl.get_id d) :: ctxt.env_named_var; } let push_named_context_val d ctxt = @@ -193,7 +196,7 @@ let match_named_context_val c = match c.env_named_ctx with | decl :: ctx -> let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in - let cval = { env_named_ctx = ctx; env_named_map = map } in + let cval = { env_named_ctx = ctx; env_named_map = map; env_named_var = List.tl c.env_named_var } in Some (decl, v, cval) let map_named_val f ctxt = @@ -208,7 +211,7 @@ let map_named_val f ctxt = in let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in if map == ctxt.env_named_map then ctxt - else { env_named_ctx = ctx; env_named_map = map } + else { env_named_ctx = ctx; env_named_map = map; env_named_var = ctxt.env_named_var } let push_named d env = {env with env_named_context = push_named_context_val d env.env_named_context} diff --git a/kernel/environ.mli b/kernel/environ.mli index 5cb56a2a29..974e794c6b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -69,6 +69,11 @@ type stratification = { type named_context_val = private { env_named_ctx : Constr.named_context; env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; + (** Identifier-indexed version of [env_named_ctx] *) + env_named_var : Constr.t list; + (** List of identifiers in [env_named_ctx], in the same order, including + let-ins. This is not used in the kernel, but is critical to preserve + sharing of evar instances in the proof engine. *) } type rel_context_val = private { diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 0754e9d4cc..7c6b869b4a 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -234,6 +234,8 @@ let sort_cmp_universes env pb s0 s1 (u, check) = let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' s, check) +exception MustExpand + let get_cumulativity_constraints cv_pb variance u u' = match cv_pb with | CONV -> @@ -251,7 +253,8 @@ let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 | Some variances -> let num_param_arity = inductive_cumulativity_arguments (mind,ind) in if not (Int.equal num_param_arity nargs) then - cmp_instances u1 u2 s + (* shortcut, not sure if worth doing, could use perf data *) + if Univ.Instance.equal u1 u2 then s else raise MustExpand else cmp_cumul cv_pb variances u1 u2 s @@ -269,7 +272,7 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u | Some _ -> 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 + if Univ.Instance.equal u1 u2 then s else raise MustExpand else (** By invariant, both constructors have a common supertype, so they are convertible _at that type_. *) @@ -336,6 +339,28 @@ let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false +let identity_of_ctx (ctx:Constr.rel_context) = + Context.Rel.to_extended_vect mkRel 0 ctx + +(* ind -> fun args => ind args *) +let eta_expand_ind env (ind,u as pind) = + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let ctx = Vars.subst_instance_context u mip.mind_arity_ctxt in + let args = identity_of_ctx ctx in + let c = mkApp (mkIndU pind, args) in + let c = Term.it_mkLambda_or_LetIn c ctx in + inject c + +let eta_expand_constructor env ((ind,ctor),u as pctor) = + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let ctx = Vars.subst_instance_context u (fst mip.mind_nf_lc.(ctor-1)) in + let args = identity_of_ctx ctx in + let c = mkApp (mkConstructU pctor, args) in + let c = Term.it_mkLambda_or_LetIn c ctx in + inject c + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -545,7 +570,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = end (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd (ind1,u1), FInd (ind2,u2)) -> + | (FInd (ind1,u1 as pind1), FInd (ind2,u2 as pind2)) -> if eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in @@ -556,11 +581,16 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = 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 + match convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_ind env pind1 in + let hd2 = eta_expand_ind env pind2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible - | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> + | (FConstruct ((ind1,j1),u1 as pctor1), FConstruct ((ind2,j2),u2 as pctor2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in @@ -571,8 +601,13 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = 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 + match convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_constructor env pctor1 in + let hd2 = eta_expand_constructor env pctor2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible (* Eta expansion of records *) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 4a41f4c890..d215a7673d 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -604,6 +604,13 @@ let pp_global k r = | Haskell -> if modular () then pp_haskell_gen k mp rls else s | Ocaml -> pp_ocaml_gen k mp rls (Some l) +(* Main name printing function for declaring a reference *) + +let pp_global_name k r = + let ls = ref_renaming (k,r) in + assert (List.length ls > 1); + List.hd ls + (* The next function is used only in Ocaml extraction...*) let pp_module mp = diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 0bd9efd255..a482cfc03d 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -55,6 +55,7 @@ val opened_libraries : unit -> ModPath.t list type kind = Term | Type | Cons | Mod val pp_global : kind -> GlobRef.t -> string +val pp_global_name : kind -> GlobRef.t -> string val pp_module : ModPath.t -> string val top_visible_mp : unit -> ModPath.t diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 088405da5d..6425c3111e 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -99,6 +99,8 @@ let str_global k r = let pp_global k r = str (str_global k r) +let pp_global_name k r = str (Common.pp_global k r) + let pp_modname mp = str (Common.pp_module mp) (* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *) @@ -451,7 +453,7 @@ let pp_val e typ = let pp_Dfix (rv,c,t) = let names = Array.map - (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + (fun r -> if is_inline_custom r then mt () else pp_global_name Term r) rv in let rec pp init i = if i >= Array.length rv then mt () @@ -504,7 +506,7 @@ let pp_logical_ind packet = fnl () let pp_singleton kn packet = - let name = pp_global Type (GlobRef.IndRef (kn,0)) in + let name = pp_global_name Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -513,7 +515,7 @@ let pp_singleton kn packet = let pp_record kn fields ip_equiv packet = let ind = GlobRef.IndRef (kn,0) in - let name = pp_global Type ind in + let name = pp_global_name Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in @@ -535,7 +537,7 @@ let pp_ind co kn ind = let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (GlobRef.IndRef (kn,i))) + pp_global_name Type (GlobRef.IndRef (kn,i))) ind.ind_packets in let cnames = @@ -575,7 +577,7 @@ let pp_decl = function | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> - let name = pp_global Type r in + let name = pp_global_name Type r in let l = rename_tvars keywords l in let ids, def = try @@ -592,7 +594,7 @@ let pp_decl = function if is_custom r then str (" = " ^ find_custom r) else pp_function (empty_env ()) a in - let name = pp_global Term r in + let name = pp_global_name Term r in pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ mt ()) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) @@ -603,10 +605,10 @@ let pp_spec = function | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in - let name = pp_global Term r in + let name = pp_global_name Term r in hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) | Stype (r,vl,ot) -> - let name = pp_global Type r in + let name = pp_global_name Type r in let l = rename_tvars keywords vl in let ids, def = try diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index fdebe14a23..2ca9a0e69d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -161,27 +161,45 @@ let catching_error call_trace fail (e, info) = fail located_exc end -let update_loc ?loc (e, info) = - (e, Option.cata (Loc.add_loc info) info loc) +let update_loc loc use_finer (e, info as e') = + match loc with + | Some loc -> + if use_finer then + (* ensure loc if there is none *) + match Loc.get_loc info with + | None -> (e, Loc.add_loc info loc) + | _ -> (e, info) + else + (* override loc (because loc refers to inside of Ltac functions) *) + (e, Loc.add_loc info loc) + | None -> e' -let catch_error ?loc call_trace f x = +let catch_error_with_trace_loc loc use_finer call_trace f x = try f x with e when CErrors.noncritical e -> let e = Exninfo.capture e in - let e = update_loc ?loc e in + let e = update_loc loc use_finer e in catching_error call_trace Exninfo.iraise e -let catch_error_loc ?loc tac = - Proofview.tclOR tac (fun exn -> - let (e, info) = update_loc ?loc exn in +let catch_error_loc loc use_finer tac = + Proofview.tclORELSE tac (fun exn -> + let (e, info) = update_loc loc use_finer exn in Proofview.tclZERO ~info e) -let wrap_error ?loc tac k = +let wrap_error tac k = + if is_traced () then Proofview.tclORELSE tac k else tac + +let wrap_error_loc loc use_finer tac k = if is_traced () then Proofview.tclORELSE tac k - else catch_error_loc ?loc tac + else catch_error_loc loc use_finer tac + +let catch_error_tac call_trace tac = + wrap_error + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) -let catch_error_tac ?loc call_trace tac = - wrap_error ?loc +let catch_error_tac_loc loc use_finer call_trace tac = + wrap_error_loc loc use_finer tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -553,7 +571,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let loc = loc_of_glob_constr term in let trace = push_trace (loc,LtacConstrInterp (term,vars)) ist in let (evd,c) = - catch_error ?loc trace (understand_ltac flags env sigma vars kind) term + catch_error_with_trace_loc loc true trace (understand_ltac flags env sigma vars kind) term in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess @@ -1066,12 +1084,12 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) -and eval_tactic ist tac : unit Proofview.tactic = match tac with +and eval_tactic_ist ist tac : unit Proofview.tactic = match tac with | TacAtom {loc;v=t} -> let call = LtacAtomCall t in let trace = push_trace(loc,call) ist in Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac ?loc trace (interp_atomic ist t)) + (catch_error_tac_loc loc true trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> @@ -1145,7 +1163,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg a -> interp_tactic ist (TacArg a) + | TacArg a -> Ftactic.run (val_interp ist tac) (fun v -> catch_error_loc a.CAst.loc false (tactic_of_value ist v)) | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> @@ -1162,7 +1180,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with ; poly ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> - Ftactic.lift (catch_error_loc ?loc (tactic_of_value ist v)) + Ftactic.lift (catch_error_loc loc false (tactic_of_value ist v)) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> @@ -1191,7 +1209,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac ?loc trace (tac args ist)) + Proofview.Trace.name_tactic name (catch_error_tac_loc loc false trace (tac args ist)) in Ftactic.run args tac @@ -1225,7 +1243,7 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false - (val_interp ~appl ist (Tacenv.interp_ltac r)) + (catch_error_tac_loc loc false trace (val_interp ~appl ist (Tacenv.interp_ltac r))) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1294,7 +1312,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac ?loc trace (val_interp ist body)) >>= fun v -> + (catch_error_tac_loc loc false trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1341,7 +1359,7 @@ and tactic_of_value ist vle = lfun = lfun; poly; extra = TacStore.set ist.extra f_trace []; } in - let tac = name_if_glob appl (eval_tactic ist t) in + let tac = name_if_glob appl (eval_tactic_ist ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) | VFun (appl,_,vmap,vars,_) -> let tactic_nm = @@ -1428,7 +1446,7 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = ; poly ; extra = TacStore.set ist.extra f_trace trace } in - let tac = eval_tactic ist t in + let tac = eval_tactic_ist ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) | _ -> Ftactic.return v @@ -1909,11 +1927,11 @@ let default_ist () = let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) Proofview.tclLIFT db_initialize <*> - interp_tactic (default_ist ()) t + eval_tactic_ist (default_ist ()) t let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> - interp_tactic ist t + eval_tactic_ist ist t (** FFI *) @@ -1959,7 +1977,7 @@ let interp_tac_gen lfun avoid_ids debug t = let extra = TacStore.set extra f_avoid_ids avoid_ids in let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in - interp_tactic ist + eval_tactic_ist ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) end @@ -2076,7 +2094,7 @@ let () = register_interp0 wit_tactic interp let () = - let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + let interp ist tac = eval_tactic_ist ist tac >>= fun () -> Ftactic.return () in register_interp0 wit_ltac interp let () = @@ -2103,7 +2121,7 @@ let _ = let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in - let tac = interp_tactic ist tac in + let tac = eval_tactic_ist ist tac in (* EJGA: We should also pass the proof name if desired, for now poly seems like enough to get reasonable behavior in practice *) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9eeba614c7..148c1772bf 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1020,10 +1020,11 @@ let lia (can_enum : bool) (prfdepth : int) sys = p) sys end; + let bnd1 = bound_monomials sys in let sys = subst sys in - let bnd = bound_monomials sys in + let bnd2 = bound_monomials sys in (* To deal with non-linear monomials *) - let sys = bnd @ saturate_by_linear_equalities sys @ sys in + let sys = bnd1 @ bnd2 @ saturate_by_linear_equalities sys @ sys in let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 4e1f9a66ac..fa29e6080e 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -1324,9 +1324,14 @@ let do_let tac (h : Constr.named_declaration) = let env = Tacmach.New.pf_env gl in let evd = Tacmach.New.project gl in try - ignore (get_injection env evd (EConstr.of_constr ty)); - tac id.Context.binder_name (EConstr.of_constr t) - (EConstr.of_constr ty) + let x = id.Context.binder_name in + ignore + (let eq = Lazy.force eq in + find_option + (match_operator env evd eq + [|EConstr.of_constr ty; EConstr.mkVar x; EConstr.of_constr t|]) + (HConstr.find_all eq !table_cache)); + tac x (EConstr.of_constr t) (EConstr.of_constr ty) with Not_found -> Tacticals.New.tclIDTAC) let iter_let_aux tac = diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 1b7768852e..d859fe51ab 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1047,7 +1047,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc = let uct = Evd.evar_universe_context (fst oc) in let n, oc = abs_evars_pirrel env sigma (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in Proofview.Unsafe.tclEVARS (Evd.set_universe_context sigma uct) <*> - Proofview.tclOR (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) + Proofview.tclORELSE (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) (fun _ -> Proofview.tclZERO dependent_apply_error) end @@ -1352,7 +1352,7 @@ let unsafe_intro env decl b = Refine.refine ~typecheck:false begin fun sigma -> let ctx = Environ.named_context_val env in let nctx = EConstr.push_named_context_val decl ctx in - let inst = List.map (get_id %> EConstr.mkVar) (Environ.named_context env) in + let inst = EConstr.identity_subst_val (Environ.named_context_val env) in let ninst = EConstr.mkRel 1 :: inst in let nb = EConstr.Vars.subst1 (EConstr.mkVar (get_id decl)) b in let sigma, ev = Evarutil.new_pure_evar ~principal:true nctx sigma nb in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 1c81fbc10b..1e182b52fa 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -485,17 +485,22 @@ let revtoptac n0 = Logic.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) end -let equality_inj l b id c = - Proofview.V82.tactic begin fun gl -> - let msg = ref "" in - try Proofview.V82.of_tactic (Equality.inj None l b None c) gl - with - | CErrors.UserError (_,s) - when msg := Pp.string_of_ppcmds s; - !msg = "Not a projectable equality but a discriminable one." || - !msg = "Nothing to inject." -> - Feedback.msg_warning (Pp.str !msg); - discharge_hyp (id, (id, "")) gl +let nothing_to_inject = + CWarnings.create ~name:"spurious-ssr-injection" ~category:"ssr" + (fun (sigma, env, ty) -> + Pp.(str "SSReflect: cannot obtain new equations out of" ++ fnl() ++ + str" " ++ Printer.pr_econstr_env env sigma ty ++ fnl() ++ + str "Did you write an extra [] in the intro pattern?")) + +let equality_inj l b id c = Proofview.Goal.enter begin fun gl -> + Proofview.tclORELSE (Equality.inj None l b None c) + (function + | (Equality.NothingToInject,_) -> + let open Proofview.Notations in + Ssrcommon.tacTYPEOF (EConstr.mkVar id) >>= fun ty -> + nothing_to_inject (Proofview.Goal.sigma gl, Proofview.Goal.env gl, ty); + Proofview.V82.tactic (discharge_hyp (id, (id, ""))) + | (e,info) -> Proofview.tclZERO ~info e) end let injectidl2rtac id c = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index da623703a2..38b26d06b9 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -465,7 +465,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr = Tactics.apply_type ~typecheck:true cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], Tacticals.New.tclTHENLIST (itacs @ rwtacs), sigma0 in let cvtac' = - Proofview.tclOR cvtac begin function + Proofview.tclORELSE cvtac begin function | (PRtype_error e, _) -> let error = Option.cata (fun (env, sigma, te) -> Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 2c7b689c04..2661000a39 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -397,6 +397,10 @@ and apply_env env t = | _ -> map_with_binders subs_lift apply_env env t +let rec strip_app = function + | APP (args,st) -> APP (args,strip_app st) + | s -> TOP + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -442,7 +446,7 @@ let rec norm_head info env t stack = | Const sp -> Reductionops.reduction_effect_hook info.env info.sigma - (fst sp) (lazy (reify_stack t stack)); + (fst sp) (lazy (reify_stack t (strip_app stack))); norm_head_ref 0 info env stack (ConstKey sp) t | LetIn (_, b, _, c) -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2feae8cc25..489e8de602 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1352,9 +1352,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = List.map (nf_evar evd) args in - let vars = List.map NamedDecl.get_id ctxt in - let argsubst = List.map2 (fun id c -> (id, c)) vars args in - let instance = List.map mkVar vars in + let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in + let instance = evar_identity_subst evi in let rhs = nf_evar evd rhs in if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); (* Ensure that any progress made by Typing.e_solve_evars will not contradict diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 79839099f7..989fb05c3d 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -216,9 +216,6 @@ type 'a update = | UpdateWith of 'a | NoUpdate -open Context.Named.Declaration -let inst_of_vars sign = List.map (get_id %> mkVar) sign - let restrict_evar_key evd evk filter candidates = match filter, candidates with | None, NoUpdate -> evd, evk @@ -701,8 +698,7 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si let (evd, evk) = new_pure_evar sign evd ty_t_in_sign ~filter ~src in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (evk, inst_in_env) t_in_env in - let ctxt = named_context_of_val sign in - let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in + let inst_in_sign = evar_identity_subst (Evd.find evd evk) in let evar_in_sign = mkEvar (evk, inst_in_sign) in (evd,whd_evar evd evar_in_sign) @@ -735,9 +731,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let sign1 = evar_hyps evi1 in let filter1 = evar_filter evi1 in let src = subterm_source evk1 evi1.evar_source in - let ids1 = List.map get_id (named_context_of_val sign1) in let avoid = Environ.ids_of_named_context_val sign1 in - let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in + let inst_in_sign = evar_identity_subst evi1 in let open Context.Rel.Declaration in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 81a62a7048..34fae613bf 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -33,8 +33,6 @@ type t = { (** For locating indices *) renamed_env : env; (** For name management *) - renamed_vars : EConstr.t list Lazy.t; - (** Identity instance of named_context of renamed_env, to maximize sharing *) extra : ext_named_context Lazy.t; (** Delay the computation of the evar extended environment *) lvar : ltac_var_map; @@ -45,11 +43,9 @@ let make ~hypnaming env sigma lvar = let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ~hypnaming sigma d acc) (rel_context env) ~init:(empty_csubst, avoid, named_context_val env) in - let open Context.Named.Declaration in { static_env = env; renamed_env = env; - renamed_vars = lazy (List.map (get_id %> mkVar) (named_context env)); extra = lazy (get_extra env sigma); lvar = lvar; } @@ -76,7 +72,6 @@ let push_rel ~hypnaming sigma d env = let env = { static_env = push_rel d env.static_env; renamed_env = push_rel d' env.renamed_env; - renamed_vars = env.renamed_vars; extra = lazy (push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d' (Lazy.force env.extra)); lvar = env.lvar; } in @@ -89,7 +84,6 @@ let push_rel_context ~hypnaming ?(force_names=false) sigma ctx env = let env = { static_env = push_rel_context ctx env.static_env; renamed_env = push_rel_context ctx' env.renamed_env; - renamed_vars = env.renamed_vars; extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d acc) ctx' (Lazy.force env.extra)); lvar = env.lvar; } in @@ -102,7 +96,7 @@ let push_rec_types ~hypnaming sigma (lna,typarray) env = Array.map get_annot ctx, env let new_evar env sigma ?src ?naming typ = - let lazy inst_vars = env.renamed_vars in + let inst_vars = EConstr.identity_subst_val (named_context_val env.renamed_env) in let rec rel_list n accu = if n <= 0 then accu else rel_list (n - 1) (mkRel n :: accu) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index fdc770dba6..aeb18ec322 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -499,13 +499,6 @@ let beta_applist sigma (c,l) = (* Iota reduction tools *) -type 'a miota_args = { - mP : constr; (* the result type *) - mconstr : constr; (* the constructor *) - mci : case_info; (* special info to re-build pattern *) - mcargs : 'a list; (* the constructor's arguments *) - mlf : 'a array } (* the branch code vector *) - let reducible_mind_case sigma c = match EConstr.kind sigma c with | Construct _ | CoFix _ -> true | _ -> false @@ -514,10 +507,7 @@ let contract_cofix sigma (bodynum,(names,types,bodies as typedbodies)) = let nbodies = Array.length bodies in let make_Fi j = let ind = nbodies-j-1 in - if Int.equal bodynum ind then mkCoFix (ind,typedbodies) - else - let bd = mkCoFix (ind,typedbodies) in - bd + mkCoFix (ind,typedbodies) in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -530,18 +520,6 @@ let reduce_and_refold_cofix recfun env sigma cofix sk = (fun _ (t,sk') -> recfun (t,sk')) [] sigma raw_answer sk -let reduce_mind_case sigma mia = - match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) - let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1),real_cargs) - | CoFix cofix -> - let cofix_def = contract_cofix sigma cofix in - (* XXX Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) - | _ -> assert false - (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) @@ -549,10 +527,7 @@ let contract_fix sigma ((recindices,bodynum),(names,types,bodies as typedbodies) let nbodies = Array.length recindices in let make_Fi j = let ind = nbodies-j-1 in - if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies) - else - let bd = mkFix ((recindices,ind),typedbodies) in - bd + mkFix ((recindices,ind),typedbodies) in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -757,7 +732,7 @@ let rec whd_state_gen flags env sigma = | None -> fold ()) | Const (c,u as const) -> reduction_effect_hook env sigma c - (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); + (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,fst (Stack.strip_app stack))))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in match constant_value_in env (c, u') with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 0f288cdd46..d404a7e414 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -217,22 +217,14 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr (** Raises [Invalid_argument] *) - -type 'a miota_args = { - mP : constr; (** the result type *) - mconstr : constr; (** the constructor *) - mci : case_info; (** special info to re-build pattern *) - mcargs : 'a list; (** the constructor's arguments *) - mlf : 'a array } (** the branch code vector *) - val reducible_mind_case : evar_map -> constr -> bool -val reduce_mind_case : evar_map -> constr miota_args -> constr val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) kind_of_term val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool val contract_fix : evar_map -> fixpoint -> constr +val contract_cofix : evar_map -> cofixpoint -> constr (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) val is_transparent : Environ.env -> Constant.t tableKey -> bool diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index e4b5dc1edf..9d15e98373 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -458,6 +458,25 @@ let contract_cofix_use_function env sigma f substl_checking_arity env (List.rev subbodies) sigma (nf_beta env sigma bodies.(bodynum)) +type 'a miota_args = { + mP : constr; (** the result type *) + mconstr : constr; (** the constructor *) + mci : case_info; (** special info to re-build pattern *) + mcargs : 'a list; (** the constructor's arguments *) + mlf : 'a array } (** the branch code vector *) + +let reduce_mind_case sigma mia = + match EConstr.kind sigma mia.mconstr with + | Construct ((ind_sp,i),u) -> +(* let ncargs = (fst mia.mci).(i-1) in*) + let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1),real_cargs) + | CoFix cofix -> + let cofix_def = contract_cofix sigma cofix in + (* XXX Is NoInvert OK here? *) + mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 9bd7ccda5d..db76d08736 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -47,16 +47,6 @@ let clenv_meta_type clenv mv = Typing.meta_type clenv.env clenv.evd mv let clenv_value clenv = meta_instance clenv.env clenv.evd clenv.templval let clenv_type clenv = meta_instance clenv.env clenv.evd clenv.templtyp -let refresh_undefined_univs clenv = - match EConstr.kind clenv.evd clenv.templval.rebus with - | Var _ -> clenv, Univ.empty_level_subst - | App (f, args) when isVar clenv.evd f -> clenv, Univ.empty_level_subst - | _ -> - let evd', subst = Evd.refresh_undefined_universes clenv.evd in - let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in - { clenv with evd = evd'; templval = map_freelisted clenv.templval; - templtyp = map_freelisted clenv.templtyp }, subst - let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c diff --git a/proofs/clenv.mli b/proofs/clenv.mli index fd1e2fe593..43e808dac7 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -45,9 +45,6 @@ val mk_clenv_from_n : Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv -(** Refresh the universes in a clenv *) -val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst - (** {6 linking of clenvs } *) val clenv_fchain : diff --git a/proofs/goal.ml b/proofs/goal.ml index beeaa60433..1c3aed8fc2 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Pp module NamedDecl = Context.Named.Declaration @@ -58,12 +57,11 @@ module V82 = struct goals are restored to their initial value after the evar is created. *) let prev_future_goals = Evd.save_future_goals evars in + let inst = EConstr.identity_subst_val hyps in let (evars, evk) = - Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false hyps evars concl + Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false ~identity:inst hyps evars concl in let evars = Evd.restore_future_goals evars prev_future_goals in - let ctxt = Environ.named_context_of_val hyps in - let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) diff --git a/proofs/proof.ml b/proofs/proof.ml index a183fa7797..38fcdd6e5f 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -356,6 +356,10 @@ let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in { p with proofview; entry } +let update_sigma_env p env = + let proofview = Proofview.Unsafe.update_sigma_env p.proofview env in + { p with proofview } + (*** Function manipulation proof extra informations ***) (*** Tactics ***) diff --git a/proofs/proof.mli b/proofs/proof.mli index 0e5bdaf07d..2d4966676e 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -78,6 +78,9 @@ val partial_proof : t -> EConstr.constr list val compact : t -> t +(** [update_sigma_env] lifts [Evd.update_sigma_env] to the proof *) +val update_sigma_env : t -> Environ.env -> t + (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. Raises [HasShelvedGoals] if some goals are left on the shelf. diff --git a/tactics/auto.ml b/tactics/auto.ml index 3287c1c354..784322679f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -12,11 +12,9 @@ open Pp open Util open Names open Termops -open EConstr open Environ open Genredexpr open Tactics -open Clenv open Locus open Proofview.Notations open Hints @@ -69,38 +67,7 @@ let auto_unif_flags = (* Try unification with the precompiled clause, then use registered Apply *) -let connect_hint_clenv h gl = - let { hint_term = c; hint_uctx = ctx; hint_clnv = clenv } = h in - (* [clenv] has been generated by a hint-making function, so the only relevant - data in its evarmap is the set of metas. The [evar_reset_evd] function - below just replaces the metas of sigma by those coming from the clenv. *) - let sigma = Tacmach.New.project gl in - let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in - (* Still, we need to update the universes *) - let clenv, c = - if h.hint_poly then - (* Refresh the instance of the hint *) - let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in - let emap c = Vars.subst_univs_level_constr subst c in - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - (* Only metas are mentioning the old universes. *) - let clenv = { - templval = Evd.map_fl emap clenv.templval; - templtyp = Evd.map_fl emap clenv.templtyp; - evd = Evd.map_metas emap evd; - env = Proofview.Goal.env gl; - } in - clenv, emap c - else - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - { clenv with evd = evd ; env = Proofview.Goal.env gl }, c - in clenv, c - -let unify_resolve flags (h : hint) = - Proofview.Goal.enter begin fun gl -> - let clenv, c = connect_hint_clenv h gl in - Clenv.res_pf ~flags clenv - end +let unify_resolve flags h = Hints.hint_res_pf ~flags h let unify_resolve_nodelta h = unify_resolve auto_unif_flags h @@ -110,10 +77,10 @@ let unify_resolve_gen = function let exact h = Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (exact_check c) + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, c = Hints.fresh_hint env sigma h in + Proofview.Unsafe.tclEVARS sigma <*> exact_check c end (* Util *) @@ -299,7 +266,7 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of TransparentState.full st -let hintmap_of sigma secvars hdc concl = +let hintmap_of env sigma secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> @@ -307,7 +274,7 @@ let hintmap_of sigma secvars hdc concl = (fun db -> match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> []) - else Hint_db.map_auto sigma ~secvars hdc concl + else Hint_db.map_auto env sigma ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -333,23 +300,24 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) + (trivial_resolve env sigma dbg mod_delta db_list local_db secvars concl))) end -and my_find_search_nodelta sigma db_list local_db secvars hdc concl = +and my_find_search_nodelta env sigma db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of sigma secvars hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of env sigma secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta sigma db_list local_db secvars hdc concl = - let f = hintmap_of sigma secvars hdc concl in +and my_find_search_delta env sigma db_list local_db secvars hdc concl = + let f = hintmap_of env sigma secvars hdc concl in if occur_existential sigma concl then List.map_append (fun db -> @@ -373,7 +341,7 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = | None -> Hint_db.map_none ~secvars db | Some hdc -> if TransparentState.is_empty st - then Hint_db.map_auto sigma ~secvars hdc concl db + then Hint_db.map_auto env sigma ~secvars hdc concl db else match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> [] @@ -402,8 +370,7 @@ and tac_of_hint dbg db_list local_db concl (flags, h) = let info = Exninfo.reify () in Tacticals.New.tclFAIL ~info 0 (str"Unbound reference") end - | Extern tacast -> - let p = FullHint.pattern h in + | Extern (p, tacast) -> conclPattern concl p tacast in let pr_hint env sigma = @@ -415,7 +382,7 @@ and tac_of_hint dbg db_list local_db concl (flags, h) = in tclLOG dbg pr_hint (FullHint.run h tactic) -and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = +and trivial_resolve env sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in @@ -424,7 +391,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta sigma db_list local_db secvars head cl)) + (my_find_search mod_delta env sigma db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -464,7 +431,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = +let possible_resolve env sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in @@ -472,7 +439,7 @@ let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta sigma db_list local_db secvars head cl) + (my_find_search mod_delta env sigma db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -507,12 +474,13 @@ let search d n mod_delta db_list local_db = ( Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve sigma d mod_delta db_list local_db secvars concl)) + (possible_resolve env sigma d mod_delta db_list local_db secvars concl)) end)) end [] in diff --git a/tactics/auto.mli b/tactics/auto.mli index 903da143d2..bc2eee0e4c 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -12,7 +12,6 @@ open Names open EConstr -open Clenv open Pattern open Hints open Tactypes @@ -23,9 +22,6 @@ val default_search_depth : int ref val auto_flags_of_state : TransparentState.t -> Unification.unify_flags -val connect_hint_clenv - : hint -> Proofview.Goal.t -> clausenv * constr - (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : Unification.unify_flags -> hint -> unit Proofview.tactic diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index bb062bfc11..bacb5a7b8f 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -49,17 +49,25 @@ let decomp sigma t = in decrec [] t -let constr_val_discr sigma t = +let evaluable_constant c env = + (* This is a hack to work around a broken Print Module implementation, see + bug #2668. *) + if Environ.mem_constant c env then Environ.evaluable_constant c env + else true + +let constr_val_discr env sigma t = let open GlobRef in let c, l = decomp sigma t in match EConstr.kind sigma c with | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) - | Const _ -> Everything + | Const (c, _) -> + if evaluable_constant c env then Everything + else Label(GRLabel (ConstRef c),l) | _ -> Nothing -let constr_pat_discr t = +let constr_pat_discr env t = if not (Patternops.occur_meta_pattern t) then None else @@ -68,16 +76,23 @@ let constr_pat_discr t = | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | PRef ((ConstRef c) as ref), args -> + if evaluable_constant c env then None + else Some (GRLabel ref, args) | _ -> None -let constr_val_discr_st sigma ts t = +let constr_val_discr_st env sigma ts t = let c, l = decomp sigma t in let open GlobRef in match EConstr.kind sigma c with - | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) + | Const (c,u) -> + if evaluable_constant c env && TransparentState.is_transparent_constant ts c then Everything + else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id -> if TransparentState.is_transparent_variable ts id then Everything else Label(GRLabel (VarRef id),l) + | Var id -> + if Environ.evaluable_named id env && TransparentState.is_transparent_variable ts id then Everything + else Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then @@ -88,52 +103,54 @@ let constr_val_discr_st sigma ts t = | Rel _ | Meta _ | Cast _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ | Proj _ | Int _ | Float _ | Array _ -> Nothing -let constr_pat_discr_st ts t = +let constr_pat_discr_st env ts t = let open GlobRef in match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) - | PRef ((VarRef v) as ref), args when not (TransparentState.is_transparent_variable ts v) -> - Some(GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> + if Environ.evaluable_named v env && (TransparentState.is_transparent_variable ts v) then None + else Some(GRLabel ref,args) + | PRef ((ConstRef c) as ref), args -> + if evaluable_constant c env && TransparentState.is_transparent_constant ts c then None + else Some (GRLabel ref, args) | PVar v, args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel (VarRef v),args) - | PRef ((ConstRef c) as ref), args when not (TransparentState.is_transparent_constant ts c) -> - Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) | PSort s, [] -> Some (SortLabel, []) | _ -> None -let bounded_constr_pat_discr_st st (t,depth) = +let bounded_constr_pat_discr_st env st (t,depth) = if Int.equal depth 0 then None else - match constr_pat_discr_st st t with + match constr_pat_discr_st env st t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr_st sigma st (t,depth) = +let bounded_constr_val_discr_st env sigma st (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr_st sigma st t with + match constr_val_discr_st env sigma st t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything -let bounded_constr_pat_discr (t,depth) = +let bounded_constr_pat_discr env (t,depth) = if Int.equal depth 0 then None else - match constr_pat_discr t with + match constr_pat_discr env t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr sigma (t,depth) = +let bounded_constr_val_discr env sigma (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr sigma t with + match constr_val_discr env sigma t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything @@ -151,31 +168,23 @@ struct type t = Dn.t - let empty = Dn.empty + type pattern = Dn.pattern - let add = function - | None -> - (fun dn (c,v) -> - Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let pattern env st pat = match st with + | None -> Dn.pattern (bounded_constr_pat_discr env) (pat, !dnet_depth) + | Some st -> Dn.pattern (bounded_constr_pat_discr_st env st) (pat, !dnet_depth) - let rmv = function - | None -> - (fun dn (c,v) -> - Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let empty = Dn.empty + let add = Dn.add + let rmv = Dn.rmv - let lookup sigma = function + let lookup env sigma = function | None -> (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr env sigma) (t,!dnet_depth)) | Some st -> (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr_st env sigma st) (t,!dnet_depth)) let app f dn = Dn.app f dn diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 4358e5a8d9..ab201a1872 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -28,12 +28,16 @@ module Make : sig type t + type pattern + + val pattern : Environ.env -> TransparentState.t option -> constr_pattern -> pattern + val empty : t - val add : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t - val rmv : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + val add : t -> pattern -> Z.t -> t + val rmv : t -> pattern -> Z.t -> t - val lookup : Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list + val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list val app : (Z.t -> unit) -> t -> unit end diff --git a/tactics/cbn.ml b/tactics/cbn.ml index dfbcc9fbce..8f0966a486 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -571,7 +571,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | None -> fold ()) | Const (c,u as const) -> Reductionops.reduction_effect_hook env sigma c - (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); + (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,fst (Stack.strip_app stack))))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in match constant_value_in env (c, u') with diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 63cafbf76d..2f55cc071f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -144,61 +144,50 @@ let auto_unif_flags ?(allowed_evars = AllowAll) st = } let e_give_exact flags h = - let { hint_term = c; hint_clnv = clenv } = h in let open Tacmach.New in Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let sigma = project gl in - let c, sigma = - if h.hint_poly then - let clenv', subst = Clenv.refresh_undefined_univs clenv in - let evd = evars_reset_evd ~with_conv_pbs:true sigma clenv'.evd in - let c = Vars.subst_univs_level_constr subst c in - c, evd - else c, sigma - in + let sigma, c = Hints.fresh_hint env sigma h in let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in Proofview.Unsafe.tclEVARS sigma <*> Clenv.unify ~flags t1 <*> exact_no_check c end -let unify_e_resolve flags = begin fun gls (h, _) -> - let clenv', c = connect_hint_clenv h gls in - Clenv.res_pf ~with_evars:true ~with_classes:false ~flags clenv' - end - -let unify_resolve flags = begin fun gls (h, _) -> - let clenv', _ = connect_hint_clenv h gls in - Clenv.res_pf ~with_evars:false ~with_classes:false ~flags clenv' +let unify_resolve ~with_evars flags h diff = match diff with +| None -> + Hints.hint_res_pf ~with_evars ~with_classes:false ~flags h +| Some (diff, ty) -> + let () = assert (not h.hint_poly) in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let sigma, c = Hints.fresh_hint env sigma h in + let clenv = mk_clenv_from_env env sigma (Some diff) (c, ty) in + Clenv.res_pf ~with_evars ~with_classes:false ~flags clenv end (** Application of a lemma using [refine] instead of the old [w_unify] *) -let unify_resolve_refine flags gls (h, n) = - let { hint_term = c; hint_type = t; hint_uctx = ctx; hint_clnv = clenv } = h in +let unify_resolve_refine flags h diff = + let len = match diff with None -> None | Some (diff, _) -> Some diff in + Proofview.Goal.enter begin fun gls -> let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in Refine.refine ~typecheck:false begin fun sigma -> - let sigma, term, ty = - if h.hint_poly then - let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in - let map c = Vars.subst_univs_level_constr subst c in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - sigma, map c, map t - else - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - sigma, c, t - in - let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in - let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in - let sigma' = - Evarconv.(unify_leq_delay - ~flags:(default_flags_of flags.core_unify_flags.modulo_delta) - env sigma' cl.cl_concl concl) - in (sigma', term) end - -let unify_resolve_refine flags gl clenv = + let sigma, term = Hints.fresh_hint env sigma h in + let ty = Retyping.get_type_of env sigma term in + let sigma, cl = Clenv.make_evar_clause env sigma ?len ty in + let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in + let flags = Evarconv.default_flags_of flags.core_unify_flags.modulo_delta in + let sigma = Evarconv.unify_leq_delay ~flags env sigma cl.cl_concl concl in + (sigma, term) + end + end + +let unify_resolve_refine flags h diff = Proofview.tclORELSE - (unify_resolve_refine flags gl clenv) + (unify_resolve_refine flags h diff) (fun (exn,info) -> match exn with | Evarconv.UnableToUnify _ -> @@ -211,35 +200,21 @@ let unify_resolve_refine flags gl clenv = (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. *) -let clenv_of_prods nprods h gl = - let { hint_term = c; hint_clnv = clenv; hint_poly = poly } = h in - if poly || Int.equal nprods 0 then Some (None, clenv) - else - let sigma = Tacmach.New.project gl in - let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in - let diff = nb_prod sigma ty - nprods in - if (>=) diff 0 then - (* Was Some clenv... *) - Some (Some diff, - mk_clenv_from_n gl (Some diff) (c,ty)) - else None - let with_prods nprods h f = if get_typeclasses_limit_intros () then Proofview.Goal.enter begin fun gl -> - try match clenv_of_prods nprods h gl with - | None -> - let info = Exninfo.reify () in - Tacticals.New.tclZEROMSG ~info (str"Not enough premisses") - | Some (diff, clenv') -> - let h = { h with hint_clnv = clenv' } in - f gl (h, diff) - with e when CErrors.noncritical e -> - let e, info = Exninfo.capture e in - Proofview.tclZERO ~info e end + let { hint_term = c; hint_poly = poly } = h in + if poly || Int.equal nprods 0 then f None + else + let sigma = Tacmach.New.project gl in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let diff = nb_prod sigma ty - nprods in + if (>=) diff 0 then f (Some (diff, ty)) + else Tacticals.New.tclZEROMSG (str"Not enough premisses") + end else Proofview.Goal.enter begin fun gl -> - if Int.equal nprods 0 then f gl (h, None) + if Int.equal nprods 0 then f None else Tacticals.New.tclZEROMSG (str"Not enough premisses") end let matches_pattern concl pat = @@ -282,13 +257,13 @@ let shelve_dependencies gls = Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls); shelve_goals gls) -let hintmap_of sigma hdc secvars concl = +let hintmap_of env sigma hdc secvars concl = match hdc with | None -> fun db -> ModeMatch (Hint_db.map_none ~secvars db) | Some hdc -> fun db -> if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto sigma ~secvars hdc concl db + Hint_db.map_eauto env sigma ~secvars hdc concl db else Hint_db.map_existential sigma ~secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) @@ -347,25 +322,25 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm if get_typeclasses_filtered_unification () then let tac = with_prods nprods h - (fun gl clenv -> + (fun diff -> matches_pattern concl p <*> - unify_resolve_refine flags gl clenv) + unify_resolve_refine flags h diff) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = - with_prods nprods h (unify_resolve flags) in + with_prods nprods h (unify_resolve ~with_evars:false flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf h -> if get_typeclasses_filtered_unification () then let tac = (with_prods nprods h - (fun gl clenv -> + (fun diff -> matches_pattern concl p <*> - unify_resolve_refine flags gl clenv)) in + unify_resolve_refine flags h diff)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = - with_prods nprods h (unify_e_resolve flags) in + with_prods nprods h (unify_resolve ~with_evars:true flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | Give_exact h -> @@ -373,18 +348,18 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm let tac = matches_pattern concl p <*> Proofview.Goal.enter - (fun gl -> unify_resolve_refine flags gl (h, None)) in + (fun gl -> unify_resolve_refine flags h None) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else e_give_exact flags h | Res_pf_THEN_trivial_fail h -> - let fst = with_prods nprods h (unify_e_resolve flags) in + let fst = with_prods nprods h (unify_resolve ~with_evars:true flags h) in let snd = if complete then Tacticals.New.tclIDTAC else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.New.tclTHEN fst snd | Unfold_nth c -> Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c]) - | Extern tacast -> conclPattern concl p tacast + | Extern (p, tacast) -> conclPattern concl p tacast in let tac = FullHint.run h tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in @@ -398,7 +373,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm | Extern _ -> (tac, b, true, name, lazy (FullHint.print env sigma h ++ pp)) | _ -> (tac, b, false, name, lazy (FullHint.print env sigma h ++ pp)) in - let hint_of_db = hintmap_of sigma hdc secvars concl in + let hint_of_db = hintmap_of env sigma hdc secvars concl in let hintl = List.map_filter (fun db -> match hint_of_db db with | ModeMatch l -> Some (db, l) | ModeMismatch -> None) @@ -1235,8 +1210,7 @@ let autoapply c i = (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.New.pf_get_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let h = { hint_term = c; hint_type = cty; hint_uctx = Univ.ContextSet.empty; hint_clnv = ce; hint_poly = false } in - unify_e_resolve flags gl (h, 0) <*> + Clenv.res_pf ~with_evars:true ~with_classes:false ~flags ce <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.make_unresolvables (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.find sigma ev).evar_source))) sigma in diff --git a/tactics/dn.ml b/tactics/dn.ml index e1c9b7c0b5..07eb49442a 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -38,6 +38,8 @@ struct type t = Trie.t + type pattern = (Y.t * int) option list + let empty = Trie.empty (* [path_of dna pat] returns the list of nodes of the pattern [pat] read in @@ -89,11 +91,13 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) in List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) - let add tm dna (pat,inf) = - let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm + let pattern dna pat = path_of dna pat + + let add tm p inf = + Trie.add p (ZSet.singleton inf) tm - let rmv tm dna (pat,inf) = - let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm + let rmv tm p inf = + Trie.remove p (ZSet.singleton inf) tm let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm diff --git a/tactics/dn.mli b/tactics/dn.mli index 2a60c3eb82..287aa2b257 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -18,9 +18,13 @@ sig must decompose any tree into a label characterizing its root node and the list of its subtree *) - val add : t -> 'a decompose_fun -> 'a * Z.t -> t + type pattern - val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t + val pattern : 'a decompose_fun -> 'a -> pattern + + val add : t -> pattern -> Z.t -> t + + val rmv : t -> pattern -> Z.t -> t type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 686303a2ab..e920093648 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -19,7 +19,6 @@ open Tacticals open Tacmach open Evd open Tactics -open Clenv open Auto open Genredexpr open Tactypes @@ -66,12 +65,9 @@ open Auto (***************************************************************************) let unify_e_resolve flags h = - Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Clenv.res_pf ~with_evars:true ~with_classes:true ~flags clenv' - end + Hints.hint_res_pf ~with_evars:true ~with_classes:true ~flags h -let hintmap_of sigma secvars concl = +let hintmap_of env sigma secvars concl = (* Warning: for computation sharing, we need to return a closure *) let hdc = try Some (decompose_app_bound sigma concl) with Bound -> None in match hdc with @@ -82,15 +78,15 @@ let hintmap_of sigma secvars concl = match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> []) - else (fun db -> Hint_db.map_auto sigma ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto env sigma ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact flags h = Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (e_give_exact c) + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, c = Hints.fresh_hint env sigma h in + Proofview.Unsafe.tclEVARS sigma <*> e_give_exact c end let rec e_trivial_fail_db db_list local_db = @@ -110,7 +106,7 @@ let rec e_trivial_fail_db db_list local_db = end and e_my_find_search env sigma db_list local_db secvars concl = - let hint_of_db = hintmap_of sigma secvars concl in + let hint_of_db = hintmap_of env sigma secvars concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -130,7 +126,7 @@ and e_my_find_search env sigma db_list local_db secvars concl = Tacticals.New.tclTHEN (unify_e_resolve st h) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> conclPattern concl (FullHint.pattern h) tacast + | Extern (pat, tacast) -> conclPattern concl pat tacast in let tac = FullHint.run h tac in (tac, b, lazy (FullHint.print env sigma h)) diff --git a/tactics/equality.ml b/tactics/equality.ml index a2325b69cc..b4def7bb51 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1134,6 +1134,7 @@ let make_tuple env sigma (rterm,rty) lind = assert (not (noccurn sigma lind rty)); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in + let a = simpl env sigma a in let na = Context.Rel.Declaration.get_annot (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1416,6 +1417,11 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) +exception NothingToInject +let () = CErrors.register_handler (function + | NothingToInject -> Some (Pp.str "Nothing to inject.") + | _ -> None) + let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in @@ -1429,7 +1435,7 @@ let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] -> - tclZEROMSG (str"Nothing to inject.") + Proofview.tclZERO NothingToInject | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns (tac (clenv_value eq_clause)) @@ -1644,7 +1650,7 @@ let cutSubstClause l2r eqn cls = let warn_deprecated_cutrewrite = CWarnings.create ~name:"deprecated-cutrewrite" ~category:"deprecated" - (fun () -> strbrk"\"cutrewrite\" is deprecated. See documentation for proposed replacement.") + (fun () -> strbrk"\"cutrewrite\" is deprecated. Use \"replace\" instead.") let cutRewriteClause l2r eqn cls = warn_deprecated_cutrewrite (); diff --git a/tactics/equality.mli b/tactics/equality.mli index e252eeab28..fdcbbc0e3c 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -91,6 +91,7 @@ val discr_tac : evars_flag -> constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic (* Below, if flag is [None], it takes the value from the dynamic value of the option *) +exception NothingToInject val inj : inj_flags option -> intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val injClause : inj_flags option -> intro_patterns option -> evars_flag -> diff --git a/tactics/hints.ml b/tactics/hints.ml index 386224824f..db4b23705f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -42,21 +42,22 @@ type debug = Debug | Info | Off exception Bound -let head_constr_bound sigma t = - let t = strip_outer_cast sigma t in - let _,ccl = decompose_prod_assum sigma t in - let hd,args = decompose_app sigma ccl in - let open GlobRef in - match EConstr.kind sigma hd with - | Const (c, _) -> ConstRef c - | Ind (i, _) -> IndRef i - | Construct (c, _) -> ConstructRef c - | Var id -> VarRef id - | Proj (p, _) -> ConstRef (Projection.constant p) - | _ -> raise Bound +let rec head_bound sigma t = match EConstr.kind sigma t with +| Prod (_, _, b) -> head_bound sigma b +| LetIn (_, _, _, b) -> head_bound sigma b +| App (c, _) -> head_bound sigma c +| Case (_, _, _, c, _) -> head_bound sigma c +| Ind (ind, _) -> GlobRef.IndRef ind +| Const (c, _) -> GlobRef.ConstRef c +| Construct (c, _) -> GlobRef.ConstructRef c +| Var id -> GlobRef.VarRef id +| Proj (p, _) -> GlobRef.ConstRef (Projection.constant p) +| Cast (c, _, _) -> head_bound sigma c +| Evar _ | Rel _ | Meta _ | Sort _ | Fix _ | Lambda _ +| CoFix _ | Int _ | Float _ | Array _ -> raise Bound let head_constr sigma c = - try head_constr_bound sigma c + try head_bound sigma c with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ (co)inductive type, (co)inductive type constructor, or projection.") @@ -105,7 +106,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Genarg.glob_generic_argument (* Hint Extern *) + | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) type 'a hints_path_atom_gen = @@ -237,10 +238,38 @@ let pri_order t1 t2 = pri_order_int t1 t2 <= 0 type stored_data = int * full_hint (* First component is the index of insertion in the table, to keep most recent first semantics. *) -module Bounded_net = Btermdn.Make(struct - type t = stored_data - let compare = pri_order_int - end) +module Bounded_net : +sig + type t + val empty : t + val add : TransparentState.t option -> t -> Pattern.constr_pattern -> stored_data -> t + val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> stored_data list +end = +struct + module Data = struct type t = stored_data let compare = pri_order_int end + module Bnet = Btermdn.Make(Data) + + type diff = Pattern.constr_pattern * stored_data + type data = Bnet of Bnet.t | Diff of diff * data ref + type t = data ref + + let empty = ref (Bnet Bnet.empty) + + let add _st net p v = ref (Diff ((p, v), net)) + + let rec force env st net = match !net with + | Bnet dn -> dn + | Diff ((p, v), rem) -> + let dn = force env st rem in + let p = Bnet.pattern env st p in + let dn = Bnet.add dn p v in + let () = net := (Bnet dn) in + dn + + let lookup env sigma st net p = + let dn = force env st net in + Bnet.lookup env sigma st dn p +end type search_entry = { sentry_nopat : stored_data list; @@ -258,27 +287,28 @@ let empty_se = { let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid -let add_tac pat t st se = +let add_tac pat t se = match pat with | None -> if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } - | Some pat -> + | Some (st, pat) -> if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se else { se with sentry_pat = List.insert pri_order t se.sentry_pat; - sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } + sentry_bnet = Bounded_net.add st se.sentry_bnet pat t; } let rebuild_dn st se = let dn' = List.fold_left - (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) + (fun dn (id, t) -> + Bounded_net.add (Some st) dn (Option.get t.pat) (id, t)) Bounded_net.empty se.sentry_pat in { se with sentry_bnet = dn' } -let lookup_tacs sigma concl st se = - let l' = Bounded_net.lookup sigma st se.sentry_bnet concl in +let lookup_tacs env sigma concl st se = + let l' = Bounded_net.lookup env sigma st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' @@ -320,8 +350,7 @@ let instantiate_hint env sigma p = | Res_pf_THEN_trivial_fail c -> Res_pf_THEN_trivial_fail (mk_clenv c) | Give_exact c -> Give_exact (mk_clenv c) - | Unfold_nth e -> Unfold_nth e - | Extern t -> Extern t + | (Unfold_nth _ | Extern _) as h -> h in { p with code = { p.code with obj = code } } @@ -500,14 +529,14 @@ val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list val map_existential : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode -val map_eauto : evar_map -> secvars:Id.Pred.t -> +val map_eauto : Environ.env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode -val map_auto : evar_map -> secvars:Id.Pred.t -> +val map_auto : Environ.env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t -val remove_one : GlobRef.t -> t -> t -val remove_list : GlobRef.t list -> t -> t +val remove_one : Environ.env -> GlobRef.t -> t -> t +val remove_list : Environ.env -> GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> TransparentState.t @@ -600,10 +629,10 @@ struct merge_entry secvars db se.sentry_nopat se.sentry_pat (* Precondition: concl has no existentials *) - let map_auto sigma ~secvars (k,args) concl db = + let map_auto env sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in - let pat = lookup_tacs sigma concl st se in + let pat = lookup_tacs env sigma concl st se in merge_entry secvars db [] pat let map_existential sigma ~secvars (k,args) concl db = @@ -613,11 +642,11 @@ struct else ModeMismatch (* [c] contains an existential *) - let map_eauto sigma ~secvars (k,args) concl db = + let map_eauto env sigma ~secvars (k,args) concl db = let se = find k db in if matches_modes sigma args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in - let pat = lookup_tacs sigma concl st se in + let pat = lookup_tacs env sigma concl st se in ModeMatch (merge_entry secvars db [] pat) else ModeMismatch @@ -636,8 +665,6 @@ struct is_unfold v.code.obj then None else Some gr | None -> None in - let dnst = if db.use_dn then Some db.hintdb_state else None in - let pat = if not db.use_dn && is_exact v.code.obj then None else v.pat in match k with | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in @@ -646,8 +673,14 @@ struct { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> + let pat = + if not db.use_dn && is_exact v.code.obj then None + else + let dnst = if db.use_dn then Some db.hintdb_state else None in + Option.map (fun p -> (dnst, p)) v.pat + in let oval = find gr db in - { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv oval) db.hintdb_map } let rebuild_db st' db = let db' = @@ -687,14 +720,14 @@ struct if sl1' == se.sentry_nopat && sl2' == se.sentry_pat then se else rebuild_dn st { se with sentry_nopat = sl1'; sentry_pat = sl2' } - let remove_list grs db = + let remove_list env grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in let hintmap = GlobRef.Map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } - let remove_one gr db = remove_list [gr] db + let remove_one env gr db = remove_list env [gr] db let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in @@ -769,12 +802,6 @@ let rec nb_hyp sigma c = match EConstr.kind sigma c with (* adding and removing tactics in the search table *) -let try_head_pattern c = - try head_pattern_bound c - with BoundPattern -> - user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ - an if, case, or let expression, an application, or a projection.") - let with_uid c = { obj = c; uid = fresh_key () } let secvars_of_idset s = @@ -795,15 +822,15 @@ let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in let hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_exact_entry" + try head_bound sigma cty + with Bound -> failwith "make_exact_entry" in let pri = match info.hint_priority with None -> 0 | Some p -> p in let pat = match info.hint_pattern with | Some pat -> snd pat - | None -> pat + | None -> + Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in (Some hd, { pri; pat = Some pat; name; @@ -817,16 +844,17 @@ let make_apply_entry env sigma (eapply,hnf,verbose) info ~poly ?(name=PathAny) ( let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in let hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_apply_entry" in + try head_bound ce.evd c' + with Bound -> failwith "make_apply_entry" in let miss = clenv_missing ce in let nmiss = List.length miss in let secvars = secvars_of_constr env sigma c in let pri = match info.hint_priority with None -> nb_hyp sigma' cty + nmiss | Some p -> p in let pat = match info.hint_pattern with - | Some p -> snd p | None -> pat + | Some p -> snd p + | None -> + Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in if Int.equal nmiss 0 then (Some hd, @@ -929,14 +957,21 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = - let hdconstr = Option.map try_head_pattern pat in + let hdconstr = match pat with + | None -> None + | Some c -> + try Some (head_pattern_bound c) + with BoundPattern -> + user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ + an if, case, or let expression, an application, or a projection.") + in (hdconstr, { pri = pri; pat = pat; name = PathAny; db = None; secvars = Id.Pred.empty; (* Approximation *) - code = with_uid (Extern tacast) }) + code = with_uid (Extern (pat, tacast)) }) let make_mode ref m = let open Term in @@ -1009,8 +1044,9 @@ let add_transparency dbname target b = in searchtable_add (dbname, Hint_db.set_transparent_state db st') let remove_hint dbname grs = + let env = Global.env () in let db = get_db dbname in - let db' = Hint_db.remove_list grs db in + let db' = Hint_db.remove_list env grs db in searchtable_add (dbname, db') type hint_action = @@ -1070,7 +1106,7 @@ let subst_autohint (subst, obj) = match t with | None -> gr' | Some t -> - (try head_constr_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) + (try head_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) with Bound -> gr') in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in @@ -1100,9 +1136,10 @@ let subst_autohint (subst, obj) = | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' - | Extern tac -> + | Extern (pat, tac) -> + let pat' = Option.Smart.map (subst_pattern env sigma subst) data.pat in let tac' = Genintern.generic_substitute subst tac in - if tac==tac' then data.code.obj else Extern tac' + if pat==pat' && tac==tac' then data.code.obj else Extern (pat', tac') in let name' = subst_path_atom subst data.name in let uid' = subst_kn subst data.code.uid in @@ -1382,7 +1419,7 @@ let pr_hint env sigma h = match h.obj with (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") | Unfold_nth c -> str"unfold " ++ pr_evaluable_reference c - | Extern tac -> + | Extern (_, tac) -> str "(*external*) " ++ Pputils.pr_glb_generic env sigma tac let pr_id_hint env sigma (id, v) = @@ -1427,7 +1464,7 @@ let pr_hint_term env sigma cl = (fun db -> match Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl db with | ModeMatch l -> l | ModeMismatch -> []) - else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto env sigma ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1593,3 +1630,45 @@ struct let repr (h : t) = h.code.obj end + +let connect_hint_clenv h gl = + let { hint_uctx = ctx; hint_clnv = clenv } = h in + (* [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) + let sigma = Tacmach.New.project gl in + let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in + (* Still, we need to update the universes *) + if h.hint_poly then + (* Refresh the instance of the hint *) + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in + let emap c = Vars.subst_univs_level_constr subst c in + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + (* Only metas are mentioning the old universes. *) + { + templval = Evd.map_fl emap clenv.templval; + templtyp = Evd.map_fl emap clenv.templtyp; + evd = Evd.map_metas emap evd; + env = Proofview.Goal.env gl; + } + else + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + { clenv with evd = evd ; env = Proofview.Goal.env gl } + +let fresh_hint env sigma h = + let { hint_term = c; hint_uctx = ctx } = h in + if h.hint_poly then + (* Refresh the instance of the hint *) + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in + let c = Vars.subst_univs_level_constr subst c in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, c + else + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, c + +let hint_res_pf ?with_evars ?with_classes ?flags h = + Proofview.Goal.enter begin fun gl -> + let clenv = connect_hint_clenv h gl in + Clenv.res_pf ?with_evars ?with_classes ?flags clenv + end diff --git a/tactics/hints.mli b/tactics/hints.mli index 8243716624..e061bd7648 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -37,9 +37,9 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Genarg.glob_generic_argument (* Hint Extern *) + | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) -type hint = { +type hint = private { hint_term : constr; hint_type : types; hint_uctx : Univ.ContextSet.t; @@ -134,18 +134,18 @@ module Hint_db : (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. Returns a [ModeMismatch] if there are declared modes and none matches. *) - val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list with_mode + val map_eauto : env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list with_mode (** All hints associated to the reference. Precondition: no evars should appear in the arguments, so no modes are checked. *) - val map_auto : evar_map -> secvars:Id.Pred.t -> + val map_auto : env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t - val remove_one : GlobRef.t -> t -> t - val remove_list : GlobRef.t list -> t -> t + val remove_one : Environ.env -> GlobRef.t -> t -> t + val remove_list : Environ.env -> GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> FullHint.t list -> unit) -> t -> unit @@ -239,6 +239,11 @@ val wrap_hint_warning_fun : env -> evar_map -> (evar_map -> 'a * evar_map) -> 'a * evar_map (** Variant of the above for non-tactics *) +val fresh_hint : env -> evar_map -> hint -> evar_map * constr + +val hint_res_pf : ?with_evars:bool -> ?with_classes:bool -> + ?flags:Unification.unify_flags -> hint -> unit Proofview.tactic + (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f553a290f9..70cea89ccb 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -117,7 +117,7 @@ let unsafe_intro env decl b = Refine.refine ~typecheck:false begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in - let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in + let inst = identity_subst_val (named_context_val env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let (sigma, ev) = new_pure_evar nctx sigma nb ~principal:true in @@ -338,7 +338,7 @@ let rename_hyp repl = let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = val_of_named_context nhyps in - let instance = List.map (NamedDecl.get_id %> mkVar) hyps in + let instance = EConstr.identity_subst_val (Environ.named_context_val env) in Refine.refine ~typecheck:false begin fun sigma -> let sigma, ev = Evarutil.new_pure_evar nctx sigma nconcl ~principal:true in sigma, mkEvar (ev, instance) @@ -437,11 +437,6 @@ let clear_hyps2 env sigma ids sign t cl = with Evarutil.ClearDependencyError (id,err,inglobal) -> error_replacing_dependency env sigma id err inglobal -let new_evar_from_context ?principal sign evd typ = - let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in - let (evd, evk) = Evarutil.new_pure_evar sign evd typ in - (evd, mkEvar (evk, instance)) - let internal_cut ?(check=true) replace id t = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -449,22 +444,22 @@ let internal_cut ?(check=true) replace id t = let concl = Proofview.Goal.concl gl in let sign = named_context_val env in let r = Retyping.relevance_of_type env sigma t in - let sign',t,concl,sigma = + let env',t,concl,sigma = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in let sign' = insert_decl_in_named_context env sigma (LocalAssum (make_annot id r,t)) nexthyp sign' in - sign',t,concl,sigma + Environ.reset_with_named_context sign' env,t,concl,sigma else (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 (make_annot id r,t)) sign,t,concl,sigma) in + push_named (LocalAssum (make_annot id r,t)) env,t,concl,sigma) in let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun sigma -> - let (sigma, ev) = new_evar_from_context sign sigma nf_t in - let (sigma, ev') = new_evar_from_context sign' sigma ~principal:true concl in + let (sigma, ev) = Evarutil.new_evar env sigma nf_t in + let (sigma, ev') = Evarutil.new_evar ~principal:true env' sigma concl in let term = mkLetIn (make_annot (Name id) r, ev, t, EConstr.Vars.subst_var id ev') in (sigma, term) end) @@ -1049,12 +1044,15 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = end end -let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) +let drop_intro_name (_ : Id.t) = Proofview.tclUNIT () + +let intro_gen n m f d = intro_then_gen n m f d drop_intro_name let intro_mustbe_force id = intro_gen (NamingMustBe (CAst.make id)) MoveLast true false -let intro_using id = intro_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false +let intro_using_then id = intro_then_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false +let intro_using id = intro_using_then id drop_intro_name let intro_then = intro_then_gen (NamingAvoid Id.Set.empty) MoveLast false false -let intro = intro_gen (NamingAvoid Id.Set.empty) MoveLast false false +let intro = intro_then drop_intro_name let introf = intro_gen (NamingAvoid Id.Set.empty) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false @@ -1070,6 +1068,11 @@ let rec intros_using = function | [] -> Proofview.tclUNIT() | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) +let rec intros_using_then_helper tac acc = function + | [] -> tac (List.rev acc) + | str::l -> intro_using_then str (fun str' -> intros_using_then_helper tac (str'::acc) l) +let intros_using_then l tac = intros_using_then_helper tac [] l + let intros = Tacticals.New.tclREPEAT intro let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = @@ -2788,7 +2791,7 @@ let pose_tac na c = let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in - let inst = List.map (fun d -> mkVar (get_id d)) (named_context env) in + let inst = EConstr.identity_subst_val hyps in let body = mkEvar (ev, mkRel 1 :: inst) in (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 5b397b15d0..00739306a7 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -65,9 +65,11 @@ val intro_avoiding : Id.Set.t -> unit Proofview.tactic val intro_replacing : Id.t -> unit Proofview.tactic val intro_using : Id.t -> unit Proofview.tactic +val intro_using_then : Id.t -> (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intro_mustbe_force : Id.t -> unit Proofview.tactic val intro_then : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intros_using : Id.t list -> unit Proofview.tactic +val intros_using_then : Id.t list -> (Id.t list -> unit Proofview.tactic) -> unit Proofview.tactic val intros_replacing : Id.t list -> unit Proofview.tactic val intros_possibly_replacing : Id.t list -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index f7447d6cec..758374c5de 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -198,7 +198,6 @@ summary: $(call summary_dir, "Coqdoc tests", coqdoc); \ $(call summary_dir, "tools/ tests", tools); \ $(call summary_dir, "Unit tests", unit-tests); \ - $(call summary_dir, "Machine arithmetic tests", arithmetic); \ $(call summary_dir, "Ltac2 tests", ltac2); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ @@ -223,7 +222,7 @@ report: summary.log # printed for all opened bugs (still active or seems to be closed). # For closed bugs that behave as expected, no message is printed -# All files are assumed to have <# of the bug>.v as a name +# All files are assumed to have bug_<# of the bug>.v as a name # Opened bugs that should not fail $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @@ -301,20 +300,20 @@ endif unit-tests/src/utest.cmx: unit-tests/src/utest.ml unit-tests/src/utest.cmi $(SHOW) 'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package oUnit $< + $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package ounit2 $< unit-tests/src/utest.cmo: unit-tests/src/utest.ml unit-tests/src/utest.cmi $(SHOW) 'OCAMLC $<' - $(HIDE)$(OCAMLC) -c -I unit-tests/src -package oUnit $< + $(HIDE)$(OCAMLC) -c -I unit-tests/src -package ounit2 $< unit-tests/src/utest.cmi: unit-tests/src/utest.mli $(SHOW) 'OCAMLC $<' - $(HIDE)$(OCAMLC) -package oUnit -c $< + $(HIDE)$(OCAMLC) -package ounit2 -c $< unit-tests: $(UNIT_LOGFILES) # Build executable, run it to generate log file unit-tests/%.ml.log: unit-tests/%.ml unit-tests/src/$(UNIT_LINK) $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,oUnit \ + $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,ounit2 \ -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test @@ -501,8 +500,8 @@ $(addsuffix .log,$(wildcard output-coqchk/*.v)): %.v.log: %.v %.out $(PREREQUISI } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi .PHONY: approve-output -approve-output: output output-coqtop - $(HIDE)for f in output/*.out.real; do \ +approve-output: output output-coqtop output-coqchk + $(HIDE)for f in $(wildcard $(addsuffix /*.out.real,$^)); do \ mv "$$f" "$${f%.real}"; \ echo "Updated $${f%.real}!"; \ done diff --git a/test-suite/bugs/bug_5996.v b/test-suite/bugs/bug_5996.v deleted file mode 100644 index c9e3292b48..0000000000 --- a/test-suite/bugs/bug_5996.v +++ /dev/null @@ -1,8 +0,0 @@ -Goal Type. - let c := constr:(prod nat nat) in - let c' := (eval pattern nat in c) in - let c' := lazymatch c' with ?f _ => f end in - let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in - let _ := type of c'' in - exact c''. -Defined. diff --git a/test-suite/bugs/bug_11140.v b/test-suite/bugs/closed/bug_11140.v index ca806ea324..ca806ea324 100644 --- a/test-suite/bugs/bug_11140.v +++ b/test-suite/bugs/closed/bug_11140.v diff --git a/test-suite/bugs/closed/bug_12001.v b/test-suite/bugs/closed/bug_12001.v new file mode 100644 index 0000000000..19533e49f1 --- /dev/null +++ b/test-suite/bugs/closed/bug_12001.v @@ -0,0 +1,24 @@ +(* Argument names don't get mangled *) +Set Mangle Names. +Lemma leibniz_equiv_iff {A : Type} (x y : A) : True. +Proof. tauto. Qed. +Check leibniz_equiv_iff (A := nat) 2 3 : True. +Unset Mangle Names. + +(* Coq doesn't make up names for arguments *) +Definition bar (a a : nat) : nat := 3. +Arguments bar _ _ : assert. +Fail Arguments bar a a0 : assert. + +(* This definition caused an anomaly in a version of this PR +without the change to prepare_implicits *) +Set Implicit Arguments. +Definition foo (_ : nat) (_ : @eq nat ltac:(assumption) 2) : True := I. +Fail Check foo (H := 2). + +Definition baz (a b : nat) := b. +Arguments baz a {b}. +Set Mangle Names. +Definition baz2 (a b : nat) := b. +Arguments baz2 a {b}. +Unset Mangle Names. diff --git a/test-suite/bugs/closed/bug_12483.v b/test-suite/bugs/closed/bug_12483.v index 0d034a65eb..ae46117e59 100644 --- a/test-suite/bugs/closed/bug_12483.v +++ b/test-suite/bugs/closed/bug_12483.v @@ -4,7 +4,7 @@ Goal False. Proof. cut (false = true). { intro H; discriminate H. } -change false with (1 <= 0)%float. +change false with (1 <=? 0)%float. rewrite leb_spec. Fail reflexivity. Abort. diff --git a/test-suite/bugs/closed/bug_12763.v b/test-suite/bugs/closed/bug_12763.v new file mode 100644 index 0000000000..6cbcc0d3b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_12763.v @@ -0,0 +1,6 @@ +Inductive bool_list := S (y : bool) (l : bool_list) | O. +Scheme Equality for bool_list. + +Set Mangle Names. +Scheme Equality for nat. +Scheme Equality for list. diff --git a/test-suite/bugs/closed/bug_12787.v b/test-suite/bugs/closed/bug_12787.v new file mode 100644 index 0000000000..2566e1f261 --- /dev/null +++ b/test-suite/bugs/closed/bug_12787.v @@ -0,0 +1,26 @@ +Inductive sigT3 {A: Type} {P: A -> Type} (Q: forall a: A, P a -> Type) := + existT3: forall a: A, forall b: P a, Q a b -> sigT3 Q +. + +Definition projT3_1 {A: Type} {P: A -> Type} {Q: forall a: A, P a -> Type} (a: sigT3 Q) := + let 'existT3 _ x0 _ _ := a in x0. + +Definition projT3_2 {A: Type} {P: A -> Type} {Q: forall a: A, P a -> Type} (a: sigT3 Q) : P (projT3_1 a) := + let 'existT3 _ x0 x1 _ := a in x1. + + + +Lemma projT3_3_eq' (A B: Type) (Q: B -> Type) (a b: sigT3 (fun (_: A) b => Q b)) (H: a = b) : + unit. +Proof. + destruct a as [x0 x1 x2], b as [y0 y1 y2]. + assert (H' := f_equal projT3_1 H). + cbn in H'. + subst x0. + assert (H' := f_equal (projT3_2 (P := fun _ => B)) H). + cbn in H'. + subst x1. + + injection H as H'. + exact tt. +Qed. diff --git a/test-suite/bugs/bug_4690.v b/test-suite/bugs/closed/bug_4690.v index f50866a990..f50866a990 100644 --- a/test-suite/bugs/bug_4690.v +++ b/test-suite/bugs/closed/bug_4690.v diff --git a/test-suite/bugs/closed/bug_7015.v b/test-suite/bugs/closed/bug_7015.v new file mode 100644 index 0000000000..a57fa94960 --- /dev/null +++ b/test-suite/bugs/closed/bug_7015.v @@ -0,0 +1,74 @@ +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. +Set Printing Universes. + +Module Simple. + + (* in the real world foo@{i} might be [@paths@{i} nat] I guess *) + Inductive foo : nat -> Type :=. + + (* on [refl (fun x => f x)] this computes to [refl f] *) + Definition eta_out {A B} (f g : forall x : A, B x) (e : (fun x => f x) = (fun x => g x)) : f = g. + Proof. + change (f = g) in e. destruct e;reflexivity. + Defined. + + Section univs. + Universes i j. + Constraint i < j. (* fail instead of forcing equality *) + + Definition one : (fun n => foo@{i} n) = fun n => foo@{j} n := eq_refl. + + Definition two : foo@{i} = foo@{j} := eta_out _ _ one. + + Definition two' : foo@{i} = foo@{j} := Eval compute in two. + + Definition three := @eq_refl (foo@{i} = foo@{j}) two. + Definition four := Eval compute in three. + + Definition five : foo@{i} = foo@{j} := eq_refl. + End univs. + + (* inference tries and succeeds with syntactic equality which doesn't eta expand *) + Fail Definition infer@{i j k|i < k, j < k, k < eq.u0} + : foo@{i} = foo@{j} :> (nat -> Type@{k}) + := eq_refl. + +End Simple. + +Module WithRed. + (** this test needs to reduce the parameter's type to work *) + + + Inductive foo@{i j} (b:bool) (x:if b return Type@{j} then Type@{i} else nat) : Type@{i} := . + + (* on [refl (fun x => f x)] this computes to [refl f] *) + Definition eta_out {A B} (f g : forall x : A, B x) (e : (fun x => f x) = (fun x => g x)) : f = g. + Proof. + change (f = g) in e. destruct e;reflexivity. + Defined. + + Section univs. + Universes i j k. + Constraint i < j. (* fail instead of forcing equality *) + + Definition one : (fun n => foo@{i k} false n) = fun n => foo@{j k} false n := eq_refl. + + Definition two : foo@{i k} false = foo@{j k} false := eta_out _ _ one. + + Definition two' : foo@{i k} false = foo@{j k} false := Eval compute in two. + + (* Failure of SR doesn't just mean that the type changes, sometimes + we lose being well-typed entirely. *) + Definition three := @eq_refl (foo@{i k} false = foo@{j k} false) two. + Definition four := Eval compute in three. + + Definition five : foo@{i k} false = foo@{j k} false := eq_refl. + End univs. + + (* inference tries and succeeds with syntactic equality which doesn't eta expand *) + Fail Definition infer@{i j k|i < k, j < k, k < eq.u0} + : foo@{i k} false = foo@{j k} false :> (nat -> Type@{k}) + := eq_refl. + +End WithRed. diff --git a/test-suite/bugs/bug_9490.v b/test-suite/bugs/closed/bug_9490.v index a5def40c49..a5def40c49 100644 --- a/test-suite/bugs/bug_9490.v +++ b/test-suite/bugs/closed/bug_9490.v diff --git a/test-suite/bugs/bug_9532.v b/test-suite/bugs/closed/bug_9532.v index d198d45f2f..d198d45f2f 100644 --- a/test-suite/bugs/bug_9532.v +++ b/test-suite/bugs/closed/bug_9532.v diff --git a/test-suite/bugs/opened/bug_2904.v b/test-suite/bugs/opened/bug_2904.v new file mode 100644 index 0000000000..da30a509ac --- /dev/null +++ b/test-suite/bugs/opened/bug_2904.v @@ -0,0 +1,18 @@ +Module Type S. +Parameter t : Type. +Module M'. +Parameter t : Type. +Definition u := S.t. +End M'. +End S. + +Module M : S. +Definition t := unit. +Module M'. +Definition t := bool. +Definition u := M.t. +End M'. +End M. + +Require Extraction. +Fail Extraction TestCompile M. diff --git a/test-suite/bugs/opened/bug_5996.v b/test-suite/bugs/opened/bug_5996.v new file mode 100644 index 0000000000..2e81a183cd --- /dev/null +++ b/test-suite/bugs/opened/bug_5996.v @@ -0,0 +1,19 @@ +(* Original example *) +Goal Type. + let c := constr:(prod nat nat) in + let c' := (eval pattern nat in c) in + let c' := lazymatch c' with ?f _ => f end in + let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in + exact c''. +Fail Defined. +Abort. + +(* Workaround *) +Goal Type. + let c := constr:(prod nat nat) in + let c' := (eval pattern nat in c) in + let c' := lazymatch c' with ?f _ => f end in + let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in + let _ := type of c'' in + exact c''. +Defined. diff --git a/test-suite/coqdoc/details.html.out b/test-suite/coqdoc/details.html.out new file mode 100644 index 0000000000..e1f1ad9867 --- /dev/null +++ b/test-suite/coqdoc/details.html.out @@ -0,0 +1,48 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.details</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.details</h1> + +<div class="code"> +</div> +<details><div class="code"> +<span class="id" title="keyword">Definition</span> <a id="foo" class="idref" href="#foo"><span class="id" title="definition">foo</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> := 3.<br/> +</div> +</details><div class="code"> + +<br/> +</div> +<details><summary>Foo bar </summary><div class="code"> +<span class="id" title="keyword">Fixpoint</span> <a id="idnat" class="idref" href="#idnat"><span class="id" title="definition">idnat</span></a> (<a id="x:1" class="idref" href="#x:1"><span class="id" title="binder">x</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> :=<br/> + <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.details.html#x:1"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> + | <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#S"><span class="id" title="constructor">S</span></a> <span class="id" title="var">x</span> ⇒ <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#S"><span class="id" title="constructor">S</span></a> (<a class="idref" href="Coqdoc.details.html#idnat:2"><span class="id" title="definition">idnat</span></a> <a class="idref" href="Coqdoc.details.html#x:1"><span class="id" title="variable">x</span></a>)<br/> + | 0 ⇒ 0<br/> + <span class="id" title="keyword">end</span>.<br/> +</div> +</details><div class="code"> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/details.tex.out b/test-suite/coqdoc/details.tex.out new file mode 100644 index 0000000000..37778944ba --- /dev/null +++ b/test-suite/coqdoc/details.tex.out @@ -0,0 +1,44 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.details}{Library }{Coqdoc.details} + +\begin{coqdoccode} +\end{coqdoccode} +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.details.foo}{foo}{\coqdocdefinition{foo}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} := 3.\coqdoceol +\end{coqdoccode} +\begin{coqdoccode} +\coqdocemptyline +\end{coqdoccode} +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Fixpoint} \coqdef{Coqdoc.details.idnat}{idnat}{\coqdocdefinition{idnat}} (\coqdef{Coqdoc.details.x:1}{x}{\coqdocbinder{x}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} :=\coqdoceol +\coqdocindent{1.00em} +\coqdockw{match} \coqref{Coqdoc.details.x:1}{\coqdocvariable{x}} \coqdockw{with}\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqexternalref{S}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{S}} \coqdocvar{x} \ensuremath{\Rightarrow} \coqexternalref{S}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{S}} (\coqref{Coqdoc.details.idnat:2}{\coqdocdefinition{idnat}} \coqref{Coqdoc.details.x:1}{\coqdocvariable{x}})\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} 0 \ensuremath{\Rightarrow} 0\coqdoceol +\coqdocindent{1.00em} +\coqdockw{end}.\coqdoceol +\end{coqdoccode} +\begin{coqdoccode} +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/details.v b/test-suite/coqdoc/details.v new file mode 100644 index 0000000000..208e60317d --- /dev/null +++ b/test-suite/coqdoc/details.v @@ -0,0 +1,11 @@ +(* begin details *) +Definition foo : nat := 3. +(* end details *) + +(* begin details : Foo bar *) +Fixpoint idnat (x : nat) : nat := + match x with + | S x => S (idnat x) + | 0 => 0 + end. +(* end details *) diff --git a/test-suite/micromega/bug_12790.v b/test-suite/micromega/bug_12790.v new file mode 100644 index 0000000000..39d640ebd9 --- /dev/null +++ b/test-suite/micromega/bug_12790.v @@ -0,0 +1,8 @@ +Require Import Lia. + +Goal forall (a b c d x: nat), +S c = a - b -> x <= x + (S c) * d. +Proof. +intros a b c d x H. +lia. +Qed. diff --git a/test-suite/micromega/bug_12791.v b/test-suite/micromega/bug_12791.v new file mode 100644 index 0000000000..8aec1904a4 --- /dev/null +++ b/test-suite/micromega/bug_12791.v @@ -0,0 +1,9 @@ +Require Import Lia. + +Definition t := nat. + +Goal forall (a b: t), let c := a in b = a -> b = c. +Proof. + intros a b c H. + lia. +Qed. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index e0aa758812..c28bb14eb3 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -84,8 +84,6 @@ Argument lists should agree on the names they provide. The command has indeed failed with message: Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Some argument names are duplicated: F -The command has indeed failed with message: Argument number 3 is a trailing implicit, so it can't be declared non maximal. Please use { } instead of [ ]. The command has indeed failed with message: diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v index 6ac09cf771..6001850046 100644 --- a/test-suite/output/Arguments_renaming.v +++ b/test-suite/output/Arguments_renaming.v @@ -48,7 +48,6 @@ Check @myplus. Fail Arguments eq_refl {F g}, [H] k. Fail Arguments eq_refl {F}, [F] : rename. -Fail Arguments eq_refl {F F}, [F] F : rename. Fail Arguments eq {A} x [z] : rename. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. diff --git a/test-suite/output/ErrorLocation_12774_1.out b/test-suite/output/ErrorLocation_12774_1.out new file mode 100644 index 0000000000..e27992ed59 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_1.out @@ -0,0 +1,3 @@ +File "stdin", line 2, characters 13-14: +Error: The term "0" has type "nat" while it is expected to have type "Type". + diff --git a/test-suite/output/ErrorLocation_12774_1.v b/test-suite/output/ErrorLocation_12774_1.v new file mode 100644 index 0000000000..8516d402d1 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_1.v @@ -0,0 +1,3 @@ +Goal Type. +simpl; exact 0. +Abort. diff --git a/test-suite/output/ErrorLocation_12774_2.out b/test-suite/output/ErrorLocation_12774_2.out new file mode 100644 index 0000000000..434275eca5 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_2.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 9-10: +Error: The term "0" has type "nat" while it is expected to have type "Type". + diff --git a/test-suite/output/ErrorLocation_12774_2.v b/test-suite/output/ErrorLocation_12774_2.v new file mode 100644 index 0000000000..e50e1caa0f --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_2.v @@ -0,0 +1,4 @@ +Ltac f := simpl. +Goal Type. +f; exact 0. +Abort. diff --git a/test-suite/output/ErrorLocation_12774_3.out b/test-suite/output/ErrorLocation_12774_3.out new file mode 100644 index 0000000000..dbd3dbd1e2 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_3.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-1: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_12774_3.v b/test-suite/output/ErrorLocation_12774_3.v new file mode 100644 index 0000000000..c624402a81 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_3.v @@ -0,0 +1,4 @@ +Ltac f := auto; intro. +Goal False. +f. +Abort. diff --git a/test-suite/output/ErrorLocation_tac_in_term_1.out b/test-suite/output/ErrorLocation_tac_in_term_1.out new file mode 100644 index 0000000000..55ad5a36da --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_1.out @@ -0,0 +1,4 @@ +File "stdin", line 2, characters 21-25: +Error: +The term "true" has type "bool" while it is expected to have type "nat". + diff --git a/test-suite/output/ErrorLocation_tac_in_term_1.v b/test-suite/output/ErrorLocation_tac_in_term_1.v new file mode 100644 index 0000000000..ef0b5aa757 --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_1.v @@ -0,0 +1,3 @@ +Goal True. +apply ltac:(apply (S true)). +Abort. diff --git a/test-suite/output/ErrorLocation_tac_in_term_2.out b/test-suite/output/ErrorLocation_tac_in_term_2.out new file mode 100644 index 0000000000..5bff5ede43 --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_2.out @@ -0,0 +1,4 @@ +File "stdin", line 4, characters 12-20: +Error: +The term "true" has type "bool" while it is expected to have type "nat". + diff --git a/test-suite/output/ErrorLocation_tac_in_term_2.v b/test-suite/output/ErrorLocation_tac_in_term_2.v new file mode 100644 index 0000000000..e0fc2a9f4f --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_2.v @@ -0,0 +1,5 @@ +Ltac f x y := apply (x y). + +Goal True. +apply ltac:(f S true). +Abort. diff --git a/test-suite/output/Error_msg_diffs.out b/test-suite/output/Error_msg_diffs.out index 3e337e892d..2645524a70 100644 --- a/test-suite/output/Error_msg_diffs.out +++ b/test-suite/output/Error_msg_diffs.out @@ -1,4 +1,4 @@ -File "stdin", line 32, characters 0-12: +File "stdin", line 32, characters 0-11: [37;41;1mError:[0m In environment T : [33;1mType[0m diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index ef7667936c..2265028d3e 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,7 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -Arguments d2 [x x0]%nat_scope +Arguments d2 [x x]%nat_scope map id (1 :: nil) : list nat map id' (1 :: nil) diff --git a/test-suite/output/RecordMissingField.out b/test-suite/output/RecordMissingField.out index 7c80a6065f..28beee90b2 100644 --- a/test-suite/output/RecordMissingField.out +++ b/test-suite/output/RecordMissingField.out @@ -1,4 +1,16 @@ -File "stdin", line 8, characters 5-22: -Error: Cannot infer field y2p of record point2d in environment: -p : point2d - +The command has indeed failed with message: +The following term contains unresolved implicit arguments: + (fun p : point2d => {| x2p := x2p p + 1; y2p := ?y2p |}) +More precisely: +- ?y2p: Cannot infer field y2p of record point2d in environment: + p : point2d +The command has indeed failed with message: +The following term contains unresolved implicit arguments: + (fun p : point2d => {| x2p := x2p p + (fun n : nat => ?n) 1; y2p := ?y2p |}) +More precisely: +- ?n: Cannot infer this placeholder of type "nat" in + environment: + p : point2d + n : nat +- ?y2p: Cannot infer field y2p of record point2d in environment: + p : point2d diff --git a/test-suite/output/RecordMissingField.v b/test-suite/output/RecordMissingField.v index 84f1748fa0..8ca721564b 100644 --- a/test-suite/output/RecordMissingField.v +++ b/test-suite/output/RecordMissingField.v @@ -3,6 +3,10 @@ should contain missing field, and the inferred type of the record **) Record point2d := mkPoint { x2p: nat; y2p: nat }. - -Definition increment_x (p: point2d) : point2d := +Fail Definition increment_x (p: point2d) : point2d := {| x2p := x2p p + 1; |}. + +(* Here there is also an unresolved implicit, which should give an + understadable error as well *) +Fail Definition increment_x (p: point2d) : point2d := + {| x2p := x2p p + (fun n => _) 1; |}. diff --git a/test-suite/output/ssr_error_multiple_intro_after_case.out b/test-suite/output/ssr_error_multiple_intro_after_case.out new file mode 100644 index 0000000000..51fb208ae9 --- /dev/null +++ b/test-suite/output/ssr_error_multiple_intro_after_case.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-11: +Error: x already used + diff --git a/test-suite/output/ssr_error_multiple_intro_after_case.v b/test-suite/output/ssr_error_multiple_intro_after_case.v new file mode 100644 index 0000000000..1f87966693 --- /dev/null +++ b/test-suite/output/ssr_error_multiple_intro_after_case.v @@ -0,0 +1,3 @@ +Require Import ssreflect. +Goal forall p : nat * nat , True. +case => x x. diff --git a/test-suite/primitive/float/compare.v b/test-suite/primitive/float/compare.v index 23d1e5bbae..75fd5c426f 100644 --- a/test-suite/primitive/float/compare.v +++ b/test-suite/primitive/float/compare.v @@ -6,380 +6,380 @@ Definition min_denorm := Eval compute in ldexp one (-1074)%Z. Definition min_norm := Eval compute in ldexp one (-1024)%Z. -Check (eq_refl false : nan == nan = false). -Check (eq_refl false : nan == nan = false). -Check (eq_refl false : nan < nan = false). -Check (eq_refl false : nan < nan = false). -Check (eq_refl false : nan <= nan = false). -Check (eq_refl false : nan <= nan = false). +Check (eq_refl false : nan =? nan = false). +Check (eq_refl false : nan =? nan = false). +Check (eq_refl false : nan <? nan = false). +Check (eq_refl false : nan <? nan = false). +Check (eq_refl false : nan <=? nan = false). +Check (eq_refl false : nan <=? nan = false). Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). -Check (eq_refl false <: nan == nan = false). -Check (eq_refl false <: nan == nan = false). -Check (eq_refl false <: nan < nan = false). -Check (eq_refl false <: nan < nan = false). -Check (eq_refl false <: nan <= nan = false). -Check (eq_refl false <: nan <= nan = false). +Check (eq_refl false <: nan =? nan = false). +Check (eq_refl false <: nan =? nan = false). +Check (eq_refl false <: nan <? nan = false). +Check (eq_refl false <: nan <? nan = false). +Check (eq_refl false <: nan <=? nan = false). +Check (eq_refl false <: nan <=? nan = false). Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). -Check (eq_refl false <<: nan == nan = false). -Check (eq_refl false <<: nan == nan = false). -Check (eq_refl false <<: nan < nan = false). -Check (eq_refl false <<: nan < nan = false). -Check (eq_refl false <<: nan <= nan = false). -Check (eq_refl false <<: nan <= nan = false). +Check (eq_refl false <<: nan =? nan = false). +Check (eq_refl false <<: nan =? nan = false). +Check (eq_refl false <<: nan <? nan = false). +Check (eq_refl false <<: nan <? nan = false). +Check (eq_refl false <<: nan <=? nan = false). +Check (eq_refl false <<: nan <=? nan = false). Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). -Check (eq_refl false : nan == - nan = false). -Check (eq_refl false : - nan == nan = false). -Check (eq_refl false : nan < - nan = false). -Check (eq_refl false : - nan < nan = false). -Check (eq_refl false : nan <= - nan = false). -Check (eq_refl false : - nan <= nan = false). +Check (eq_refl false : nan =? - nan = false). +Check (eq_refl false : - nan =? nan = false). +Check (eq_refl false : nan <? - nan = false). +Check (eq_refl false : - nan <? nan = false). +Check (eq_refl false : nan <=? - nan = false). +Check (eq_refl false : - nan <=? nan = false). Check (eq_refl FNotComparable : nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable : - nan ?= nan = FNotComparable). -Check (eq_refl false <: nan == - nan = false). -Check (eq_refl false <: - nan == nan = false). -Check (eq_refl false <: nan < - nan = false). -Check (eq_refl false <: - nan < nan = false). -Check (eq_refl false <: nan <= - nan = false). -Check (eq_refl false <: - nan <= nan = false). +Check (eq_refl false <: nan =? - nan = false). +Check (eq_refl false <: - nan =? nan = false). +Check (eq_refl false <: nan <? - nan = false). +Check (eq_refl false <: - nan <? nan = false). +Check (eq_refl false <: nan <=? - nan = false). +Check (eq_refl false <: - nan <=? nan = false). Check (eq_refl FNotComparable <: nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable <: - nan ?= nan = FNotComparable). -Check (eq_refl false <<: nan == - nan = false). -Check (eq_refl false <<: - nan == nan = false). -Check (eq_refl false <<: nan < - nan = false). -Check (eq_refl false <<: - nan < nan = false). -Check (eq_refl false <<: nan <= - nan = false). -Check (eq_refl false <<: - nan <= nan = false). +Check (eq_refl false <<: nan =? - nan = false). +Check (eq_refl false <<: - nan =? nan = false). +Check (eq_refl false <<: nan <? - nan = false). +Check (eq_refl false <<: - nan <? nan = false). +Check (eq_refl false <<: nan <=? - nan = false). +Check (eq_refl false <<: - nan <=? nan = false). Check (eq_refl FNotComparable <<: nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable <<: - nan ?= nan = FNotComparable). -Check (eq_refl true : one == one = true). -Check (eq_refl true : one == one = true). -Check (eq_refl false : one < one = false). -Check (eq_refl false : one < one = false). -Check (eq_refl true : one <= one = true). -Check (eq_refl true : one <= one = true). +Check (eq_refl true : one =? one = true). +Check (eq_refl true : one =? one = true). +Check (eq_refl false : one <? one = false). +Check (eq_refl false : one <? one = false). +Check (eq_refl true : one <=? one = true). +Check (eq_refl true : one <=? one = true). Check (eq_refl FEq : one ?= one = FEq). Check (eq_refl FEq : one ?= one = FEq). -Check (eq_refl true <: one == one = true). -Check (eq_refl true <: one == one = true). -Check (eq_refl false <: one < one = false). -Check (eq_refl false <: one < one = false). -Check (eq_refl true <: one <= one = true). -Check (eq_refl true <: one <= one = true). +Check (eq_refl true <: one =? one = true). +Check (eq_refl true <: one =? one = true). +Check (eq_refl false <: one <? one = false). +Check (eq_refl false <: one <? one = false). +Check (eq_refl true <: one <=? one = true). +Check (eq_refl true <: one <=? one = true). Check (eq_refl FEq <: one ?= one = FEq). Check (eq_refl FEq <: one ?= one = FEq). -Check (eq_refl true <<: one == one = true). -Check (eq_refl true <<: one == one = true). -Check (eq_refl false <<: one < one = false). -Check (eq_refl false <<: one < one = false). -Check (eq_refl true <<: one <= one = true). -Check (eq_refl true <<: one <= one = true). +Check (eq_refl true <<: one =? one = true). +Check (eq_refl true <<: one =? one = true). +Check (eq_refl false <<: one <? one = false). +Check (eq_refl false <<: one <? one = false). +Check (eq_refl true <<: one <=? one = true). +Check (eq_refl true <<: one <=? one = true). Check (eq_refl FEq <<: one ?= one = FEq). Check (eq_refl FEq <<: one ?= one = FEq). -Check (eq_refl true : zero == zero = true). -Check (eq_refl true : zero == zero = true). -Check (eq_refl false : zero < zero = false). -Check (eq_refl false : zero < zero = false). -Check (eq_refl true : zero <= zero = true). -Check (eq_refl true : zero <= zero = true). +Check (eq_refl true : zero =? zero = true). +Check (eq_refl true : zero =? zero = true). +Check (eq_refl false : zero <? zero = false). +Check (eq_refl false : zero <? zero = false). +Check (eq_refl true : zero <=? zero = true). +Check (eq_refl true : zero <=? zero = true). Check (eq_refl FEq : zero ?= zero = FEq). Check (eq_refl FEq : zero ?= zero = FEq). -Check (eq_refl true <: zero == zero = true). -Check (eq_refl true <: zero == zero = true). -Check (eq_refl false <: zero < zero = false). -Check (eq_refl false <: zero < zero = false). -Check (eq_refl true <: zero <= zero = true). -Check (eq_refl true <: zero <= zero = true). +Check (eq_refl true <: zero =? zero = true). +Check (eq_refl true <: zero =? zero = true). +Check (eq_refl false <: zero <? zero = false). +Check (eq_refl false <: zero <? zero = false). +Check (eq_refl true <: zero <=? zero = true). +Check (eq_refl true <: zero <=? zero = true). Check (eq_refl FEq <: zero ?= zero = FEq). Check (eq_refl FEq <: zero ?= zero = FEq). -Check (eq_refl true <<: zero == zero = true). -Check (eq_refl true <<: zero == zero = true). -Check (eq_refl false <<: zero < zero = false). -Check (eq_refl false <<: zero < zero = false). -Check (eq_refl true <<: zero <= zero = true). -Check (eq_refl true <<: zero <= zero = true). +Check (eq_refl true <<: zero =? zero = true). +Check (eq_refl true <<: zero =? zero = true). +Check (eq_refl false <<: zero <? zero = false). +Check (eq_refl false <<: zero <? zero = false). +Check (eq_refl true <<: zero <=? zero = true). +Check (eq_refl true <<: zero <=? zero = true). Check (eq_refl FEq <<: zero ?= zero = FEq). Check (eq_refl FEq <<: zero ?= zero = FEq). -Check (eq_refl true : zero == - zero = true). -Check (eq_refl true : - zero == zero = true). -Check (eq_refl false : zero < - zero = false). -Check (eq_refl false : - zero < zero = false). -Check (eq_refl true : zero <= - zero = true). -Check (eq_refl true : - zero <= zero = true). +Check (eq_refl true : zero =? - zero = true). +Check (eq_refl true : - zero =? zero = true). +Check (eq_refl false : zero <? - zero = false). +Check (eq_refl false : - zero <? zero = false). +Check (eq_refl true : zero <=? - zero = true). +Check (eq_refl true : - zero <=? zero = true). Check (eq_refl FEq : zero ?= - zero = FEq). Check (eq_refl FEq : - zero ?= zero = FEq). -Check (eq_refl true <: zero == - zero = true). -Check (eq_refl true <: - zero == zero = true). -Check (eq_refl false <: zero < - zero = false). -Check (eq_refl false <: - zero < zero = false). -Check (eq_refl true <: zero <= - zero = true). -Check (eq_refl true <: - zero <= zero = true). +Check (eq_refl true <: zero =? - zero = true). +Check (eq_refl true <: - zero =? zero = true). +Check (eq_refl false <: zero <? - zero = false). +Check (eq_refl false <: - zero <? zero = false). +Check (eq_refl true <: zero <=? - zero = true). +Check (eq_refl true <: - zero <=? zero = true). Check (eq_refl FEq <: zero ?= - zero = FEq). Check (eq_refl FEq <: - zero ?= zero = FEq). -Check (eq_refl true <<: zero == - zero = true). -Check (eq_refl true <<: - zero == zero = true). -Check (eq_refl false <<: zero < - zero = false). -Check (eq_refl false <<: - zero < zero = false). -Check (eq_refl true <<: zero <= - zero = true). -Check (eq_refl true <<: - zero <= zero = true). +Check (eq_refl true <<: zero =? - zero = true). +Check (eq_refl true <<: - zero =? zero = true). +Check (eq_refl false <<: zero <? - zero = false). +Check (eq_refl false <<: - zero <? zero = false). +Check (eq_refl true <<: zero <=? - zero = true). +Check (eq_refl true <<: - zero <=? zero = true). Check (eq_refl FEq <<: zero ?= - zero = FEq). Check (eq_refl FEq <<: - zero ?= zero = FEq). -Check (eq_refl true : - zero == - zero = true). -Check (eq_refl true : - zero == - zero = true). -Check (eq_refl false : - zero < - zero = false). -Check (eq_refl false : - zero < - zero = false). -Check (eq_refl true : - zero <= - zero = true). -Check (eq_refl true : - zero <= - zero = true). +Check (eq_refl true : - zero =? - zero = true). +Check (eq_refl true : - zero =? - zero = true). +Check (eq_refl false : - zero <? - zero = false). +Check (eq_refl false : - zero <? - zero = false). +Check (eq_refl true : - zero <=? - zero = true). +Check (eq_refl true : - zero <=? - zero = true). Check (eq_refl FEq : - zero ?= - zero = FEq). Check (eq_refl FEq : - zero ?= - zero = FEq). -Check (eq_refl true <: - zero == - zero = true). -Check (eq_refl true <: - zero == - zero = true). -Check (eq_refl false <: - zero < - zero = false). -Check (eq_refl false <: - zero < - zero = false). -Check (eq_refl true <: - zero <= - zero = true). -Check (eq_refl true <: - zero <= - zero = true). +Check (eq_refl true <: - zero =? - zero = true). +Check (eq_refl true <: - zero =? - zero = true). +Check (eq_refl false <: - zero <? - zero = false). +Check (eq_refl false <: - zero <? - zero = false). +Check (eq_refl true <: - zero <=? - zero = true). +Check (eq_refl true <: - zero <=? - zero = true). Check (eq_refl FEq <: - zero ?= - zero = FEq). Check (eq_refl FEq <: - zero ?= - zero = FEq). -Check (eq_refl true <<: - zero == - zero = true). -Check (eq_refl true <<: - zero == - zero = true). -Check (eq_refl false <<: - zero < - zero = false). -Check (eq_refl false <<: - zero < - zero = false). -Check (eq_refl true <<: - zero <= - zero = true). -Check (eq_refl true <<: - zero <= - zero = true). +Check (eq_refl true <<: - zero =? - zero = true). +Check (eq_refl true <<: - zero =? - zero = true). +Check (eq_refl false <<: - zero <? - zero = false). +Check (eq_refl false <<: - zero <? - zero = false). +Check (eq_refl true <<: - zero <=? - zero = true). +Check (eq_refl true <<: - zero <=? - zero = true). Check (eq_refl FEq <<: - zero ?= - zero = FEq). Check (eq_refl FEq <<: - zero ?= - zero = FEq). -Check (eq_refl true : infinity == infinity = true). -Check (eq_refl true : infinity == infinity = true). -Check (eq_refl false : infinity < infinity = false). -Check (eq_refl false : infinity < infinity = false). -Check (eq_refl true : infinity <= infinity = true). -Check (eq_refl true : infinity <= infinity = true). +Check (eq_refl true : infinity =? infinity = true). +Check (eq_refl true : infinity =? infinity = true). +Check (eq_refl false : infinity <? infinity = false). +Check (eq_refl false : infinity <? infinity = false). +Check (eq_refl true : infinity <=? infinity = true). +Check (eq_refl true : infinity <=? infinity = true). Check (eq_refl FEq : infinity ?= infinity = FEq). Check (eq_refl FEq : infinity ?= infinity = FEq). -Check (eq_refl true <: infinity == infinity = true). -Check (eq_refl true <: infinity == infinity = true). -Check (eq_refl false <: infinity < infinity = false). -Check (eq_refl false <: infinity < infinity = false). -Check (eq_refl true <: infinity <= infinity = true). -Check (eq_refl true <: infinity <= infinity = true). +Check (eq_refl true <: infinity =? infinity = true). +Check (eq_refl true <: infinity =? infinity = true). +Check (eq_refl false <: infinity <? infinity = false). +Check (eq_refl false <: infinity <? infinity = false). +Check (eq_refl true <: infinity <=? infinity = true). +Check (eq_refl true <: infinity <=? infinity = true). Check (eq_refl FEq <: infinity ?= infinity = FEq). Check (eq_refl FEq <: infinity ?= infinity = FEq). -Check (eq_refl true <<: infinity == infinity = true). -Check (eq_refl true <<: infinity == infinity = true). -Check (eq_refl false <<: infinity < infinity = false). -Check (eq_refl false <<: infinity < infinity = false). -Check (eq_refl true <<: infinity <= infinity = true). -Check (eq_refl true <<: infinity <= infinity = true). +Check (eq_refl true <<: infinity =? infinity = true). +Check (eq_refl true <<: infinity =? infinity = true). +Check (eq_refl false <<: infinity <? infinity = false). +Check (eq_refl false <<: infinity <? infinity = false). +Check (eq_refl true <<: infinity <=? infinity = true). +Check (eq_refl true <<: infinity <=? infinity = true). Check (eq_refl FEq <<: infinity ?= infinity = FEq). Check (eq_refl FEq <<: infinity ?= infinity = FEq). -Check (eq_refl true : - infinity == - infinity = true). -Check (eq_refl true : - infinity == - infinity = true). -Check (eq_refl false : - infinity < - infinity = false). -Check (eq_refl false : - infinity < - infinity = false). -Check (eq_refl true : - infinity <= - infinity = true). -Check (eq_refl true : - infinity <= - infinity = true). +Check (eq_refl true : - infinity =? - infinity = true). +Check (eq_refl true : - infinity =? - infinity = true). +Check (eq_refl false : - infinity <? - infinity = false). +Check (eq_refl false : - infinity <? - infinity = false). +Check (eq_refl true : - infinity <=? - infinity = true). +Check (eq_refl true : - infinity <=? - infinity = true). Check (eq_refl FEq : - infinity ?= - infinity = FEq). Check (eq_refl FEq : - infinity ?= - infinity = FEq). -Check (eq_refl true <: - infinity == - infinity = true). -Check (eq_refl true <: - infinity == - infinity = true). -Check (eq_refl false <: - infinity < - infinity = false). -Check (eq_refl false <: - infinity < - infinity = false). -Check (eq_refl true <: - infinity <= - infinity = true). -Check (eq_refl true <: - infinity <= - infinity = true). +Check (eq_refl true <: - infinity =? - infinity = true). +Check (eq_refl true <: - infinity =? - infinity = true). +Check (eq_refl false <: - infinity <? - infinity = false). +Check (eq_refl false <: - infinity <? - infinity = false). +Check (eq_refl true <: - infinity <=? - infinity = true). +Check (eq_refl true <: - infinity <=? - infinity = true). Check (eq_refl FEq <: - infinity ?= - infinity = FEq). Check (eq_refl FEq <: - infinity ?= - infinity = FEq). -Check (eq_refl true <<: - infinity == - infinity = true). -Check (eq_refl true <<: - infinity == - infinity = true). -Check (eq_refl false <<: - infinity < - infinity = false). -Check (eq_refl false <<: - infinity < - infinity = false). -Check (eq_refl true <<: - infinity <= - infinity = true). -Check (eq_refl true <<: - infinity <= - infinity = true). +Check (eq_refl true <<: - infinity =? - infinity = true). +Check (eq_refl true <<: - infinity =? - infinity = true). +Check (eq_refl false <<: - infinity <? - infinity = false). +Check (eq_refl false <<: - infinity <? - infinity = false). +Check (eq_refl true <<: - infinity <=? - infinity = true). +Check (eq_refl true <<: - infinity <=? - infinity = true). Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). -Check (eq_refl false : min_denorm == min_norm = false). -Check (eq_refl false : min_norm == min_denorm = false). -Check (eq_refl true : min_denorm < min_norm = true). -Check (eq_refl false : min_norm < min_denorm = false). -Check (eq_refl true : min_denorm <= min_norm = true). -Check (eq_refl false : min_norm <= min_denorm = false). +Check (eq_refl false : min_denorm =? min_norm = false). +Check (eq_refl false : min_norm =? min_denorm = false). +Check (eq_refl true : min_denorm <? min_norm = true). +Check (eq_refl false : min_norm <? min_denorm = false). +Check (eq_refl true : min_denorm <=? min_norm = true). +Check (eq_refl false : min_norm <=? min_denorm = false). Check (eq_refl FLt : min_denorm ?= min_norm = FLt). Check (eq_refl FGt : min_norm ?= min_denorm = FGt). -Check (eq_refl false <: min_denorm == min_norm = false). -Check (eq_refl false <: min_norm == min_denorm = false). -Check (eq_refl true <: min_denorm < min_norm = true). -Check (eq_refl false <: min_norm < min_denorm = false). -Check (eq_refl true <: min_denorm <= min_norm = true). -Check (eq_refl false <: min_norm <= min_denorm = false). +Check (eq_refl false <: min_denorm =? min_norm = false). +Check (eq_refl false <: min_norm =? min_denorm = false). +Check (eq_refl true <: min_denorm <? min_norm = true). +Check (eq_refl false <: min_norm <? min_denorm = false). +Check (eq_refl true <: min_denorm <=? min_norm = true). +Check (eq_refl false <: min_norm <=? min_denorm = false). Check (eq_refl FLt <: min_denorm ?= min_norm = FLt). Check (eq_refl FGt <: min_norm ?= min_denorm = FGt). -Check (eq_refl false <<: min_denorm == min_norm = false). -Check (eq_refl false <<: min_norm == min_denorm = false). -Check (eq_refl true <<: min_denorm < min_norm = true). -Check (eq_refl false <<: min_norm < min_denorm = false). -Check (eq_refl true <<: min_denorm <= min_norm = true). -Check (eq_refl false <<: min_norm <= min_denorm = false). +Check (eq_refl false <<: min_denorm =? min_norm = false). +Check (eq_refl false <<: min_norm =? min_denorm = false). +Check (eq_refl true <<: min_denorm <? min_norm = true). +Check (eq_refl false <<: min_norm <? min_denorm = false). +Check (eq_refl true <<: min_denorm <=? min_norm = true). +Check (eq_refl false <<: min_norm <=? min_denorm = false). Check (eq_refl FLt <<: min_denorm ?= min_norm = FLt). Check (eq_refl FGt <<: min_norm ?= min_denorm = FGt). -Check (eq_refl false : min_denorm == one = false). -Check (eq_refl false : one == min_denorm = false). -Check (eq_refl true : min_denorm < one = true). -Check (eq_refl false : one < min_denorm = false). -Check (eq_refl true : min_denorm <= one = true). -Check (eq_refl false : one <= min_denorm = false). +Check (eq_refl false : min_denorm =? one = false). +Check (eq_refl false : one =? min_denorm = false). +Check (eq_refl true : min_denorm <? one = true). +Check (eq_refl false : one <? min_denorm = false). +Check (eq_refl true : min_denorm <=? one = true). +Check (eq_refl false : one <=? min_denorm = false). Check (eq_refl FLt : min_denorm ?= one = FLt). Check (eq_refl FGt : one ?= min_denorm = FGt). -Check (eq_refl false <: min_denorm == one = false). -Check (eq_refl false <: one == min_denorm = false). -Check (eq_refl true <: min_denorm < one = true). -Check (eq_refl false <: one < min_denorm = false). -Check (eq_refl true <: min_denorm <= one = true). -Check (eq_refl false <: one <= min_denorm = false). +Check (eq_refl false <: min_denorm =? one = false). +Check (eq_refl false <: one =? min_denorm = false). +Check (eq_refl true <: min_denorm <? one = true). +Check (eq_refl false <: one <? min_denorm = false). +Check (eq_refl true <: min_denorm <=? one = true). +Check (eq_refl false <: one <=? min_denorm = false). Check (eq_refl FLt <: min_denorm ?= one = FLt). Check (eq_refl FGt <: one ?= min_denorm = FGt). -Check (eq_refl false <<: min_denorm == one = false). -Check (eq_refl false <<: one == min_denorm = false). -Check (eq_refl true <<: min_denorm < one = true). -Check (eq_refl false <<: one < min_denorm = false). -Check (eq_refl true <<: min_denorm <= one = true). -Check (eq_refl false <<: one <= min_denorm = false). +Check (eq_refl false <<: min_denorm =? one = false). +Check (eq_refl false <<: one =? min_denorm = false). +Check (eq_refl true <<: min_denorm <? one = true). +Check (eq_refl false <<: one <? min_denorm = false). +Check (eq_refl true <<: min_denorm <=? one = true). +Check (eq_refl false <<: one <=? min_denorm = false). Check (eq_refl FLt <<: min_denorm ?= one = FLt). Check (eq_refl FGt <<: one ?= min_denorm = FGt). -Check (eq_refl false : min_norm == one = false). -Check (eq_refl false : one == min_norm = false). -Check (eq_refl true : min_norm < one = true). -Check (eq_refl false : one < min_norm = false). -Check (eq_refl true : min_norm <= one = true). -Check (eq_refl false : one <= min_norm = false). +Check (eq_refl false : min_norm =? one = false). +Check (eq_refl false : one =? min_norm = false). +Check (eq_refl true : min_norm <? one = true). +Check (eq_refl false : one <? min_norm = false). +Check (eq_refl true : min_norm <=? one = true). +Check (eq_refl false : one <=? min_norm = false). Check (eq_refl FLt : min_norm ?= one = FLt). Check (eq_refl FGt : one ?= min_norm = FGt). -Check (eq_refl false <: min_norm == one = false). -Check (eq_refl false <: one == min_norm = false). -Check (eq_refl true <: min_norm < one = true). -Check (eq_refl false <: one < min_norm = false). -Check (eq_refl true <: min_norm <= one = true). -Check (eq_refl false <: one <= min_norm = false). +Check (eq_refl false <: min_norm =? one = false). +Check (eq_refl false <: one =? min_norm = false). +Check (eq_refl true <: min_norm <? one = true). +Check (eq_refl false <: one <? min_norm = false). +Check (eq_refl true <: min_norm <=? one = true). +Check (eq_refl false <: one <=? min_norm = false). Check (eq_refl FLt <: min_norm ?= one = FLt). Check (eq_refl FGt <: one ?= min_norm = FGt). -Check (eq_refl false <<: min_norm == one = false). -Check (eq_refl false <<: one == min_norm = false). -Check (eq_refl true <<: min_norm < one = true). -Check (eq_refl false <<: one < min_norm = false). -Check (eq_refl true <<: min_norm <= one = true). -Check (eq_refl false <<: one <= min_norm = false). +Check (eq_refl false <<: min_norm =? one = false). +Check (eq_refl false <<: one =? min_norm = false). +Check (eq_refl true <<: min_norm <? one = true). +Check (eq_refl false <<: one <? min_norm = false). +Check (eq_refl true <<: min_norm <=? one = true). +Check (eq_refl false <<: one <=? min_norm = false). Check (eq_refl FLt <<: min_norm ?= one = FLt). Check (eq_refl FGt <<: one ?= min_norm = FGt). -Check (eq_refl false : one == infinity = false). -Check (eq_refl false : infinity == one = false). -Check (eq_refl true : one < infinity = true). -Check (eq_refl false : infinity < one = false). -Check (eq_refl true : one <= infinity = true). -Check (eq_refl false : infinity <= one = false). +Check (eq_refl false : one =? infinity = false). +Check (eq_refl false : infinity =? one = false). +Check (eq_refl true : one <? infinity = true). +Check (eq_refl false : infinity <? one = false). +Check (eq_refl true : one <=? infinity = true). +Check (eq_refl false : infinity <=? one = false). Check (eq_refl FLt : one ?= infinity = FLt). Check (eq_refl FGt : infinity ?= one = FGt). -Check (eq_refl false <: one == infinity = false). -Check (eq_refl false <: infinity == one = false). -Check (eq_refl true <: one < infinity = true). -Check (eq_refl false <: infinity < one = false). -Check (eq_refl true <: one <= infinity = true). -Check (eq_refl false <: infinity <= one = false). +Check (eq_refl false <: one =? infinity = false). +Check (eq_refl false <: infinity =? one = false). +Check (eq_refl true <: one <? infinity = true). +Check (eq_refl false <: infinity <? one = false). +Check (eq_refl true <: one <=? infinity = true). +Check (eq_refl false <: infinity <=? one = false). Check (eq_refl FLt <: one ?= infinity = FLt). Check (eq_refl FGt <: infinity ?= one = FGt). -Check (eq_refl false <<: one == infinity = false). -Check (eq_refl false <<: infinity == one = false). -Check (eq_refl true <<: one < infinity = true). -Check (eq_refl false <<: infinity < one = false). -Check (eq_refl true <<: one <= infinity = true). -Check (eq_refl false <<: infinity <= one = false). +Check (eq_refl false <<: one =? infinity = false). +Check (eq_refl false <<: infinity =? one = false). +Check (eq_refl true <<: one <? infinity = true). +Check (eq_refl false <<: infinity <? one = false). +Check (eq_refl true <<: one <=? infinity = true). +Check (eq_refl false <<: infinity <=? one = false). Check (eq_refl FLt <<: one ?= infinity = FLt). Check (eq_refl FGt <<: infinity ?= one = FGt). -Check (eq_refl false : - infinity == infinity = false). -Check (eq_refl false : infinity == - infinity = false). -Check (eq_refl true : - infinity < infinity = true). -Check (eq_refl false : infinity < - infinity = false). -Check (eq_refl true : - infinity <= infinity = true). -Check (eq_refl false : infinity <= - infinity = false). +Check (eq_refl false : - infinity =? infinity = false). +Check (eq_refl false : infinity =? - infinity = false). +Check (eq_refl true : - infinity <? infinity = true). +Check (eq_refl false : infinity <? - infinity = false). +Check (eq_refl true : - infinity <=? infinity = true). +Check (eq_refl false : infinity <=? - infinity = false). Check (eq_refl FLt : - infinity ?= infinity = FLt). Check (eq_refl FGt : infinity ?= - infinity = FGt). -Check (eq_refl false <: - infinity == infinity = false). -Check (eq_refl false <: infinity == - infinity = false). -Check (eq_refl true <: - infinity < infinity = true). -Check (eq_refl false <: infinity < - infinity = false). -Check (eq_refl true <: - infinity <= infinity = true). -Check (eq_refl false <: infinity <= - infinity = false). +Check (eq_refl false <: - infinity =? infinity = false). +Check (eq_refl false <: infinity =? - infinity = false). +Check (eq_refl true <: - infinity <? infinity = true). +Check (eq_refl false <: infinity <? - infinity = false). +Check (eq_refl true <: - infinity <=? infinity = true). +Check (eq_refl false <: infinity <=? - infinity = false). Check (eq_refl FLt <: - infinity ?= infinity = FLt). Check (eq_refl FGt <: infinity ?= - infinity = FGt). -Check (eq_refl false <<: - infinity == infinity = false). -Check (eq_refl false <<: infinity == - infinity = false). -Check (eq_refl true <<: - infinity < infinity = true). -Check (eq_refl false <<: infinity < - infinity = false). -Check (eq_refl true <<: - infinity <= infinity = true). -Check (eq_refl false <<: infinity <= - infinity = false). +Check (eq_refl false <<: - infinity =? infinity = false). +Check (eq_refl false <<: infinity =? - infinity = false). +Check (eq_refl true <<: - infinity <? infinity = true). +Check (eq_refl false <<: infinity <? - infinity = false). +Check (eq_refl true <<: - infinity <=? infinity = true). +Check (eq_refl false <<: infinity <=? - infinity = false). Check (eq_refl FLt <<: - infinity ?= infinity = FLt). Check (eq_refl FGt <<: infinity ?= - infinity = FGt). -Check (eq_refl false : - infinity == one = false). -Check (eq_refl false : one == - infinity = false). -Check (eq_refl true : - infinity < one = true). -Check (eq_refl false : one < - infinity = false). -Check (eq_refl true : - infinity <= one = true). -Check (eq_refl false : one <= - infinity = false). +Check (eq_refl false : - infinity =? one = false). +Check (eq_refl false : one =? - infinity = false). +Check (eq_refl true : - infinity <? one = true). +Check (eq_refl false : one <? - infinity = false). +Check (eq_refl true : - infinity <=? one = true). +Check (eq_refl false : one <=? - infinity = false). Check (eq_refl FLt : - infinity ?= one = FLt). Check (eq_refl FGt : one ?= - infinity = FGt). -Check (eq_refl false <: - infinity == one = false). -Check (eq_refl false <: one == - infinity = false). -Check (eq_refl true <: - infinity < one = true). -Check (eq_refl false <: one < - infinity = false). -Check (eq_refl true <: - infinity <= one = true). -Check (eq_refl false <: one <= - infinity = false). +Check (eq_refl false <: - infinity =? one = false). +Check (eq_refl false <: one =? - infinity = false). +Check (eq_refl true <: - infinity <? one = true). +Check (eq_refl false <: one <? - infinity = false). +Check (eq_refl true <: - infinity <=? one = true). +Check (eq_refl false <: one <=? - infinity = false). Check (eq_refl FLt <: - infinity ?= one = FLt). Check (eq_refl FGt <: one ?= - infinity = FGt). -Check (eq_refl false <<: - infinity == one = false). -Check (eq_refl false <<: one == - infinity = false). -Check (eq_refl true <<: - infinity < one = true). -Check (eq_refl false <<: one < - infinity = false). -Check (eq_refl true <<: - infinity <= one = true). -Check (eq_refl false <<: one <= - infinity = false). +Check (eq_refl false <<: - infinity =? one = false). +Check (eq_refl false <<: one =? - infinity = false). +Check (eq_refl true <<: - infinity <? one = true). +Check (eq_refl false <<: one <? - infinity = false). +Check (eq_refl true <<: - infinity <=? one = true). +Check (eq_refl false <<: one <=? - infinity = false). Check (eq_refl FLt <<: - infinity ?= one = FLt). Check (eq_refl FGt <<: one ?= - infinity = FGt). diff --git a/test-suite/primitive/float/gen_compare.sh b/test-suite/primitive/float/gen_compare.sh index cd87eb4e5b..6e3dd6d04b 100755 --- a/test-suite/primitive/float/gen_compare.sh +++ b/test-suite/primitive/float/gen_compare.sh @@ -20,7 +20,7 @@ genTest() { echo >&2 "genTest expects 10 arguments" fi TACTICS=(":" "<:" "<<:") - OPS=("==" "<" "<=" "?=") + OPS=("=?" "<?" "<=?" "?=") x="$1" y="$2" OPS1=("$3" "$4" "$5" "$6") # for x y diff --git a/test-suite/primitive/uint63/eqb.v b/test-suite/primitive/uint63/eqb.v index dcc0b71f6d..43c98e2b6f 100644 --- a/test-suite/primitive/uint63/eqb.v +++ b/test-suite/primitive/uint63/eqb.v @@ -4,14 +4,14 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 == 1 = true). -Check (eq_refl true <: 1 == 1 = true). -Check (eq_refl true <<: 1 == 1 = true). -Definition compute1 := Eval compute in 1 == 1. +Check (eq_refl : 1 =? 1 = true). +Check (eq_refl true <: 1 =? 1 = true). +Check (eq_refl true <<: 1 =? 1 = true). +Definition compute1 := Eval compute in 1 =? 1. Check (eq_refl compute1 : true = true). -Check (eq_refl : 9223372036854775807 == 0 = false). -Check (eq_refl false <: 9223372036854775807 == 0 = false). -Check (eq_refl false <<: 9223372036854775807 == 0 = false). -Definition compute2 := Eval compute in 9223372036854775807 == 0. +Check (eq_refl : 9223372036854775807 =? 0 = false). +Check (eq_refl false <: 9223372036854775807 =? 0 = false). +Check (eq_refl false <<: 9223372036854775807 =? 0 = false). +Definition compute2 := Eval compute in 9223372036854775807 =? 0. Check (eq_refl compute2 : false = false). diff --git a/test-suite/primitive/uint63/leb.v b/test-suite/primitive/uint63/leb.v index 5354919978..e5142282ae 100644 --- a/test-suite/primitive/uint63/leb.v +++ b/test-suite/primitive/uint63/leb.v @@ -4,20 +4,20 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 <= 1 = true). -Check (eq_refl true <: 1 <= 1 = true). -Check (eq_refl true <<: 1 <= 1 = true). -Definition compute1 := Eval compute in 1 <= 1. +Check (eq_refl : 1 <=? 1 = true). +Check (eq_refl true <: 1 <=? 1 = true). +Check (eq_refl true <<: 1 <=? 1 = true). +Definition compute1 := Eval compute in 1 <=? 1. Check (eq_refl compute1 : true = true). -Check (eq_refl : 1 <= 2 = true). -Check (eq_refl true <: 1 <= 2 = true). -Check (eq_refl true <<: 1 <= 2 = true). -Definition compute2 := Eval compute in 1 <= 2. +Check (eq_refl : 1 <=? 2 = true). +Check (eq_refl true <: 1 <=? 2 = true). +Check (eq_refl true <<: 1 <=? 2 = true). +Definition compute2 := Eval compute in 1 <=? 2. Check (eq_refl compute2 : true = true). -Check (eq_refl : 9223372036854775807 <= 0 = false). -Check (eq_refl false <: 9223372036854775807 <= 0 = false). -Check (eq_refl false <<: 9223372036854775807 <= 0 = false). -Definition compute3 := Eval compute in 9223372036854775807 <= 0. +Check (eq_refl : 9223372036854775807 <=? 0 = false). +Check (eq_refl false <: 9223372036854775807 <=? 0 = false). +Check (eq_refl false <<: 9223372036854775807 <=? 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 <=? 0. Check (eq_refl compute3 : false = false). diff --git a/test-suite/primitive/uint63/ltb.v b/test-suite/primitive/uint63/ltb.v index 7ae5ac6493..50cef6be66 100644 --- a/test-suite/primitive/uint63/ltb.v +++ b/test-suite/primitive/uint63/ltb.v @@ -4,20 +4,20 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 < 1 = false). -Check (eq_refl false <: 1 < 1 = false). -Check (eq_refl false <<: 1 < 1 = false). -Definition compute1 := Eval compute in 1 < 1. +Check (eq_refl : 1 <? 1 = false). +Check (eq_refl false <: 1 <? 1 = false). +Check (eq_refl false <<: 1 <? 1 = false). +Definition compute1 := Eval compute in 1 <? 1. Check (eq_refl compute1 : false = false). -Check (eq_refl : 1 < 2 = true). -Check (eq_refl true <: 1 < 2 = true). -Check (eq_refl true <<: 1 < 2 = true). -Definition compute2 := Eval compute in 1 < 2. +Check (eq_refl : 1 <? 2 = true). +Check (eq_refl true <: 1 <? 2 = true). +Check (eq_refl true <<: 1 <? 2 = true). +Definition compute2 := Eval compute in 1 <? 2. Check (eq_refl compute2 : true = true). -Check (eq_refl : 9223372036854775807 < 0 = false). -Check (eq_refl false <: 9223372036854775807 < 0 = false). -Check (eq_refl false <<: 9223372036854775807 < 0 = false). -Definition compute3 := Eval compute in 9223372036854775807 < 0. +Check (eq_refl : 9223372036854775807 <? 0 = false). +Check (eq_refl false <: 9223372036854775807 <? 0 = false). +Check (eq_refl false <<: 9223372036854775807 <? 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 <? 0. Check (eq_refl compute3 : false = false). diff --git a/test-suite/primitive/uint63/mod.v b/test-suite/primitive/uint63/mod.v index 5307eed493..3ad6312c2c 100644 --- a/test-suite/primitive/uint63/mod.v +++ b/test-suite/primitive/uint63/mod.v @@ -4,14 +4,14 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 6 \% 3 = 0). -Check (eq_refl 0 <: 6 \% 3 = 0). -Check (eq_refl 0 <<: 6 \% 3 = 0). -Definition compute1 := Eval compute in 6 \% 3. +Check (eq_refl : 6 mod 3 = 0). +Check (eq_refl 0 <: 6 mod 3 = 0). +Check (eq_refl 0 <<: 6 mod 3 = 0). +Definition compute1 := Eval compute in 6 mod 3. Check (eq_refl compute1 : 0 = 0). -Check (eq_refl : 5 \% 3 = 2). -Check (eq_refl 2 <: 5 \% 3 = 2). -Check (eq_refl 2 <<: 5 \% 3 = 2). -Definition compute2 := Eval compute in 5 \% 3. +Check (eq_refl : 5 mod 3 = 2). +Check (eq_refl 2 <: 5 mod 3 = 2). +Check (eq_refl 2 <<: 5 mod 3 = 2). +Definition compute2 := Eval compute in 5 mod 3. Check (eq_refl compute2 : 2 = 2). diff --git a/test-suite/primitive/uint63/unsigned.v b/test-suite/primitive/uint63/unsigned.v index 82920bd201..6224e9d15b 100644 --- a/test-suite/primitive/uint63/unsigned.v +++ b/test-suite/primitive/uint63/unsigned.v @@ -11,8 +11,8 @@ Check (eq_refl 0 <<: 1/(0-1) = 0). Definition compute1 := Eval compute in 1/(0-1). Check (eq_refl compute1 : 0 = 0). -Check (eq_refl : 3 \% (0-1) = 3). -Check (eq_refl 3 <: 3 \% (0-1) = 3). -Check (eq_refl 3 <<: 3 \% (0-1) = 3). -Definition compute2 := Eval compute in 3 \% (0-1). +Check (eq_refl : 3 mod (0-1) = 3). +Check (eq_refl 3 <: 3 mod (0-1) = 3). +Check (eq_refl 3 <<: 3 mod (0-1) = 3). +Definition compute2 := Eval compute in 3 mod (0-1). Check (eq_refl compute2 : 3 = 3). diff --git a/test-suite/ssr/noting_to_inject.v b/test-suite/ssr/noting_to_inject.v new file mode 100644 index 0000000000..95bbd3e777 --- /dev/null +++ b/test-suite/ssr/noting_to_inject.v @@ -0,0 +1,9 @@ +Require Import ssreflect ssrfun ssrbool. + + +Goal forall b : bool, b -> False. +Set Warnings "+spurious-ssr-injection". +Fail move=> b []. +Set Warnings "-spurious-ssr-injection". +move=> b []. +Abort. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 563651cfa5..7acaa92b89 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -190,7 +190,7 @@ Record Monad {m : Type -> Type} := { Print Visibility. Print unit. -Arguments unit {m m0 α}. +Arguments unit {m _ α}. Arguments Monad : clear implicits. Notation "'return' t" := (unit t). diff --git a/test-suite/unit-tests/.merlin.in b/test-suite/unit-tests/.merlin.in index b2279de74e..668b431d52 100644 --- a/test-suite/unit-tests/.merlin.in +++ b/test-suite/unit-tests/.merlin.in @@ -3,4 +3,4 @@ REC S ** B ** -PKG oUnit +PKG ounit2 diff --git a/theories/Array/PArray.v b/theories/Array/PArray.v index 282f56267c..3511ba0918 100644 --- a/theories/Array/PArray.v +++ b/theories/Array/PArray.v @@ -45,19 +45,19 @@ Local Open Scope array_scope. Primitive max_length := #array_max_length. (** Axioms *) -Axiom get_out_of_bounds : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. +Axiom get_out_of_bounds : forall A (t:array A) i, (i <? length t) = false -> t.[i] = default t. -Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. +Axiom get_set_same : forall A t i (a:A), (i <? length t) = true -> t.[i<-a].[i] = a. Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. Axiom default_set : forall A t i (a:A), default t.[i<-a] = default t. Axiom get_make : forall A (a:A) size i, (make size a).[i] = a. -Axiom leb_length : forall A (t:array A), length t <= max_length = true. +Axiom leb_length : forall A (t:array A), length t <=? max_length = true. Axiom length_make : forall A size (a:A), - length (make size a) = if size <= max_length then size else max_length. + length (make size a) = if size <=? max_length then size else max_length. Axiom length_set : forall A t i (a:A), length t.[i<-a] = length t. @@ -69,7 +69,7 @@ Axiom length_reroot : forall A (t:array A), length (reroot t) = length t. Axiom array_ext : forall A (t1 t2:array A), length t1 = length t2 -> - (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> + (forall i, i <? length t1 = true -> t1.[i] = t2.[i]) -> default t1 = default t2 -> t1 = t2. @@ -77,7 +77,7 @@ Axiom array_ext : forall A (t1 t2:array A), Lemma default_copy A (t:array A) : default (copy t) = default t. Proof. - assert (irr_lt : length t < length t = false). + assert (irr_lt : length t <? length t = false). destruct (Int63.ltbP (length t) (length t)); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_copy := get_copy A t (length t)). @@ -87,7 +87,7 @@ Qed. Lemma default_make A (a : A) size : default (make size a) = a. Proof. - assert (irr_lt : length (make size a) < length (make size a) = false). + assert (irr_lt : length (make size a) <? length (make size a) = false). destruct (Int63.ltbP (length (make size a)) (length (make size a))); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_make := get_make A a size (length (make size a))). @@ -96,7 +96,7 @@ Qed. Lemma default_reroot A (t:array A) : default (reroot t) = default t. Proof. - assert (irr_lt : length t < length t = false). + assert (irr_lt : length t <? length t = false). destruct (Int63.ltbP (length t) (length t)); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_reroot := get_reroot A t (length t)). @@ -107,16 +107,16 @@ Qed. Lemma get_set_same_default A (t : array A) (i : int) : t.[i <- default t].[i] = default t. Proof. - case_eq (i < length t); intros. + case_eq (i <? length t); intros. rewrite get_set_same; trivial. rewrite get_out_of_bounds, default_set; trivial. rewrite length_set; trivial. Qed. Lemma get_not_default_lt A (t:array A) x : - t.[x] <> default t -> (x < length t) = true. + t.[x] <> default t -> (x <? length t) = true. Proof. intros Hd. - case_eq (x < length t); intros Heq; [trivial | ]. + case_eq (x <? length t); intros Heq; [trivial | ]. elim Hd; rewrite get_out_of_bounds; trivial. Qed. diff --git a/theories/Floats/FloatAxioms.v b/theories/Floats/FloatAxioms.v index f4aa1f81c6..78df357c0f 100644 --- a/theories/Floats/FloatAxioms.v +++ b/theories/Floats/FloatAxioms.v @@ -38,9 +38,9 @@ Qed. Axiom opp_spec : forall x, Prim2SF (-x)%float = SFopp (Prim2SF x). Axiom abs_spec : forall x, Prim2SF (abs x) = SFabs (Prim2SF x). -Axiom eqb_spec : forall x y, (x == y)%float = SFeqb (Prim2SF x) (Prim2SF y). -Axiom ltb_spec : forall x y, (x < y)%float = SFltb (Prim2SF x) (Prim2SF y). -Axiom leb_spec : forall x y, (x <= y)%float = SFleb (Prim2SF x) (Prim2SF y). +Axiom eqb_spec : forall x y, (x =? y)%float = SFeqb (Prim2SF x) (Prim2SF y). +Axiom ltb_spec : forall x y, (x <? y)%float = SFltb (Prim2SF x) (Prim2SF y). +Axiom leb_spec : forall x y, (x <=? y)%float = SFleb (Prim2SF x) (Prim2SF y). Definition flatten_cmp_opt c := match c with diff --git a/theories/Floats/PrimFloat.v b/theories/Floats/PrimFloat.v index e5a9748481..ed7947aa63 100644 --- a/theories/Floats/PrimFloat.v +++ b/theories/Floats/PrimFloat.v @@ -27,9 +27,11 @@ Register float_class as kernel.ind_f_class. Primitive float := #float64_type. (** ** Syntax support *) +Module Import PrimFloatNotationsInternalA. Declare Scope float_scope. Delimit Scope float_scope with float. Bind Scope float_scope with float. +End PrimFloatNotationsInternalA. Declare ML Module "float_syntax_plugin". @@ -41,31 +43,34 @@ Primitive abs := #float64_abs. Primitive sqrt := #float64_sqrt. Primitive opp := #float64_opp. -Notation "- x" := (opp x) : float_scope. Primitive eqb := #float64_eq. -Notation "x == y" := (eqb x y) (at level 70, no associativity) : float_scope. Primitive ltb := #float64_lt. -Notation "x < y" := (ltb x y) (at level 70, no associativity) : float_scope. Primitive leb := #float64_le. -Notation "x <= y" := (leb x y) (at level 70, no associativity) : float_scope. Primitive compare := #float64_compare. -Notation "x ?= y" := (compare x y) (at level 70, no associativity) : float_scope. Primitive mul := #float64_mul. -Notation "x * y" := (mul x y) : float_scope. Primitive add := #float64_add. -Notation "x + y" := (add x y) : float_scope. Primitive sub := #float64_sub. -Notation "x - y" := (sub x y) : float_scope. Primitive div := #float64_div. + +Module Import PrimFloatNotationsInternalB. +Notation "- x" := (opp x) : float_scope. +Notation "x =? y" := (eqb x y) (at level 70, no associativity) : float_scope. +Notation "x <? y" := (ltb x y) (at level 70, no associativity) : float_scope. +Notation "x <=? y" := (leb x y) (at level 70, no associativity) : float_scope. +Notation "x ?= y" := (compare x y) (at level 70, no associativity) : float_scope. +Notation "x * y" := (mul x y) : float_scope. +Notation "x + y" := (add x y) : float_scope. +Notation "x - y" := (sub x y) : float_scope. Notation "x / y" := (div x y) : float_scope. +End PrimFloatNotationsInternalB. (** ** Conversions *) @@ -114,15 +119,27 @@ Definition neg_zero := Eval compute in (-zero)%float. Definition two := Eval compute in (of_int63 2). (** ** Predicates and helper functions *) -Definition is_nan f := negb (f == f)%float. +Definition is_nan f := negb (f =? f)%float. -Definition is_zero f := (f == zero)%float. (* note: 0 == -0 with floats *) +Definition is_zero f := (f =? zero)%float. (* note: 0 =? -0 with floats *) -Definition is_infinity f := (abs f == infinity)%float. +Definition is_infinity f := (abs f =? infinity)%float. Definition is_finite (x : float) := negb (is_nan x || is_infinity x). (** [get_sign]: return [true] for [-] sign, [false] for [+] sign. *) Definition get_sign f := let f := if is_zero f then (one / f)%float else f in - (f < zero)%float. + (f <? zero)%float. + +Module Export PrimFloatNotations. + Local Open Scope float_scope. + #[deprecated(since="8.13",note="use infix <? instead")] + Notation "x < y" := (x <? y) (at level 70, no associativity) : float_scope. + #[deprecated(since="8.13",note="use infix <=? instead")] + Notation "x <= y" := (x <=? y) (at level 70, no associativity) : float_scope. + #[deprecated(since="8.13",note="use infix =? instead")] + Notation "x == y" := (x =? y) (at level 70, no associativity) : float_scope. + Export PrimFloatNotationsInternalA. + Export PrimFloatNotationsInternalB. +End PrimFloatNotations. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 8ab12ae534..9984bff0c2 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -79,7 +79,7 @@ Register negb as core.bool.negb. (** Basic properties of [andb] *) -Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. +Lemma andb_prop (a b:bool) : andb a b = true -> a = true /\ b = true. Proof. destruct a, b; repeat split; assumption. Qed. @@ -87,8 +87,8 @@ Hint Resolve andb_prop: bool. Register andb_prop as core.bool.andb_prop. -Lemma andb_true_intro : - forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. +Lemma andb_true_intro (b1 b2:bool) : + b1 = true /\ b2 = true -> andb b1 b2 = true. Proof. destruct b1; destruct b2; simpl; intros [? ?]; assumption. Qed. @@ -245,25 +245,22 @@ End projections. Hint Resolve pair inl inr: core. -Lemma surjective_pairing : - forall (A B:Type) (p:A * B), p = (fst p, snd p). +Lemma surjective_pairing (A B:Type) (p:A * B) : p = (fst p, snd p). Proof. destruct p; reflexivity. Qed. -Lemma injective_projections : - forall (A B:Type) (p1 p2:A * B), +Lemma injective_projections (A B:Type) (p1 p2:A * B) : fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2. Proof. destruct p1; destruct p2; simpl; intros Hfst Hsnd. rewrite Hfst; rewrite Hsnd; reflexivity. Qed. -Lemma pair_equal_spec : - forall (A B : Type) (a1 a2 : A) (b1 b2 : B), +Lemma pair_equal_spec (A B : Type) (a1 a2 : A) (b1 b2 : B) : (a1, b1) = (a2, b2) <-> a1 = a2 /\ b1 = b2. Proof with auto. - split; intros. + split; intro H. - split. + replace a1 with (fst (a1, b1)); replace a2 with (fst (a2, b2))... rewrite H... @@ -272,15 +269,21 @@ Proof with auto. - destruct H; subst... Qed. -Definition prod_uncurry (A B C:Type) (f:A * B -> C) +Definition curry {A B C:Type} (f:A * B -> C) (x:A) (y:B) : C := f (x,y). -Definition prod_curry (A B C:Type) (f:A -> B -> C) +Definition uncurry {A B C:Type} (f:A -> B -> C) (p:A * B) : C := match p with (x, y) => f x y end. +#[deprecated(since = "8.13", note = "Use curry instead.")] +Definition prod_uncurry (A B C:Type) : (A * B -> C) -> A -> B -> C := curry. + +#[deprecated(since = "8.13", note = "Use uncurry instead.")] +Definition prod_curry (A B C:Type) : (A -> B -> C) -> A * B -> C := uncurry. + Import EqNotations. -Lemma rew_pair : forall A (P Q : A->Type) x1 x2 (y1:P x1) (y2:Q x1) (H:x1=x2), +Lemma rew_pair A (P Q : A->Type) x1 x2 (y1:P x1) (y2:Q x1) (H:x1=x2) : (rew H in y1, rew H in y2) = rew [fun x => (P x * Q x)%type] H in (y1,y2). Proof. destruct H. reflexivity. @@ -341,7 +344,7 @@ Register Eq as core.comparison.Eq. Register Lt as core.comparison.Lt. Register Gt as core.comparison.Gt. -Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. +Lemma comparison_eq_stable (c c' : comparison) : ~~ c = c' -> c = c'. Proof. destruct c, c'; intro H; reflexivity || destruct H; discriminate. Qed. @@ -353,12 +356,12 @@ Definition CompOpp (r:comparison) := | Gt => Lt end. -Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c. +Lemma CompOpp_involutive c : CompOpp (CompOpp c) = c. Proof. destruct c; reflexivity. Qed. -Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'. +Lemma CompOpp_inj c c' : CompOpp c = CompOpp c' -> c = c'. Proof. destruct c; destruct c'; auto; discriminate. Qed. @@ -399,7 +402,7 @@ Register CompEqT as core.CompareSpecT.CompEqT. Register CompLtT as core.CompareSpecT.CompLtT. Register CompGtT as core.CompareSpecT.CompGtT. -Lemma CompareSpec2Type : forall Peq Plt Pgt c, +Lemma CompareSpec2Type Peq Plt Pgt c : CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. Proof. destruct c; intros H; constructor; inversion_clear H; auto. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8f9f68a292..8012235143 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -523,41 +523,28 @@ Section equality_dep. Variable f : forall x, B x. Variables x y : A. - Theorem f_equal_dep : forall (H: x = y), rew H in f x = f y. + Theorem f_equal_dep (H: x = y) : rew H in f x = f y. Proof. destruct H; reflexivity. Defined. End equality_dep. -Section equality_dep2. - - Variable A A' : Type. - Variable B : A -> Type. - Variable B' : A' -> Type. - Variable f : A -> A'. - Variable g : forall a:A, B a -> B' (f a). - Variables x y : A. - - Lemma f_equal_dep2 : forall {A A' B B'} (f : A -> A') (g : forall a:A, B a -> B' (f a)) - {x1 x2 : A} {y1 : B x1} {y2 : B x2} (H : x1 = x2), +Lemma f_equal_dep2 {A A' B B'} (f : A -> A') (g : forall a:A, B a -> B' (f a)) + {x1 x2 : A} {y1 : B x1} {y2 : B x2} (H : x1 = x2) : rew H in y1 = y2 -> rew f_equal f H in g x1 y1 = g x2 y2. - Proof. - destruct H, 1. reflexivity. - Defined. - -End equality_dep2. +Proof. + destruct H, 1. reflexivity. +Defined. -Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. +Lemma rew_opp_r A (P:A->Type) (x y:A) (H:x=y) (a:P y) : rew H in rew <- H in a = a. Proof. -intros. destruct H. reflexivity. Defined. -Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. +Lemma rew_opp_l A (P:A->Type) (x y:A) (H:x=y) (a:P x) : rew <- H in rew H in a = a. Proof. -intros. destruct H. reflexivity. Defined. @@ -597,7 +584,7 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. -Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), +Theorem f_equal_compose A B C (a b:A) (f:A->B) (g:B->C) (e:a=b) : f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. Proof. destruct e. reflexivity. @@ -605,68 +592,69 @@ Defined. (** The groupoid structure of equality *) -Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. +Theorem eq_trans_refl_l A (x y:A) (e:x=y) : eq_trans eq_refl e = e. Proof. destruct e. reflexivity. Defined. -Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. +Theorem eq_trans_refl_r A (x y:A) (e:x=y) : eq_trans e eq_refl = e. Proof. destruct e. reflexivity. Defined. -Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. +Theorem eq_sym_involutive A (x y:A) (e:x=y) : eq_sym (eq_sym e) = e. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. +Theorem eq_trans_sym_inv_l A (x y:A) (e:x=y) : eq_trans (eq_sym e) e = eq_refl. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. +Theorem eq_trans_sym_inv_r A (x y:A) (e:x=y) : eq_trans e (eq_sym e) = eq_refl. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), +Theorem eq_trans_assoc A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t) : eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. Proof. destruct e''; reflexivity. Defined. -Theorem rew_map : forall A B (P:B->Type) (f:A->B) x1 x2 (H:x1=x2) (y:P (f x1)), +Theorem rew_map A B (P:B->Type) (f:A->B) x1 x2 (H:x1=x2) (y:P (f x1)) : rew [fun x => P (f x)] H in y = rew f_equal f H in y. Proof. destruct H; reflexivity. Defined. -Theorem eq_trans_map : forall {A B} {x1 x2 x3:A} {y1:B x1} {y2:B x2} {y3:B x3}, - forall (H1:x1=x2) (H2:x2=x3) (H1': rew H1 in y1 = y2) (H2': rew H2 in y2 = y3), +Theorem eq_trans_map {A B} {x1 x2 x3:A} {y1:B x1} {y2:B x2} {y3:B x3} + (H1:x1=x2) (H2:x2=x3) (H1': rew H1 in y1 = y2) (H2': rew H2 in y2 = y3) : rew eq_trans H1 H2 in y1 = y3. Proof. - intros. destruct H2. exact (eq_trans H1' H2'). + destruct H2. exact (eq_trans H1' H2'). Defined. -Lemma map_subst : forall {A} {P Q:A->Type} (f : forall x, P x -> Q x) {x y} (H:x=y) (z:P x), +Lemma map_subst {A} {P Q:A->Type} (f : forall x, P x -> Q x) {x y} (H:x=y) (z:P x) : rew H in f x z = f y (rew H in z). Proof. destruct H. reflexivity. Defined. -Lemma map_subst_map : forall {A B} {P:A->Type} {Q:B->Type} (f:A->B) (g : forall x, P x -> Q (f x)), - forall {x y} (H:x=y) (z:P x), rew f_equal f H in g x z = g y (rew H in z). +Lemma map_subst_map {A B} {P:A->Type} {Q:B->Type} (f:A->B) (g : forall x, P x -> Q (f x)) + {x y} (H:x=y) (z:P x) : + rew f_equal f H in g x z = g y (rew H in z). Proof. destruct H. reflexivity. Defined. -Lemma rew_swap : forall A (P:A->Type) x1 x2 (H:x1=x2) (y1:P x1) (y2:P x2), rew H in y1 = y2 -> y1 = rew <- H in y2. +Lemma rew_swap A (P:A->Type) x1 x2 (H:x1=x2) (y1:P x1) (y2:P x2) : rew H in y1 = y2 -> y1 = rew <- H in y2. Proof. destruct H. trivial. Defined. -Lemma rew_compose : forall A (P:A->Type) x1 x2 x3 (H1:x1=x2) (H2:x2=x3) (y:P x1), +Lemma rew_compose A (P:A->Type) x1 x2 x3 (H1:x1=x2) (H2:x2=x3) (y:P x1) : rew H2 in rew H1 in y = rew (eq_trans H1 H2) in y. Proof. destruct H2. reflexivity. @@ -674,9 +662,8 @@ Defined. (** Extra properties of equality *) -Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). +Theorem eq_id_comm_l A (f:A->A) (Hf:forall a, a = f a) a : f_equal f (Hf a) = Hf (f a). Proof. - intros. unfold f_equal. rewrite <- (eq_trans_sym_inv_l (Hf a)). destruct (Hf a) at 1 2. @@ -684,9 +671,8 @@ Proof. reflexivity. Defined. -Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). +Theorem eq_id_comm_r A (f:A->A) (Hf:forall a, f a = a) a : f_equal f (Hf a) = Hf (f a). Proof. - intros. unfold f_equal. rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))). set (Hfsymf := fun a => eq_sym (Hf a)). @@ -700,36 +686,36 @@ Proof. reflexivity. Defined. -Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). +Lemma eq_refl_map_distr A B x (f:A->B) : f_equal f (eq_refl x) = eq_refl (f x). Proof. reflexivity. Qed. -Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). +Lemma eq_trans_map_distr A B x y z (f:A->B) (e:x=y) (e':y=z) : f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). Proof. destruct e'. reflexivity. Defined. -Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). +Lemma eq_sym_map_distr A B (x y:A) (f:A->B) (e:x=y) : eq_sym (f_equal f e) = f_equal f (eq_sym e). Proof. destruct e. reflexivity. Defined. -Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). +Lemma eq_trans_sym_distr A (x y z:A) (e:x=y) (e':y=z) : eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). Proof. destruct e, e'. reflexivity. Defined. -Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), +Lemma eq_trans_rew_distr A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x) : rew (eq_trans e e') in k = rew e' in rew e in k. Proof. destruct e, e'; reflexivity. Qed. -Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), +Lemma rew_const A P (x y:A) (e:x=y) (k:P) : rew [fun _ => P] e in k = k. Proof. destruct e; reflexivity. @@ -797,9 +783,9 @@ Lemma forall_exists_coincide_unique_domain : -> (exists! x, P x). Proof. intros A P H. - destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|]. + destruct (H P) as ((x & Hx & _),_); [trivial|]. exists x. split; [trivial|]. - destruct H with (Q:=fun x'=>x=x') as (_,Huniq). + destruct (H (fun x'=>x=x')) as (_,Huniq). apply Huniq. exists x; auto. Qed. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 4ff007570e..1fb6dabe6f 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -765,7 +765,7 @@ Section Dependent_choice_lemmas. exists f. split. - reflexivity. - - induction n; simpl; apply proj2_sig. + - intro n; induction n; simpl; apply proj2_sig. Defined. End Dependent_choice_lemmas. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index c3c69f46f3..e0eae7c287 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -3157,6 +3157,44 @@ Section Repeat. - f_equal; apply IHn. Qed. + Lemma repeat_app x n m : + repeat x (n + m) = repeat x n ++ repeat x m. + Proof. + induction n as [|n IHn]; simpl; auto. + now rewrite IHn. + Qed. + + Lemma repeat_eq_app x n l1 l2 : + repeat x n = l1 ++ l2 -> repeat x (length l1) = l1 /\ repeat x (length l2) = l2. + Proof. + revert n; induction l1 as [|a l1 IHl1]; simpl; intros n Hr; subst. + - repeat split; now rewrite repeat_length. + - destruct n; inversion Hr as [ [Heq Hr0] ]; subst. + now apply IHl1 in Hr0 as [-> ->]. + Qed. + + Lemma repeat_eq_cons x y n l : + repeat x n = y :: l -> x = y /\ repeat x (pred n) = l. + Proof. + intros Hr. + destruct n; inversion_clear Hr; auto. + Qed. + + Lemma repeat_eq_elt x y n l1 l2 : + repeat x n = l1 ++ y :: l2 -> x = y /\ repeat x (length l1) = l1 /\ repeat x (length l2) = l2. + Proof. + intros Hr; apply repeat_eq_app in Hr as [Hr1 Hr2]; subst. + apply repeat_eq_cons in Hr2; intuition. + Qed. + + Lemma Forall_eq_repeat x l : + Forall (eq x) l -> l = repeat x (length l). + Proof. + induction l as [|a l IHl]; simpl; intros HF; auto. + inversion_clear HF as [ | ? ? ? HF']; subst. + now rewrite (IHl HF') at 1. + Qed. + End Repeat. Lemma repeat_to_concat A n (a:A) : diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 6470cd6c81..e3e8f532b3 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -99,7 +99,7 @@ Module ZnZ. lxor : t -> t -> t }. Section Specs. - Context {t : Type}{ops : Ops t}. + Context {t : Set}{ops : Ops t}. Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). @@ -221,7 +221,7 @@ Module ZnZ. Section WW. - Context {t : Type}{ops : Ops t}{specs : Specs ops}. + Context {t : Set}{ops : Ops t}{specs : Specs ops}. Let wB := base digits. @@ -284,7 +284,7 @@ Module ZnZ. Section Of_Z. - Context {t : Type}{ops : Ops t}{specs : Specs ops}. + Context {t : Set}{ops : Ops t}{specs : Specs ops}. Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). @@ -325,7 +325,7 @@ End ZnZ. (** A modular specification grouping the earlier records. *) Module Type CyclicType. - Parameter t : Type. + Parameter t : Set. Declare Instance ops : ZnZ.Ops t. Declare Instance specs : ZnZ.Specs ops. End CyclicType. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index 3232e3afe0..165f9893ca 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -54,7 +54,7 @@ Arguments W0 {znz}. (if depth = n). *) -Fixpoint word (w:Type) (n:nat) : Type := +Fixpoint word (w:Set) (n:nat) : Set := match n with | O => w | S n => zn2z (word w n) diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 5f903c41cb..2a26b6b12a 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -48,7 +48,7 @@ Definition mulc_WW x y := Notation "n '*c' m" := (mulc_WW n m) (at level 40, no associativity) : int63_scope. Definition pos_mod p x := - if p <= digits then + if p <=? digits then let p := digits - p in (x << p) >> p else x. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 2c112c3469..383c0aff3a 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -31,56 +31,61 @@ Declare Scope int63_scope. Definition id_int : int -> int := fun x => x. Declare ML Module "int63_syntax_plugin". +Module Import Int63NotationsInternalA. Delimit Scope int63_scope with int63. Bind Scope int63_scope with int. +End Int63NotationsInternalA. (* Logical operations *) Primitive lsl := #int63_lsl. -Infix "<<" := lsl (at level 30, no associativity) : int63_scope. Primitive lsr := #int63_lsr. -Infix ">>" := lsr (at level 30, no associativity) : int63_scope. Primitive land := #int63_land. -Infix "land" := land (at level 40, left associativity) : int63_scope. Primitive lor := #int63_lor. -Infix "lor" := lor (at level 40, left associativity) : int63_scope. Primitive lxor := #int63_lxor. -Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. (* Arithmetic modulo operations *) Primitive add := #int63_add. -Notation "n + m" := (add n m) : int63_scope. Primitive sub := #int63_sub. -Notation "n - m" := (sub n m) : int63_scope. Primitive mul := #int63_mul. -Notation "n * m" := (mul n m) : int63_scope. Primitive mulc := #int63_mulc. Primitive div := #int63_div. -Notation "n / m" := (div n m) : int63_scope. Primitive mod := #int63_mod. -Notation "n '\%' m" := (mod n m) (at level 40, left associativity) : int63_scope. (* Comparisons *) Primitive eqb := #int63_eq. -Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. Primitive ltb := #int63_lt. -Notation "m < n" := (ltb m n) : int63_scope. Primitive leb := #int63_le. -Notation "m <= n" := (leb m n) : int63_scope. -Notation "m ≤ n" := (leb m n) (at level 70, no associativity) : int63_scope. Local Open Scope int63_scope. +Module Import Int63NotationsInternalB. +Infix "<<" := lsl (at level 30, no associativity) : int63_scope. +Infix ">>" := lsr (at level 30, no associativity) : int63_scope. +Infix "land" := land (at level 40, left associativity) : int63_scope. +Infix "lor" := lor (at level 40, left associativity) : int63_scope. +Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. +Infix "+" := add : int63_scope. +Infix "-" := sub : int63_scope. +Infix "*" := mul : int63_scope. +Infix "/" := div : int63_scope. +Infix "mod" := mod (at level 40, no associativity) : int63_scope. +Infix "=?" := eqb (at level 70, no associativity) : int63_scope. +Infix "<?" := ltb (at level 70, no associativity) : int63_scope. +Infix "<=?" := leb (at level 70, no associativity) : int63_scope. +Infix "≤?" := leb (at level 70, no associativity) : int63_scope. +End Int63NotationsInternalB. + (** The number of digits as a int *) Definition digits := 63. @@ -89,16 +94,16 @@ Definition max_int := Eval vm_compute in 0 - 1. Register Inline max_int. (** Access to the nth digits *) -Definition get_digit x p := (0 < (x land (1 << p))). +Definition get_digit x p := (0 <? (x land (1 << p))). Definition set_digit x p (b:bool) := - if if 0 <= p then p < digits else false then + if if 0 <=? p then p <? digits else false then if b then x lor (1 << p) else x land (max_int lxor (1 << p)) else x. (** Equality to 0 *) -Definition is_zero (i:int) := i == 0. +Definition is_zero (i:int) := i =? 0. Register Inline is_zero. (** Parity *) @@ -113,7 +118,6 @@ Definition bit i n := negb (is_zero ((i >> n) << (digits - 1))). (** Extra modulo operations *) Definition opp (i:int) := 0 - i. Register Inline opp. -Notation "- x" := (opp x) : int63_scope. Definition oppcarry i := max_int - i. Register Inline oppcarry. @@ -134,29 +138,27 @@ Register Inline subcarry. Definition addc_def x y := let r := x + y in - if r < x then C1 r else C0 r. + if r <? x then C1 r else C0 r. (* the same but direct implementation for efficiency *) Primitive addc := #int63_addc. -Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. Definition addcarryc_def x y := let r := addcarry x y in - if r <= x then C1 r else C0 r. + if r <=? x then C1 r else C0 r. (* the same but direct implementation for efficiency *) Primitive addcarryc := #int63_addcarryc. Definition subc_def x y := - if y <= x then C0 (x - y) else C1 (x - y). + if y <=? x then C0 (x - y) else C1 (x - y). (* the same but direct implementation for efficiency *) Primitive subc := #int63_subc. -Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. Definition subcarryc_def x y := - if y < x then C0 (x - y - 1) else C1 (x - y - 1). + if y <? x then C0 (x - y - 1) else C1 (x - y - 1). (* the same but direct implementation for efficiency *) Primitive subcarryc := #int63_subcarryc. -Definition diveucl_def x y := (x/y, x\%y). +Definition diveucl_def x y := (x/y, x mod y). (* the same but direct implementation for efficiency *) Primitive diveucl := #int63_diveucl. @@ -166,6 +168,12 @@ Definition addmuldiv_def p x y := (x << p) lor (y >> (digits - p)). Primitive addmuldiv := #int63_addmuldiv. +Module Import Int63NotationsInternalC. +Notation "- x" := (opp x) : int63_scope. +Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. +Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. +End Int63NotationsInternalC. + Definition oppc (i:int) := 0 -c i. Register Inline oppc. @@ -177,11 +185,10 @@ Register Inline predc. (** Comparison *) Definition compare_def x y := - if x < y then Lt - else if (x == y) then Eq else Gt. + if x <? y then Lt + else if (x =? y) then Eq else Gt. Primitive compare := #int63_compare. -Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. Import Bool ZArith. (** Translation to Z *) @@ -194,8 +201,6 @@ Fixpoint to_Z_rec (n:nat) (i:int) := Definition to_Z := to_Z_rec size. -Notation "'φ' x" := (to_Z x) (at level 0) : int63_scope. - Fixpoint of_pos_rec (n:nat) (p:positive) := match n, p with | O, _ => 0 @@ -215,8 +220,12 @@ Definition of_Z z := Definition wB := (2 ^ (Z.of_nat size))%Z. +Module Import Int63NotationsInternalD. +Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. +Notation "'φ' x" := (to_Z x) (at level 0) : int63_scope. Notation "'Φ' x" := (zn2z_to_Z wB to_Z x) (at level 0) : int63_scope. +End Int63NotationsInternalD. Lemma to_Z_rec_bounded size : forall x, (0 <= to_Z_rec size x < 2 ^ Z.of_nat size)%Z. Proof. @@ -347,16 +356,16 @@ Axiom mulc_spec : forall x y, φ x * φ y = φ (fst (mulc x y)) * wB + φ (snd ( Axiom div_spec : forall x y, φ (x / y) = φ x / φ y. -Axiom mod_spec : forall x y, φ (x \% y) = φ x mod φ y. +Axiom mod_spec : forall x y, φ (x mod y) = φ x mod φ y. (* Comparisons *) -Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. +Axiom eqb_correct : forall i j, (i =? j)%int63 = true -> i = j. -Axiom eqb_refl : forall x, (x == x)%int63 = true. +Axiom eqb_refl : forall x, (x =? x)%int63 = true. -Axiom ltb_spec : forall x y, (x < y)%int63 = true <-> φ x < φ y. +Axiom ltb_spec : forall x y, (x <? y)%int63 = true <-> φ x < φ y. -Axiom leb_spec : forall x y, (x <= y)%int63 = true <-> φ x <= φ y. +Axiom leb_spec : forall x y, (x <=? y)%int63 = true <-> φ x <= φ y. (** Exotic operations *) @@ -397,7 +406,7 @@ Local Open Scope int63_scope. Definition sqrt_step (rec: int -> int -> int) (i j: int) := let quo := i / j in - if quo < j then rec i ((j + quo) >> 1) + if quo <? j then rec i ((j + quo) >> 1) else j. Definition iter_sqrt := @@ -421,9 +430,9 @@ Definition high_bit := 1 << (digits - 1). Definition sqrt2_step (rec: int -> int -> int -> int) (ih il j: int) := - if ih < j then + if ih <? j then let (quo,_) := diveucl_21 ih il j in - if quo < j then + if quo <? j then match j +c quo with | C0 m1 => rec ih il (m1 >> 1) | C1 m1 => rec ih il ((m1 >> 1) + high_bit) @@ -448,48 +457,48 @@ Definition sqrt2 ih il := let (ih1, il1) := mulc s s in match il -c il1 with | C0 il2 => - if ih1 < ih then (s, C1 il2) else (s, C0 il2) + if ih1 <? ih then (s, C1 il2) else (s, C0 il2) | C1 il2 => - if ih1 < (ih - 1) then (s, C1 il2) else (s, C0 il2) + if ih1 <? (ih - 1) then (s, C1 il2) else (s, C0 il2) end. (** Gcd **) Fixpoint gcd_rec (guard:nat) (i j:int) {struct guard} := match guard with | O => 1 - | S p => if j == 0 then i else gcd_rec p j (i \% j) + | S p => if j =? 0 then i else gcd_rec p j (i mod j) end. Definition gcd := gcd_rec (2*size). (** equality *) -Lemma eqb_complete : forall x y, x = y -> (x == y) = true. +Lemma eqb_complete : forall x y, x = y -> (x =? y) = true. Proof. intros x y H; rewrite -> H, eqb_refl;trivial. Qed. -Lemma eqb_spec : forall x y, (x == y) = true <-> x = y. +Lemma eqb_spec : forall x y, (x =? y) = true <-> x = y. Proof. split;auto using eqb_correct, eqb_complete. Qed. -Lemma eqb_false_spec : forall x y, (x == y) = false <-> x <> y. +Lemma eqb_false_spec : forall x y, (x =? y) = false <-> x <> y. Proof. intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. Qed. -Lemma eqb_false_complete : forall x y, x <> y -> (x == y) = false. +Lemma eqb_false_complete : forall x y, x <> y -> (x =? y) = false. Proof. intros x y;rewrite eqb_false_spec;trivial. Qed. -Lemma eqb_false_correct : forall x y, (x == y) = false -> x <> y. +Lemma eqb_false_correct : forall x y, (x =? y) = false -> x <> y. Proof. intros x y;rewrite eqb_false_spec;trivial. Qed. Definition eqs (i j : int) : {i = j} + { i <> j } := - (if i == j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) + (if i =? j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) (eqb_correct i j) @@ -503,7 +512,7 @@ Qed. (* Extra function on equality *) Definition cast i j := - (if i == j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) + (if i =? j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) then fun Heq : true = true -> i = j => Some (fun (P : int -> Type) (Hi : P i) => @@ -520,14 +529,14 @@ Proof. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. -Lemma cast_diff : forall i j, i == j = false -> cast i j = None. +Lemma cast_diff : forall i j, i =? j = false -> cast i j = None. Proof. intros;unfold cast;intros; generalize (eqb_correct i j). rewrite H;trivial. Qed. Definition eqo i j := - (if i == j as b return ((b = true -> i = j) -> option (i=j)) + (if i =? j as b return ((b = true -> i = j) -> option (i=j)) then fun Heq : true = true -> i = j => Some (Heq (eq_refl true)) else fun _ : false = true -> i = j => None) (eqb_correct i j). @@ -540,7 +549,7 @@ Proof. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. -Lemma eqo_diff : forall i j, i == j = false -> eqo i j = None. +Lemma eqo_diff : forall i j, i =? j = false -> eqo i j = None. Proof. unfold eqo;intros; generalize (eqb_correct i j). rewrite H;trivial. @@ -548,13 +557,13 @@ Qed. (** Comparison *) -Lemma eqbP x y : reflect (φ x = φ y ) (x == y). +Lemma eqbP x y : reflect (φ x = φ y ) (x =? y). Proof. apply iff_reflect; rewrite eqb_spec; split; [ apply to_Z_inj | apply f_equal ]. Qed. -Lemma ltbP x y : reflect (φ x < φ y )%Z (x < y). +Lemma ltbP x y : reflect (φ x < φ y )%Z (x <? y). Proof. apply iff_reflect; symmetry; apply ltb_spec. Qed. -Lemma lebP x y : reflect (φ x <= φ y )%Z (x ≤ y). +Lemma lebP x y : reflect (φ x <= φ y )%Z (x ≤? y). Proof. apply iff_reflect; symmetry; apply leb_spec. Qed. Lemma compare_spec x y : compare x y = (φ x ?= φ y)%Z. @@ -742,7 +751,7 @@ Proof. Qed. Lemma add_le_r m n: - if (n <= m + n)%int63 then (φ m + φ n < wB)%Z else (wB <= φ m + φ n)%Z. + if (n <=? m + n)%int63 then (φ m + φ n < wB)%Z else (wB <= φ m + φ n)%Z. Proof. case (to_Z_bounded m); intros H1m H2m. case (to_Z_bounded n); intros H1n H2n. @@ -753,11 +762,11 @@ Proof. rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. rewrite !Zmod_small; auto with zarith. apply f_equal2 with (f := Zmod); auto with zarith. - case_eq (n <= m + n)%int63; auto. + case_eq (n <=? m + n)%int63; auto. rewrite leb_spec, H1; auto with zarith. assert (H1: (φ (m + n) = φ m + φ n)%Z). rewrite add_spec, Zmod_small; auto with zarith. - replace (n <= m + n)%int63 with true; auto. + replace (n <=? m + n)%int63 with true; auto. apply sym_equal; rewrite leb_spec, H1; auto with zarith. Qed. @@ -783,7 +792,7 @@ Proof. apply to_Z_inj; rewrite lsr_spec; reflexivity. Qed. Lemma lsr_0_r i: i >> 0 = i. Proof. apply to_Z_inj; rewrite lsr_spec, Zdiv_1_r; exact eq_refl. Qed. -Lemma lsr_1 n : 1 >> n = (n == 0). +Lemma lsr_1 n : 1 >> n = (n =? 0)%int63. Proof. case eqbP. intros h; rewrite (to_Z_inj _ _ h), lsr_0_r; reflexivity. @@ -798,12 +807,12 @@ Proof. lia. Qed. -Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int63. +Lemma lsr_add i m n: ((i >> m) >> n = if n <=? m + n then i >> (m + n) else 0)%int63. Proof. case (to_Z_bounded m); intros H1m H2m. case (to_Z_bounded n); intros H1n H2n. case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <= m + n)%int63; intros H. + generalize (add_le_r m n); case (n <=? m + n)%int63; intros H. apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. rewrite add_spec, Zmod_small; auto with zarith. apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. @@ -833,7 +842,7 @@ Proof. apply f_equal2 with (f := Zmod); auto with zarith. Qed. -Lemma lsr_M_r x i (H: (digits <= i = true)%int63) : x >> i = 0%int63. +Lemma lsr_M_r x i (H: (digits <=? i = true)%int63) : x >> i = 0%int63. Proof. apply to_Z_inj. rewrite lsr_spec, to_Z_0. @@ -889,22 +898,22 @@ Proof. Qed. Lemma bit_lsr x i j : - (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int63. + (bit (x >> i) j = if j <=? i + j then bit x (i + j) else false)%int63. Proof. - unfold bit; rewrite lsr_add; case (_ ≤ _); auto. + unfold bit; rewrite lsr_add; case (_ ≤? _); auto. Qed. -Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. +Lemma bit_b2i (b: bool) i : bit b i = (i =? 0)%int63 && b. Proof. case b; unfold bit; simpl b2i. - rewrite lsr_1; case (i == 0); auto. + rewrite lsr_1; case (i =? 0)%int63; auto. rewrite lsr0, lsl0, andb_false_r; auto. Qed. -Lemma bit_1 n : bit 1 n = (n == 0). +Lemma bit_1 n : bit 1 n = (n =? 0)%int63. Proof. unfold bit; rewrite lsr_1. - case (_ == _); simpl; auto. + case (_ =? _)%int63; simpl; auto. Qed. Local Hint Resolve Z.lt_gt Z.div_pos : zarith. @@ -929,14 +938,14 @@ Proof. case bit; discriminate. Qed. -Lemma bit_M i n (H: (digits <= n = true)%int63): bit i n = false. +Lemma bit_M i n (H: (digits <=? n = true)%int63): bit i n = false. Proof. unfold bit; rewrite lsr_M_r; auto. Qed. -Lemma bit_half i n (H: (n < digits = true)%int63) : bit (i>>1) n = bit i (n+1). +Lemma bit_half i n (H: (n <? digits = true)%int63) : bit (i>>1) n = bit i (n+1). Proof. unfold bit. rewrite lsr_add. - case_eq (n <= (1 + n))%int63. + case_eq (n <=? (1 + n))%int63. replace (1+n)%int63 with (n+1)%int63; [auto|idtac]. apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. intros H1; assert (H2: n = max_int). @@ -968,10 +977,10 @@ Proof. Qed. Lemma bit_lsl x i j : bit (x << i) j = -(if (j < i) || (digits <= j) then false else bit x (j - i))%int63. +(if (j <? i) || (digits <=? j) then false else bit x (j - i))%int63. Proof. assert (F1: 1 >= 0) by discriminate. - case_eq (digits <= j)%int63; intros H. + case_eq (digits <=? j)%int63; intros H. rewrite orb_true_r, bit_M; auto. set (d := φ digits). case (Zle_or_lt d (φ j)); intros H1. @@ -1039,10 +1048,10 @@ Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). Proof. apply bit_ext; intros n. rewrite -> lor_spec, !bit_lsr, lor_spec. - case (_ <= _)%int63; auto. + case (_ <=? _)%int63; auto. Qed. -Lemma lor_le x y : (y <= x lor y)%int63 = true. +Lemma lor_le x y : (y <=? x lor y)%int63 = true. Proof. generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. unfold wB; elim size. @@ -1092,7 +1101,7 @@ Proof. rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. apply Zdiv_lt_upper_bound; auto with zarith. intros m H1 H2. - case_eq (digits <= m)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (digits <=? m)%int63; [idtac | rewrite <- not_true_iff_false]; intros Heq. rewrite bit_M in H1; auto; discriminate. rewrite leb_spec in Heq. @@ -1131,7 +1140,7 @@ Proof. rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. apply Zdiv_lt_upper_bound; auto with zarith. intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <= m)%int63. + case_eq (digits <=? m)%int63. intros Hlm; rewrite bit_M; auto; discriminate. rewrite <- not_true_iff_false, leb_spec; intros Hlm. case (Zle_lt_or_eq 0 φ m); auto; intros Hm. @@ -1177,11 +1186,11 @@ Proof. rewrite (fun x y => Zmod_small (x - y)); auto with zarith. intros n; rewrite -> bit_lsl, bit_lsr. generalize (add_le_r (digits - p) n). - case (_ ≤ _); try discriminate. + case (_ ≤? _); try discriminate. rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n < p)%int63; try discriminate. + case_eq (n <? p)%int63; try discriminate. rewrite <- not_true_iff_false, ltb_spec; intros H2. - case (_ ≤ _); try discriminate. + case (_ ≤? _); try discriminate. intros _; rewrite bit_M; try discriminate. rewrite -> leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. rewrite -> sub_spec, Zmod_small; auto with zarith. @@ -1196,7 +1205,7 @@ Proof. apply bit_ext; intros n. rewrite bit_b2i, land_spec, bit_1. generalize (eqb_spec n 0). - case (n == 0); auto. + case (n =? 0)%int63; auto. intros(H,_); rewrite andb_true_r, H; auto. rewrite andb_false_r; auto. Qed. @@ -1373,9 +1382,9 @@ Qed. (* sqrt2 *) Lemma sqrt2_step_def rec ih il j: sqrt2_step rec ih il j = - if (ih < j)%int63 then + if (ih <? j)%int63 then let quo := fst (diveucl_21 ih il j) in - if (quo < j)%int63 then + if (quo <? j)%int63 then let m := match j +c quo with | C0 m1 => m1 >> 1 @@ -1453,7 +1462,7 @@ Proof. apply Zmult_lt_0_compat; auto with zarith. refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } cbv zeta. - case_eq (ih < j)%int63;intros Heq. + case_eq (ih <? j)%int63;intros Heq. rewrite -> ltb_spec in Heq. 2: rewrite <-not_true_iff_false, ltb_spec in Heq. 2: split; auto. @@ -1462,7 +1471,7 @@ Proof. 2: assert (0 <= φ il/φ j) by (apply Z_div_pos; auto with zarith). 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. case (Zle_or_lt (2^(Z_of_nat size -1)) φ j); intros Hjj. - case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. + case_eq (fst (diveucl_21 ih il j) <? j)%int63;intros Heq0. 2: rewrite <-not_true_iff_false, ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. 2: split; auto; apply sqrt_test_true; auto with zarith. rewrite -> ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. @@ -1557,7 +1566,7 @@ Lemma sqrt2_spec : forall x y, generalize (subc_spec il il1). case subc; intros il2 Hil2. simpl interp_carry in Hil2. - case_eq (ih1 < ih)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (ih1 <? ih)%int63; [idtac | rewrite <- not_true_iff_false]; rewrite ltb_spec; intros Heq. unfold interp_carry; rewrite Zmult_1_l. rewrite -> Z.pow_2_r, Hihl1, Hil2. @@ -1602,7 +1611,7 @@ Lemma sqrt2_spec : forall x y, case (to_Z_bounded ih); intros H1 H2. split; auto with zarith. apply Z.le_trans with (wB/4 - 1); auto with zarith. - case_eq (ih1 < ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (ih1 <? ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; rewrite ltb_spec, Hsih; intros Heq. rewrite Z.pow_2_r, Hihl1. case (Zle_lt_or_eq (φ ih1 + 2) φ ih); auto with zarith. @@ -1927,3 +1936,21 @@ Qed. Lemma lxor0_r i : i lxor 0 = i. Proof. rewrite lxorC; exact (lxor0 i). Qed. + +Module Export Int63Notations. + Local Open Scope int63_scope. + #[deprecated(since="8.13",note="use infix mod instead")] + Notation "a \% m" := (a mod m) (at level 40, left associativity) : int63_scope. + #[deprecated(since="8.13",note="use infix =? instead")] + Notation "m '==' n" := (m =? n) (at level 70, no associativity) : int63_scope. + #[deprecated(since="8.13",note="use infix <? instead")] + Notation "m < n" := (m <? n) : int63_scope. + #[deprecated(since="8.13",note="use infix <=? instead")] + Notation "m <= n" := (m <=? n) : int63_scope. + #[deprecated(since="8.13",note="use infix ≤? instead")] + Notation "m ≤ n" := (m <=? n) (at level 70, no associativity) : int63_scope. + Export Int63NotationsInternalA. + Export Int63NotationsInternalB. + Export Int63NotationsInternalC. + Export Int63NotationsInternalD. +End Int63Notations. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 026cf32ceb..2f445c341a 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -522,6 +522,18 @@ Proof. repeat red; eauto using Permutation_NoDup. Qed. +Lemma Permutation_repeat x n l : + Permutation l (repeat x n) -> l = repeat x n. +Proof. + revert n; induction l as [|y l IHl] ; simpl; intros n HP; auto. + - now apply Permutation_nil in HP; inversion HP. + - assert (y = x) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst. + destruct n; simpl; simpl in HP. + + symmetry in HP; apply Permutation_nil in HP; inversion HP. + + f_equal; apply IHl. + now apply Permutation_cons_inv with x. +Qed. + End Permutation_properties. Section Permutation_map. diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index b801a3b06e..5d210b2e60 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -504,9 +504,9 @@ rule coq_bol = parse { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } | space* end_show nl { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } - | space* begin_details nl - { Lexing.new_line lexbuf; - let s = details_body lexbuf in + | space* begin_details (* At this point, the comment remains open, + and will be closed by [details_body] *) + { let s = details_body lexbuf in Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } | space* end_details nl { Lexing.new_line lexbuf; diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index def1cbbcf8..32cf05e1eb 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -838,7 +838,7 @@ module Html = struct printf "<a id=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> - let id' = prepare_entry id t in + let id' = escaped (prepare_entry id t) in printf "<a href=\"%s\">%s</a> %s<br/>\n" link id' text) l; printf "<br/><br/>" end diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f47cdd8bf0..7a7e7d6e35 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -556,11 +556,17 @@ let list_id l = List.fold_left ( fun a decl -> let s' = Id.of_string (s'^"_lb")) ::a ) [] l + +let avoid_of_list_id list_id = + List.fold_left (fun avoid (s,seq,sbl,slb) -> + List.fold_left (fun avoid id -> Id.Set.add id avoid) + avoid [s;seq;sbl;slb]) + Id.Set.empty list_id + (* build the right eq_I A B.. N eq_A .. eq_N *) -let eqI ind l = - let list_id = list_id l in +let eqI ind list_id = let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e = match lookup_scheme beq_scheme_kind ind with @@ -568,7 +574,7 @@ let eqI ind l = | None -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed."); - in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)) + in mkApp(e,eA) (**********************************************************************) (* Boolean->Leibniz *) @@ -576,12 +582,12 @@ let eqI ind l = open Namegen let compute_bl_goal ind lnamesparrec nparrec = - let eqI = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in + let eqI = eqI ind list_id in + let avoid = avoid_of_list_id list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -607,88 +613,74 @@ let compute_bl_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) + (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar x;mkVar y|]);tt ()|])) Sorts.Relevant - (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) + (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar x;mkVar y|])) ))) let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in - let avoid = ref [] in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh - in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (EConstr.mkVar freshn); - intro_using freshm; - destruct_on (EConstr.mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity my_discr_tac - ); - simpl_in_hyp (freshz,Locus.InHyp); -(* + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) + @ ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) + in + intros_using_then first_intros begin fun fresh_first_intros -> + Tacticals.New.tclTHENLIST [ + intro_using_then (Id.of_string "x") (fun freshn -> induct_on (EConstr.mkVar freshn)); + intro_using_then (Id.of_string "y") (fun freshm -> destruct_on (EConstr.mkVar freshm)); + intro_using_then (Id.of_string "Z") begin fun freshz -> + Tacticals.New.tclTHENLIST [ + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity my_discr_tac + ); + simpl_in_hyp (freshz,Locus.InHyp); + (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). -*) - Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [ - Simple.apply_in freshz (EConstr.of_constr (andb_prop())); - Proofview.Goal.enter begin fun gl -> - let fresht = fresh_id (Id.of_string "Z") gl in - destruct_on_as (EConstr.mkVar freshz) - (IntroOrPattern [[CAst.make @@ IntroNaming (IntroIdentifier fresht); - CAst.make @@ IntroNaming (IntroIdentifier freshz)]]) - end - ]); -(* + *) + Tacticals.New.tclREPEAT ( + Tacticals.New.tclTHENLIST [ + Simple.apply_in freshz (EConstr.of_constr (andb_prop())); + destruct_on_as (EConstr.mkVar freshz) + (IntroOrPattern [[CAst.make @@ IntroNaming (IntroFresh (Id.of_string "Z")); + CAst.make @@ IntroNaming (IntroIdentifier freshz)]]) + ]); + (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto -*) - Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let sigma = Tacmach.New.project gl in - match EConstr.kind sigma concl with - | App (c,ca) -> ( - match EConstr.kind sigma c with - | Ind (indeq, u) -> - if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") - then - Tacticals.New.tclTHEN - (do_replace_bl bl_scheme_key ind - (!avoid) - nparrec (ca.(2)) - (ca.(1))) - Auto.default_auto - else - Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") - ) - | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end + *) + Proofview.Goal.enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + match EConstr.kind sigma concl with + | App (c,ca) -> ( + match EConstr.kind sigma c with + | Ind (indeq, u) -> + if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") + then + Tacticals.New.tclTHEN + (do_replace_bl bl_scheme_key ind + (List.rev fresh_first_intros) + nparrec (ca.(2)) + (ca.(1))) + Auto.default_auto + else + Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") + ) + | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + end - ] - end + ] + end + ] + end let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -729,11 +721,11 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = eq () and tt = tt () and bb = bb () in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in - let eqI = eqI ind lnamesparrec in + let avoid = avoid_of_list_id list_id in + let eqI = eqI ind list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -760,73 +752,62 @@ let compute_lb_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) + (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar x;mkVar y|])) Sorts.Relevant - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) + (mkApp(eq,[|bb;mkApp(eqI,[|mkVar x;mkVar y|]);tt|])) ))) let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in - let avoid = ref [] in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh - in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (EConstr.mkVar freshn); - intro_using freshm; - destruct_on (EConstr.mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity my_discr_tac - ); - my_inj_tac freshz; - intros; simpl_in_concl; - Auto.default_auto; - Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); - simplest_split ;Auto.default_auto ] - ); - Proofview.Goal.enter begin fun gls -> - let concl = Proofview.Goal.concl gls in - let sigma = Tacmach.New.project gl in - (* assume the goal to be eq (eq_type ...) = true *) - match EConstr.kind sigma concl with - | App(c,ca) -> (match (EConstr.kind sigma ca.(1)) with - | App(c',ca') -> - let n = Array.length ca' in - do_replace_lb mode lb_scheme_key - (!avoid) - nparrec - ca'.(n-2) ca'.(n-1) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - ) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end - ] - end + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) + @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in + intros_using_then first_intros begin fun fresh_first_intros -> + Tacticals.New.tclTHENLIST [ + intro_using_then (Id.of_string "x") (fun freshn -> induct_on (EConstr.mkVar freshn)); + intro_using_then (Id.of_string "y") (fun freshm -> destruct_on (EConstr.mkVar freshm)); + intro_using_then (Id.of_string "Z") begin fun freshz -> + Tacticals.New.tclTHENLIST [ + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity my_discr_tac + ); + my_inj_tac freshz; + intros; simpl_in_concl; + Auto.default_auto; + Tacticals.New.tclREPEAT ( + Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); + simplest_split ;Auto.default_auto ] + ); + Proofview.Goal.enter begin fun gls -> + let concl = Proofview.Goal.concl gls in + let sigma = Tacmach.New.project gls in + (* assume the goal to be eq (eq_type ...) = true *) + match EConstr.kind sigma concl with + | App(c,ca) -> (match (EConstr.kind sigma ca.(1)) with + | App(c',ca') -> + let n = Array.length ca' in + do_replace_lb mode lb_scheme_key + (List.rev fresh_first_intros) + nparrec + ca'.(n-2) ca'.(n-1) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + ) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + end + ] + end + ] + end let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") @@ -868,10 +849,10 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = eq () and tt = tt () and bb = bb () in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in + let avoid = avoid_of_list_id list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -912,12 +893,10 @@ let compute_dec_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in - let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in + let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar x;mkVar y|]) in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.not.type",[|eqnm|])|]) ) ) @@ -925,83 +904,89 @@ let compute_dec_goal ind lnamesparrec nparrec = let compute_dec_tact ind lnamesparrec nparrec = let eq = eq () and tt = tt () - and ff = ff () and bb = bb () in + and ff = ff () and bb = bb () in let list_id = list_id lnamesparrec in find_scheme beq_scheme_kind ind >>= fun _ -> - let eqI = eqI ind lnamesparrec in - let avoid = ref [] in + let _non_fresh_eqI = eqI ind list_id in let eqtrue x = mkApp(eq,[|bb;x;tt|]) in let eqfalse x = mkApp(eq,[|bb;x;ff|]) in let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) + @ ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) + @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshH = fresh_id (Id.of_string "H") gl in - let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in - let arfresh = Array.of_list fresh_first_intros in - let xargs = Array.sub arfresh 0 (2*nparrec) in - find_scheme bl_scheme_kind ind >>= fun c -> - let blI = mkConst c in - find_scheme lb_scheme_kind ind >>= fun c -> - let lbI = mkConst c in - Tacticals.New.tclTHENLIST [ - intros_using fresh_first_intros; - intros_using [freshn;freshm]; - (*we do this so we don't have to prove the same goal twice *) - assert_by (Name freshH) (EConstr.of_constr ( - mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - )) - (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); - + let fresh_id s gl = fresh_id_in_env (Id.Set.empty) s (Proofview.Goal.env gl) in + intros_using_then first_intros begin fun fresh_first_intros -> + let eqI = + let a = Array.of_list fresh_first_intros in + let n = List.length list_id in + assert (Int.equal (Array.length a) (4 * n)); + let fresh_list_id = + List.init n (fun i -> (Array.get a i, Array.get a (i+n), + Array.get a (i+2*n), Array.get a (i+3*n))) in + eqI ind fresh_list_id + in + intro_using_then (Id.of_string "x") begin fun freshn -> + intro_using_then (Id.of_string "y") begin fun freshm -> Proofview.Goal.enter begin fun gl -> - let freshH2 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ - (* left *) - Tacticals.New.tclTHENLIST [ - simplest_left; - apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); - Auto.default_auto - ] - ; - - (*right *) - Proofview.Goal.enter begin fun gl -> - let freshH3 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENLIST [ - simplest_right ; - unfold_constr (Coqlib.lib_ref "core.not.type"); - intro; - Equality.subst_all (); - assert_by (Name freshH3) - (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) - (Tacticals.New.tclTHENLIST [ - apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); - Auto.default_auto - ]); - Equality.general_rewrite_bindings_in true - Locus.AllOccurrences true false - (List.hd !avoid) - ((EConstr.mkVar (List.hd (List.tl !avoid))), - NoBindings - ) - true; - my_discr_tac + let freshH = fresh_id (Id.of_string "H") gl in + let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in + let arfresh = Array.of_list fresh_first_intros in + let xargs = Array.sub arfresh 0 (2*nparrec) in + find_scheme bl_scheme_kind ind >>= fun c -> + let blI = mkConst c in + find_scheme lb_scheme_kind ind >>= fun c -> + let lbI = mkConst c in + Tacticals.New.tclTHENLIST [ + (*we do this so we don't have to prove the same goal twice *) + assert_by (Name freshH) (EConstr.of_constr ( + mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) + )) + (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); + + Proofview.Goal.enter begin fun gl -> + let freshH2 = fresh_id (Id.of_string "H") gl in + Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ + (* left *) + Tacticals.New.tclTHENLIST [ + simplest_left; + apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); + Auto.default_auto + ] + ; + + (*right *) + Proofview.Goal.enter begin fun gl -> + let freshH3 = fresh_id (Id.of_string "H") gl in + Tacticals.New.tclTHENLIST [ + simplest_right ; + unfold_constr (Coqlib.lib_ref "core.not.type"); + intro; + Equality.subst_all (); + assert_by (Name freshH3) + (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) + (Tacticals.New.tclTHENLIST [ + apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); + Auto.default_auto + ]); + Equality.general_rewrite_bindings_in true + Locus.AllOccurrences true false + freshH3 + ((EConstr.mkVar freshH2), + NoBindings + ) + true; + my_discr_tac + ] + end + ] + end ] - end - ] + end end - ] - end + end + end let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 360e228bfc..be9cc059a7 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -213,14 +213,6 @@ let vernac_arguments ~section_local reference args more_implicits flags = in CErrors.user_err ~hdr:"vernac_declare_arguments" msg end; - let duplicate_names = - List.duplicates Name.equal (List.filter ((!=) Anonymous) names) - in - if not (List.is_empty duplicate_names) then begin - CErrors.user_err Pp.(strbrk "Some argument names are duplicated: " ++ - prlist_with_sep pr_comma Name.print duplicate_names) - end; - let implicits = List.map (fun { name; implicit_status = i } -> (name,i)) args in diff --git a/vernac/declare.ml b/vernac/declare.ml index eedbee852b..28e6f21d41 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -642,14 +642,32 @@ let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = dref (* Preparing proof entries *) +let error_unresolved_evars env sigma t evars = + let pr_unresolved_evar e = + hov 2 (str"- " ++ Printer.pr_existential_key sigma e ++ str ": " ++ + Himsg.explain_pretype_error env sigma + (Pretype_errors.UnsolvableImplicit (e,None))) + in + CErrors.user_err (hov 0 begin + str "The following term contains unresolved implicit arguments:"++ fnl () ++ + str " " ++ Printer.pr_econstr_env env sigma t ++ fnl () ++ + str "More precisely: " ++ fnl () ++ + v 0 (prlist_with_sep cut pr_unresolved_evar (Evar.Set.elements evars)) + end) + +let check_evars_are_solved env sigma t = + let t = EConstr.of_constr t in + let evars = Evarutil.undefined_evars_of_term sigma t in + if not (Evar.Set.is_empty evars) then error_unresolved_evars env sigma t evars let prepare_definition ~info ~opaque ~body ~typ sigma = let { Info.poly; udecl; inline; _ } = info in let env = Global.env () in - Pretyping.check_evars_are_solved ~program_mode:false env sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf typ) in + Option.iter (check_evars_are_solved env sigma) types; + check_evars_are_solved env sigma body; let univs = Evd.check_univ_decl ~poly sigma udecl in let entry = definition_entry ~opaque ~inline ?types ~univs body in let uctx = Evd.evar_universe_context sigma in @@ -1717,11 +1735,7 @@ let return_proof ps = List.map (fun (((_ub, body),eff),_) -> (body,eff)) p, uctx let update_global_env = - map ~f:(fun p -> - let { Proof.sigma } = Proof.data p in - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in - p) + map ~f:(fun p -> Proof.update_sigma_env p (Global.env ())) let next = let n = ref 0 in fun () -> incr n; !n diff --git a/vernac/declare.mli b/vernac/declare.mli index c5a8afbad5..3001d0d206 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -117,8 +117,7 @@ end normalized w.r.t. the passed [evar_map] [sigma]. Universes should be handled properly, including minimization and restriction. Note that [sigma] is checked for unresolved evars, thus you should be - careful not to submit open terms or evar maps with stale, - unresolved existentials *) + careful not to submit open terms *) val declare_definition : info:Info.t -> cinfo:EConstr.t option CInfo.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d540e7f93d..548f59559a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -345,17 +345,21 @@ let dump_universes_gen prl g s = close (); Exninfo.iraise reraise -let universe_subgraph ?loc g univ = +let universe_subgraph ?loc kept univ = let open Univ in let sigma = Evd.from_env (Global.env()) in - let univs_of q = + let parse q = let q = Glob_term.(GType q) in (* this function has a nice error message for not found univs *) - LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) + Pretyping.interp_known_glob_level ?loc sigma q in - let univs = List.fold_left (fun univs q -> LSet.union univs (univs_of q)) LSet.empty g in - let csts = UGraph.constraints_for ~kept:(LSet.add Level.prop (LSet.add Level.set univs)) univ in - let univ = LSet.fold UGraph.add_universe_unconstrained univs UGraph.initial_universes in + let kept = List.fold_left (fun kept q -> LSet.add (parse q) kept) LSet.empty kept in + let csts = UGraph.constraints_for ~kept univ in + let add u newgraph = + let strict = UGraph.check_constraint univ (Level.set,Lt,u) in + UGraph.add_universe u ~lbound:UGraph.Bound.Set ~strict newgraph + in + let univ = LSet.fold add kept UGraph.initial_universes in UGraph.merge_constraints csts univ let print_universes ?loc ~sort ~subgraph dst = |